Thanks bluatigro.
I shall add the worry sim.
Each contact increases anxiety.
The more anxiety the blacker.
Code: Select all
Type ball
x As Single 'position x component
y As Single 'position y component
dx As Single 'velocity x component
dy As Single 'velocity y component
col As Ulong 'colour
As Long r,m 'radius, mass
As Single dr 'contact variable
as long done
End Type
#define map(a,b,x,c,d) ((d)-(c))*((x)-(a))/((b)-(a))+(c)
#define range(f,l) Int(Rnd*((l+1)-(f))+(f))
Screen 20,32
Dim Shared As Integer xres,yres
Dim Shared As Any Ptr row:row=Screenptr
Dim Shared As Integer pitch
Screeninfo xres,yres,,,pitch
Sub _circle(b As ball)
#define incircle(cx,cy,radius,x,y) (cx-x)*(cx-x) +(cy-y)*(cy-y)<= radius*radius
#define onscreen x>=0 And x<xres And y>.0 And y<yres
#define putpixel(_x,_y,colour) *Cptr(Ulong Ptr,row+ (_y)*pitch+ (_x) Shl 2) =(colour)
Dim As Ulong tc
For x As Long=b.x-b.r To b.x+b.r
For y As Long=b.y-b.r To b.y+b.r
If incircle(b.x,b.y,b.r,x,y) Andalso onscreen Then
If incircle(b.x,b.y,b.dr,x,y) Then
putpixel(x,y,0)
Else
putpixel(x,y,b.col)
end if
End If
Next
Next
End Sub
Sub MoveAndDraw( b() As ball,Byref e As Long,s as string="",f as boolean,byref h as long=0)
e=0
dim as long h2
For n As Long=Lbound(b) To Ubound(b)
if f then if b(n).done=0 then s=" Worrying" else h2+=1
b(n).x+=b(n).dx:b(n).y+=b(n).dy
_circle(b(n))
e+=.5*b(n).m*(b(n).dx*b(n).dx + b(n).dy*b(n).dy)
Next n
h=h2
'if h then s= " End Phase"
if h=ubound(b) then s=" DONE"
End Sub
Sub edges(b() As ball,xres As Long,yres As Long,Byref status As Long=0 ) 'get status also
For n As Long=Lbound(b) To Ubound(b)
If(b(n).x<b(n).r) Then b(n).x=b(n).r: b(n).dx=-b(n).dx
If(b(n).x>xres-b(n).r )Then b(n).x=xres-b(n).r: b(n).dx=-b(n).dx
If(b(n).y<b(n).r)Then b(n).y=b(n).r:b(n).dy=-b(n).dy
If(b(n).y>yres-b(n).r)Then b(n).y=yres-b(n).r:b(n).dy=-b(n).dy
If b(n).x<0 Or b(n).x>xres Then status=0
If b(n).y<0 Or b(n).y>yres Then status=0
Next n
End Sub
Function DetectBallCollisions( B1 As ball,B2 As ball) As Single 'avoid using sqr if they are well seperated
Dim As Long xdiff = B2.x-B1.x
Dim As Long ydiff = B2.y-B1.y
If Abs(xdiff) > (B2.r+B1.r) Then Return 0
If Abs(ydiff) > (B2.r+B1.r) Then Return 0
Var L=Sqr(xdiff*xdiff+ydiff*ydiff)
If L<=(B2.r+B1.r) Then Function=L Else Function=0
End Function
Sub BallCollisions(b() As ball,flag As boolean=0)
For n1 As Long=Lbound(b) To Ubound(b)-1
For n2 As Long=n1+1 To Ubound(b)
Dim As Single L= DetectBallCollisions(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 ln=Sqr(impulsex*impulsex+impulsey*impulsey)
impulsex/=ln'normalize the impulse
impulsey/=ln
'set one ball to nearest non overlap position
b(n1).x=b(n2).x+(b(n2).r+b(n1).r)*impulsex
b(n1).y=b(n2).y+(b(n2).r+b(n1).r)*impulsey
Dim As Single impactx=b(n1).dx-b(n2).dx
Dim As Single impacty=b(n1).dy-b(n2).dy
Dim As Single dot=impactx*impulsex+impacty*impulsey
Dim As Single mn2=b(n1).m/(b(n1).m+b(n2).m),mn1=b(n2).m/(b(n1).m+b(n2).m)
b(n1).dx-=dot*impulsex*2*mn1
b(n1).dy-=dot*impulsey*2*mn1
b(n2).dx+=dot*impulsex*2*mn2
b(n2).dy+=dot*impulsey*2*mn2
If flag Then
b(n1).dr+=.02*b(n1).r:b(n2).dr+=.02*b(n2).r
If b(n1).dr>.95*b(n1).r Then b(n1).dr=.95*b(n1).r:b(n1).done=1
If b(n2).dr>.95*b(n2).r Then b(n2).dr=.95*b(n2).r:b(n2).done=1
End If
End If
Next n2
Next n1
End Sub
Function Regulate(Byval MyFps As Long,Byref fps As Long) As Long
Static As Double timervalue,lastsleeptime,t3,frames
frames+=1
If (Timer-t3)>=1 Then t3=Timer:fps=frames:frames=0
Var sleeptime=lastsleeptime+((1/myfps)-Timer+timervalue)*1000
If sleeptime<1 Then sleeptime=1
lastsleeptime=sleeptime
timervalue=Timer
Return sleeptime
End Function
Dim As ball b(1 To 100)
For n As Long=1 To 100
With b(n)
.x=range(25,(xres-25))
.y=range(25,(yres-25))
.dx=(Rnd-Rnd)*2
.dy=(Rnd-Rnd)*2
.r=18+Rnd*4
.m=.r^2
.col=Rgb(Rnd*255,Rnd*255,Rnd*255)
End With
Next n
Dim As Long e,ctr,fps,h,xpos
Dim As boolean f
dim as string msg
Do
windowtitle "stability "&e
if f=0 then ctr+=1
edges(b(),xres,yres)
BallCollisions(b(),f)
Screenlock
Cls
Draw String(20,20),Str(fps)+" fps " + msg
moveanddraw(b(),e,msg,f,h)
if h then
xpos=map(1,ubound(b),h,(.2*xres),(.8*xres))
line(.2*xres,.9*yres)-(xpos,.92*yres),rgb(0,150,255),bf
line(.2*xres,.9*yres)-(.8*xres,.92*yres),,b
end if
Screenunlock
Sleep regulate(60,fps)
if f=0 then If ctr>300 Then f=true' time for balls to seperate
Loop Until Inkey=Chr(27)