Code: Select all
Type disc
As single x,y 'centre
As Long radius
As Ulong colour
As Any Ptr im
Declare Destructor
End Type
Destructor disc
Imagedestroy im
Print "image destroyed"
Sleep 100
End Destructor
'is x,y in disc c?
Function indisc(c As disc,x As Long,y As Long) As Long
Return (c.x-x)*(c.x-x) +(c.y-y)*(c.y-y)<= c.radius*c.radius
End Function
Function DetectDiscsAreClose( B1 As disc,B2 As disc) As Single
Dim As single xdiff = B2.x-B1.x
Dim As single ydiff = B2.y-B1.y
If Abs(xdiff) > (B2.radius+B1.radius) Then Return 0
If Abs(ydiff) > (B2.radius+B1.radius) Then Return 0
Var L=Sqr(xdiff*xdiff+ydiff*ydiff)
If L<=(B2.radius+B1.radius) Then Function=L Else Function=0
End Function
Sub TouchingDiscs(b() As disc)
For n1 As Long=Lbound(b) To Ubound(b)-1
For n2 As Long=n1+1 To Ubound(b)
Dim As Single L= DetectDiscsAreClose(b(n1),b(n2))
If L Then
Dim As Single impulsex=(b(n1).x-b(n2).x)
Dim As Single impulsey=(b(n1).y-b(n2).y)
Dim As Single lngth=Sqr(impulsex*impulsex+impulsey*impulsey)
impulsex/=lngth
impulsey/=lngth
Dim As Single impactx=-Sgn(b(n1).x-b(n2).x)
Dim As Single impacty=-Sgn(b(n1).y-b(n2).y)
Dim As Single dot=impulsex*impactx+impulsey*impacty
b(n1).x-=dot*impulsex*2
b(n1).y-=dot*impulsey*2
b(n2).x+=dot*impulsex*2
b(n2).y+=dot*impulsey*2
End If
Next n2
Next n1
End Sub
Function map(a As Double,b As Double,x As Double,c As Double,d As Double) As Double
Return (d-c)*(x-a)/(b-a)+c
End Function
Sub drawdiscs(d() As disc)
Static As Any Ptr back
If back=0 Then
back=Imagecreate(800,600,Rgb(255,255,255))
For x As Long=0 To 799
For y As Long=0 To 699
Pset back,(x,y),Rgba(x,x xor y,y,100)
Next
Next
End If
TouchingDiscs(d())
Screenlock
Put(0,0),back,Pset
For n As Long=Lbound(d) To Ubound(d)
Put(d(n).x-d(n).radius,d(n).y-d(n).radius),d(n).im,trans
Next n
Screenunlock
For n As Long=1 To 100000:Next 'wait a bit
End Sub
Sub creatediscs(d() As disc)
For n As Long=Lbound(d) To Ubound(d)
d(n).x=Rnd*800
d(n).y=Rnd*600
d(n).radius=10+Rnd*50
d(n).colour=Rnd*Rgb(255,255,255)
d(n).im=Imagecreate(2*d(n).radius+2,2*d(n).radius+2)
Var c=d(n).colour
Var f=.99
Var rd=Cast(Ubyte Ptr,@c)[2],gr=Cast(Ubyte Ptr,@c)[1],bl=Cast(Ubyte Ptr,@c)[0]
For r As Long= d(n).radius To 0 Step -1
Var r1=map(0,d(n).radius,r,rd,rd\2)
Var g1=map(0,d(n).radius,r,gr,gr\2)
Var b1=map(0,d(n).radius,r,bl,bl\2)
Circle d(n).im,(d(n).radius,d(n).radius),r,Rgb(r1,g1,b1),,,,f
Next r
Next n
End Sub
Sub MoveByMouse(d() As disc,i As Long,mx As Long,my As Long,button As Long)
Dim As Long x=mx,y=my,dx,dy,b
Dim As Long idx=d(i).x-mx,idy=d(i).y-my
While button = 1
drawdiscs(d())
Getmouse mx,my,,button
If mx>0 And my>0 Then
If mx<>x Or my<>y Then
dx = mx - x
dy = my - y
x = mx
y = my
d(i).x=x+dx+idx
d(i).y=y+dy+idy
'don't let active disc off screen (pushed ones are ignored)
If d(i).x< -d(i).radius+5 Then d(i).x=-d(i).radius+5
If d(i).y< -d(i).radius+5 Then d(i).y=-d(i).radius+5
If d(i).x>800+d(i).radius-5 Then d(i).x=800+d(i).radius-5
If d(i).y>600+d(i).radius-5 Then d(i).y=600+d(i).radius-5
End If
End If
Wend
End Sub
Sub mainsub
Screen 19,32,,64
Windowtitle "Push things around, press <ecsape> to end."
Dim As disc d(1 To 20)
creatediscs(d())
Dim As Long mx,my,button,ox,oy
Do
Getmouse mx,my,,button
For n As Long=Lbound(d) To Ubound(d)
If indisc(d(n),mx,my) And button=1 Then 'if mouse is in a disc
movebymouse(d(),n,mx,my,button) 'smooth drag keeping positions intact
Exit For
End If
Next n
drawdiscs(d())
Loop Until Inkey=Chr(27)'escape key
End Sub
'==================
mainsub
End
