作者MiaoMi225 (口苗口米～)
看板CTSH96302
标题●●●●●●●●●●●●●●●●●●●●●●●
时间Mon Jun 8 11:36:13 2009
!!! 滑鼠控制 !!!
module mouseevent
contains
subroutine switch_left
use DFLIB
common /aaa/ x1,y1,s
s=5
ii=setcolor(0)
ii=rectangle_w($gfillinterior,x1-s,y1+s,x1+s,y1-s)
x1=x1-30
ii=setcolor(12)
ii=rectangle_w($gfillinterior,x1-s,y1+s,x1+s,y1-s)
end subroutine
subroutine switch_right
use DFLIB
common /aaa/ x1,y1,s
s=5
ii=setcolor(0)
ii=rectangle_w($gfillinterior,x1-s,y1+s,x1+s,y1-s)
x1=x1+30
ii=setcolor(12)
ii=rectangle_w($gfillinterior,x1-s,y1+s,x1+s,y1-s)
end subroutine
end module
program ballcollision
use DFLIB
use mouseevent
common /aaa/ x1,y1
dimension x(2),y(2),r(2),vx(2),vy(2),dt(2)
real (kind=8) m1,m2
!!! 设定视窗 !!!
xmin=0
xmax=1024
ymin=0
ymax=768
ii=setwindow(.true.,xmin,ymax,xmax,ymin)
open(1,file='user')
ii=setbkcolor(0)
call clearscreen($gclearscreen)
ii=clickmenuqq(loc(winfullscreen))
!!! 球球1号 !!!
m1=1
x(1)=200
y(1)=200
r(1)=20
vx(1)=1
vy(1)=5
dt(1)=0.5
!!! 球球2号 !!!
m2=2
x(2)=400
y(2)=400
r(2)=20
vx(2)=5
vy(2)=1
dt(2)=0.5
!!! 初始点点位置 !!!
y1=384
x1=512
s=5
ii=setcolor(12)
ii=rectangle_w($gfillinterior,x1-s,y1+s,x1+s,y1-s)
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)=0.1
else
dt(k)=0.5
endif
!!! 球球1号跟球球2号 碰撞 !!!
if ( sqrt((x(1)-x(2))**2+(y(1)-y(2))**2) < r(1)+r(2) ) 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)
else
vx(1)=vx(1)
vy(1)=vy(1)
vx(2)=vx(2)
vy(2)=vy(2)
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)+s ) then
goto 99
endif
enddo
enddo
99 end
--
※ 发信站: 批踢踢实业坊(ptt.cc)
◆ From: 140.120.148.4