────────────────────────

[MiaoMi225 (口苗口米～)]

!!! 滑鼠控制 !!!
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)
噓 luiyilun:紅的明顯!!
→ a606155123:顆顆