作者MiaoMi225 (口苗口米～)
看板CTSH96302
标题────────────────────────
时间Mon Jun 8 02:13:49 2009
!!! 滑鼠控制 !!!
module mouseevent
contains
!common /aaa/x1,y1,r
subroutine switch_left
use DFLIB
real(kind=8) x1,y1
common /aaa/x1,y1,r
r=2 ! 点点的大小 !
y1=0
x1=0
s=30 ! 一次移动的距离 !
!!! 消除原轨迹 !!!
ii=setcolor(0)
ii=rectangle_w($gfillinterior , x1-r,y1+r,x1+r,y1-r)
!!! 点点移动 !!!
x1=x1-s
!!! 点点形状 !!!
ii=setcolor(12)
ii=rectangle_w($gfillinterior , x1-r,y1+r,x1+r,y1-r)
end subroutine
subroutine switch_right
use DFLIB
real(kind=8) x1,y1
common /aaa/x1,y1,r
r=1 ! 点点的大小 !
y1=0
x1=0
s=30 ! 一次移动的距离 !
!!! 消除原轨迹
ii=setcolor(0)
ii=rectangle_w($gfillinterior , x1-r,y1+r,x1+r,y1-r)
!!! 点点移动 !!!
x1=x1+s
!!! 点点形状 !!!
ii=setcolor(12)
ii=rectangle_w($gfillinterior , x1-r,y1+r,x1+r,y1-r)
end subroutine
end module
program ballcollision
use DFLIB
use mouseevent
dimension x(2),y(2),r(2),vx(2),vy(2),dt(2)
real (kind=8) m1,m2
!!! 设定视窗 !!!
xmin=-300*1024.0/768.0
xmax=300*1024.0/768.0
ymin=-300
ymax=300
ii=setwindow(.true.,xmin,ymax,xmax,ymin)
ii=setbkcolor(0)
call clearscreen($gclearscreen)
ii=clickmenuqq(loc(winfullscreen))
!!! 球球1号 !!!
m1=1
x(1)=-200
y(1)=-200
r(1)=20
vx(1)=2.0
vy(1)=3.0
dt(1)=1
!!! 球球2号 !!!
m2=2
x(2)=100
y(2)=100
r(2)=20
vx(2)=2.0
vy(2)=3.0
dt(2)=1
!!! 初始点点位置 !!!
y1=0
x1=0
ii=setcolor(12)
ii=rectangle_w($gfillinterior,x1-2,y1+2,x1+2,y1-2)
do while (.true.)
!!! 设定边界 !!!
ii=setcolor(12)
z=50
ii=rectangle_w($gborder,xmin+z,ymax-z,xmax-z,ymin+z)
!!! 碰撞边界弹回 !!!
do k=1,2
if (x(k)>xmax-r(k)-z .or. x(k)<xmin+r(k)+z) then
vx(k)=-vx(k)
endif
if (y(k)>ymax-r(k)-z .or. y(k)<ymin+r(k)+z) then
vy(k)=-vy(k)
endif
!!! 调整靠近边界速度 !!!
b=r(k)+z+10
if (x(k)+r(k)>xmax-b .or. x(k)-r(k)<xmin+b .or. y(k)+r(k)>ymax-b .or. y(k)-r(k)<ymin+b) then
dt(k)=1
else
dt(k)=1
endif
!!! 球球1号跟球球2号 碰撞 !!!
if ( sqrt((x(1)-x(2))**2+(y(1)-y(2))**2) < r(1)+r(2)+1 ) then
vx(1)=((m1+m2)*vx(1)+2*m2*vx(2))/(m1+m2)
vy(1)=((m1+m2)*vy(1)+2*m2*vy(2))/(m1+m2)
vx(2)=((m2-m1)*vx(2)+2*m1*vx(1))/(m1+m2)
vy(2)=((m2-m1)*vy(2)+2*m1*vy(1))/(m1+m2)
endif
!!! 清除痕迹 !!!
ii=setcolor(0)
ii=ellipse_w($gfillinterior,x(k)-r(k),y(k)+r(k),x(k)+r(k),y(k)-r(k))
!!! 设定圆球轨迹 !!!
ii=setcolor(9)
x(k)=x(k)-vx(k)*dt(k)
y(k)=y(k)-vy(k)*dt(k)
ii=ellipse_w($gfillinterior,x(k)-r(k),y(k)+r(k),x(k)+r(k),y(k)-r(k))
call sleepqq(1)
!!! 点点控制 !!!
event=mouse$lbuttondown
ii=RegisterMouseEvent(1,event,switch_left)
event=mouse$rbuttondown
ii=RegisterMouseEvent(1,event,switch_right)
if ( sqrt((x1-x(k))**2+(y1-y(k))**2) < r(k)+3 ) then
go to 99
endif
if ( sqrt((x2-x(k))**2+(y2-y(k))**2) < r(k)+3 ) then
go to 99
endif
enddo
enddo
99 end
--
※ 发信站: 批踢踢实业坊(ptt.cc)
◆ From: 125.230.74.47
※ 编辑: MiaoMi225 来自: 125.230.74.47 (06/08 02:14)
1F：嘘 luiyilun:红的明显!! 06/08 09:57
2F：→ a606155123:颗颗 06/08 10:51