This is slightly less exciting than watching paint dry.

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

End Type

dim shared as any ptr i

Sub MoveAndDraw( b() As ball,Byref e As Single,f As Single)'get energy also

static as long counter,flag

counter+=1

if counter>50 then flag=1:counter=50 'allow time for balls to seperate

For n As Long=Lbound(b) To Ubound(b)

b(n).x+=b(n).dx*f:b(n).y+=b(n).dy*f

if flag then Circle(b(n).x,b(n).y),b(n).r,b(n).col,,,,f

e+=(.5*b(n).m*(b(n).dx*b(n).dx + b(n).dy*b(n).dy))

Next n

e*=f

Draw String(b(0).x-16,b(0).y-8),"<-->",Rgb(200,0,0)

if flag then pset i,(b(1).x,b(1).y)

End Sub

Sub Edgecollisions(b() As ball,xres As Long,yres As Long,Byref status As Long ) 'get status also

Const k=50

For n As Long=Lbound(b)+1 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-k)Then b(n).y=yres-b(n).r-k: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)

For n1 As Long=Lbound(b)+1 To Ubound(b)-1

For n2 As Long=n1+1 To Ubound(b)

If DetectBallCollisions(b(n1),b(n2)) 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 ~digital to analogue workaround

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

End If

Next n2

Next n1

End Sub

'steady framerate

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

Sub display(b() As ball,xres As Long,yres As Long,f As Single=0)'all graphics

#define map(a,b,x,c,d) ((d)-(c))*((x)-(a))/((b)-(a))+(c)

Dim As Long status=1

Edgecollisions(b(),xres,yres,status)

BallCollisions(b())

f=map((xres/2-300+20),(xres/2+300-20),b(0).x,0,2)

Static As Long frate

Dim As Single energy

Screenlock

Cls

put(0,0),i,trans

Line(0,768-50)-(1024,768-50),,b

Var h=xres/2

Line(h-300,768-48)-(h+300,yres-2),Rgb(100,100,100),bf

MoveAndDraw(b(),energy,f)

Draw String(10,yres-45), "framerate " &frate , Rgb(0, 200, 0)

Draw String (10,yres-30),"System energy " &energy

Draw String (h+310,yres-45),"System status " & Iif(status,"OK","Leaks")

Screenunlock

Sleep regulate(65,frate)

End Sub

Sub MoveByMouse(d() As ball,mx As Long,my As Long,button As Long,xres As Long,yres As Long)

Dim As Long x=mx,y=my,dx,dy,b

Dim As Long idx=d(0).x-mx,idy=d(0).y-my

While button = 1

If my<yres-50 Then Exit Sub

display(d(),xres,yres)

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(0).x=x+dx+idx

If d(0).x<xres/2-300+20 Then d(0).x=xres/2-300+20

If d(0).x>xres/2+300-20 Then d(0).x=xres/2+300-20

End If

End If

Wend

End Sub

Function Start() As Long

Windowtitle "Brownian motion by mouse --- <esc> to end"

#define range(f,l) Int(Rnd*(((l)+1)-(f)))+(f)

#define incircle(cx,cy,radius,x,y) (cx-x)*(cx-x) +(cy-y)*(cy-y)<= radius*radius

Dim As ball b(0 To 300)

Dim As Integer xres,yres

Screen 20,32

Color ,Rgb(0,0,50)

Screeninfo xres,yres

i=imagecreate(xres,yres)

b(0).x=xres/2:b(0).y=743:b(0).col=Rgb(255,255,255):b(0).r=20 'moveable circle by mouse

b(1).x=xres/2:b(1).y=yres/2:b(1).col=Rgb(255,255,255):b(1).r=30:b(1).m=b(1).r^2 'large circle

For n As Long=Lbound(b)+2 To Ubound(b)

With b(n)

Do

.x=range(20,(xres-20))

.y=range(20,(yres-150))

Loop Until incircle(b(1).x,b(1).y,2*b(1).r,.x,.y)=0

.dx=(Rnd-Rnd)*2

.dy=(Rnd-Rnd)*2

.col=Rgb(Rnd*255,Rnd*255,Rnd*255)

.r=10+Rnd*8

.m=.r^2

End With

Next

Dim As Long mx,my,btn

While 1

Getmouse mx,my,,btn

display(b(),xres,yres)

If incircle(b(0).x,b(0).y,b(0).r,mx,my) And btn=1 Then

MoveByMouse(b(),mx,my,btn,xres,yres)

End If

If Inkey=Chr(27) Then Exit While

Wend

Return 0

End Function

end Start

imagedestroy i

Sleep