billiard style ball movement
billiard style ball movement
deleted
Last edited by alfakilo on Jul 07, 2014 19:41, edited 1 time in total.
To avoid flickering (due to 'Cls' instruction in the loop), lock the automatic window refresh during the graphic drawing instructions only, using 'ScreenLock' then 'ScreenUnLock' statement.
http://www.freebasic.net/wiki/wikka.php ... Screenlock
http://www.freebasic.net/wiki/wikka.php ... reenunlock
http://www.freebasic.net/wiki/wikka.php ... Screenlock
http://www.freebasic.net/wiki/wikka.php ... reenunlock
Code: Select all
#Include "fbgfx.bi"
ScreenRes 1000, 800, 32
Color RGB(255, 25, 25), RGB(205, 205, 255)
Dim Shared As Integer mx, my, mb '' mouse position, buttons
Const PI = 3.141593
Dim Shared As single resultanglerad
Dim Shared As single resultangledeg
Declare Sub mm(i As Integer)
'Player ball
Dim x As Single=50
Dim y As Single=350
Dim force As Single=0
'Other balls
Type unittype
x1 As Single
y1 As Single
force1 As single
End Type
Dim Shared unit1() As unittype:ReDim unit1(1 To 10)
'positions for them
unit1(1).x1=150
unit1(1).y1=250
unit1(2).x1=170
unit1(2).y1=250
unit1(3).x1=190
unit1(3).y1=250
unit1(4).x1=210
unit1(4).y1=250
unit1(5).x1=230
unit1(5).y1=250
unit1(6).x1=150
unit1(6).y1=450
unit1(7).x1=170
unit1(7).y1=450
unit1(8).x1=190
unit1(8).y1=450
unit1(9).x1=210
unit1(9).y1=450
unit1(10).x1=230
unit1(10).y1=450
Do 'MAIN LOOP
Sleep 15
Getmouse( mx, my, , mb )
Screenlock
Cls
Locate 1:Print "FORCE " & force
Line (x, y)-(mx, my), 6
Circle (x, y), 10, &H20FFFF00,,, 1, F
For i As Integer=1 To 10
Circle (unit1(i).x1, unit1(i).y1), 10, &H20FF0000,,, 1, F
Next
Screenunlock
resultanglerad = ATAN2((-1)*(my-y),(mx-x))'UNIT ANGLE
resultanglerad = PI/2 - resultanglerad:resultangledeg = (resultanglerad*180)/PI
If mb=1 And force<1 Then force=10
If force>0 Then
force-=0.1
x = x + sin(resultanglerad)*force
y = y - cos(resultanglerad)*force
endif
'CHECKING COLLISION WITH PLAYER OBJECT
For i As Integer=1 To 10
If Abs(x-unit1(i).x1)<20 And Abs(y-unit1(i).y1)<20 Then unit1(i).force1=force:force-=1.5
resultanglerad = ATAN2((-1)*(y-unit1(i).y1),(x-unit1(i).x1))'UNIT ANGLE
resultanglerad = PI/2 - resultanglerad:resultangledeg = (resultanglerad*180)/PI
If unit1(i).force1>0 Then
unit1(i).force1-=0.1
unit1(i).x1 = unit1(i).x1 - sin(resultanglerad)*unit1(i).force1
unit1(i).y1 = unit1(i).y1 + cos(resultanglerad)*unit1(i).force1
EndIf
mm(i)
Next
If x<5 Then x=500:force=0
If y<5 Then y=400:force=0
If x>995 Then x=500:force=0
If y>795 Then y=400:force=0
Loop While Not Multikey(FB.SC_ESCAPE)
'check collision for each other
Sub mm(i As Integer)
For i2 As Integer=i+1 To 10
If Abs(unit1(i).x1-unit1(i2).x1)<20 And Abs(unit1(i).y1-unit1(i2).y1)<20 Then unit1(i2).force1=unit1(i).force1
Next
End Sub
To avoid flickering, you can also you 2 screen pages (ScreenRes 1000, 800, 32, 2) and use ScreenSet to filp between them.
Interestingly you can modify the direction a bit after the strike (push / kick).
The math does not seem right, the balls do not move as expected. Sometimes too fast, too slow, sticky or making curves. Or is the last one a spin effect?
You could check collisions between the red balls as well, with a nested loop:
If speed becomes important, you can use vector maths as well to prevent the use of slow atan, sin, cos
Interestingly you can modify the direction a bit after the strike (push / kick).
The math does not seem right, the balls do not move as expected. Sometimes too fast, too slow, sticky or making curves. Or is the last one a spin effect?
You could check collisions between the red balls as well, with a nested loop:
Code: Select all
for i = 1 to 10
for j = i+1 to 10
'check collision between unit(i) and unit(j)
'if collision modify forces on these two
next
next- Yes, because on a PC faster, the flickering is very annoying (mine: Intel Core 2 Duo P8400 / 2.26 GHz)!alfakilo wrote:My PC is too slow that i didnt seen any flickering in my pc.
Yes I know that I can use screenlock and screenunlock(thanks for telling anyway)
- When the graphic drawing time is short and we allow time for the system (sleep 15), we can use the method 'ScreenLock/ScreenUnLock' (just around graphic instructions) that has the merit of being simple and less penalizing (in time). Otherwise we must implement the method of double buffering 'ScreenSet/ScreenCopy'.
Possibly of interest, related posts:
http://www.freebasic.net/forum/viewtopi ... t=tutorial
http://www.freebasic.net/forum/viewtopi ... t=tutorial
http://www.freebasic.net/forum/viewtopi ... t=tutorial
http://www.freebasic.net/forum/viewtopi ... t=tutorial
A handy lib that I made for this purpose:
http://www.freebasic.net/forum/viewtopic.php?t=17333
Especially check out the test.bas example.
http://www.freebasic.net/forum/viewtopic.php?t=17333
Especially check out the test.bas example.
I've been messing around a bit with these collisions, more pool than billiards, and just as a non-interactive viewer.
I'm working on a bounce off any line algo, will post here when finished, if you like.
I'm working on a bounce off any line algo, will post here when finished, if you like.
Code: Select all
Type d2
As Single mx,my,mw,ang
End Type
Operator + (v1 As d2,v2 As d2) As d2
Return Type<d2>(v1.mx+v2.mx,v1.my+v2.my,v1.mw+v2.mw,v1.ang+v2.ang)
End Operator
Operator -(v1 As d2,v2 As d2) As d2
Return Type<d2>(v1.mx-v2.mx,v1.my-v2.my,v1.mw-v2.mw)
End Operator
Operator * Overload (f As Single,v1 As d2) As d2 'scalar*d2
Return Type<d2>(f*v1.mx,f*v1.my,f*v1.mw)
End Operator
Operator * Overload (v1 As d2,v2 As d2) As Single 'dot product
Return v1.mx*v2.mx+v1.my*v2.my+v1.mw*v2.mw
End Operator
#define dot *
#define length(v) sqr(v.mx*v.mx+v.my*v.my)
#define normalize(v) Type<d2>(v.mx/length(v),v.my/length(v))
#define rr(f,l) Csng(Rnd*(l-f)+f)
Dim As Integer n=3
Dim balls(1 To n) As d2
Dim direction(1 To n) As d2
Dim collision(1 To n) As Integer
Sub draw_balls(b As d2)
#macro rotate(pivotx,pivoty,px,py,a,scale)
var Newx=scale*(Cos(a*.0174533)*(px-pivotx)-Sin(a*.0174533)*(py-pivoty))+pivotx
var Newy=scale*(Sin(a*.0174533)*(px-pivotx)+Cos(a*.0174533)*(py-pivoty))+pivoty
#endmacro
#macro incircle(cx,cy,radius,x,y)
(cx-x)*(cx-x) +(cy-y)*(cy-y)<= radius*radius
#endmacro
If b.mw=0 Then b.mw=1
b.mw=Abs(b.mw)
If b.mw=1 Then Circle(b.mx,b.my),40,0:Exit Sub
Redim As Uinteger array(1)
Dim As Integer count
For x As Integer=b.mx-40 To b.mx+40
For y As Integer=b.my-40 To b.my+40
If incircle(b.mx,b.my,40,x,y) Then
count=count+1
Redim Preserve array(count)
array(count)=Point(x,y)
End If
Next y
Next x
count=0
Dim As Single dil
For x As Integer=b.mx-40 To b.mx+40
For y As Integer=b.my-40 To b.my+40
If incircle(b.mx,b.my,40,x,y) Then
count=count+1
rotate(b.mx,b.my,x,y,b.ang,dil)
var dist=Sqr((b.mx-newx)*(b.mx-newx)+(b.my-newy)*(b.my-newy))
dil=(b.mw+(1-b.mw)*dist/(40*b.mw))
If incircle(b.mx,b.my,(20*b.mw),newx,newy) Then
Line(NewX-dil/2,NewY-dil/2)-(NewX+dil/2,NewY+dil/2),array(count),BF
End If
End If
Next y
Next x
'circle(b.mx,b.my),20*b.mw
End Sub
Sub framecounter
Static As Single frame,fps
frame=frame+1
Static As Single t1,t2
If frame>=fps Then
t1 = Timer
fps = frame/(t1-t2)
Windowtitle "Frames per second = " & fps
t2=Timer
frame=0
End If
End Sub'
Dim As Any Pointer im
Dim As Integer xres,yres
Screen 19
Screeninfo xres,yres
im=imagecreate(xres,yres)
'draw background to image _________________________-
Paint im,(0,0),4
For x As Integer=0 To xres
For y As Integer=0 To yres
If x Mod 50=0 Then Circle im,(x,y),Rnd*10,Int(Rnd*30)
If y Mod 50=0 Then Circle im,(x,y),Rnd*10,Int(Rnd*30)
If x Mod 50=0 And y Mod 50=0 Then Draw String im,(x+25,y-30),Chr(Rnd*128)
Next y
Next x
'_______________________
Dim As Single seperation,temp
For z As Integer=1 To n 'set positions
balls(z).mx=rr(150,150)+seperation
balls(z).my=rr(150,150)+seperation
seperation=seperation+150
balls(z).mw=Sqr(z)+2
balls(z).ang=rr(-100,100)
Next z
balls(n).mw=1.5
For z As Integer=1 To n 'set speeds
temp=rr(.5,1.5)
direction(z).mx=temp
direction(z).my=temp
Next z
' _________Collision macros_____________________
Dim As Single dt
Dim As d2 impulse,impact
#macro check_side_collisions()
For z2 As Integer=1 To n
#macro redirect()
impact=-1*direction(z2)
dt=impact dot impulse
direction(z2)=direction(z2)+2*dt*impulse
#endmacro
If balls(z2).mx<20*balls(z2).mw Then
impulse=Type<d2>(1,0,0)
redirect()
End If
If balls(z2).mx>xres-20*balls(z2).mw Then
impulse=Type<d2>(-1,0,0)
redirect()
End If
If balls(z2).my>yres-20*balls(z2).mw Then
impulse=Type<d2>(0,-1,0)
redirect()
End If
If balls(z2).my<20*balls(z2).mw Then
impulse=Type<d2>(0,1,0)
redirect()
End If
Next z2
#endmacro
#macro check_ball_to_ball_collisions()
For xx As Integer=1 To n
For yy As Integer=1 To n
If xx<>yy Then
If collision(xx)+collision(yy)<2 Then
If length((balls(xx)-balls(yy)))<=20*balls(xx).mw+20*balls(yy).mw Then
impulse=normalize((balls(xx)-balls(yy)))
impact=direction(xx)-direction(yy)
dt=(impact dot impulse)
var mxx=balls(xx).mw*balls(xx).mw 'the ball (weights)
var myy=balls(yy).mw*balls(yy).mw
direction(xx)=direction(xx)-dt*(2*myy/(mxx+myy))*impulse
direction(yy)=direction(yy)+dt*(2*mxx/(myy+mxx))*impulse
collision(xx)=1
collision(yy)=1
End If 'seperation
End If 'collisions
End If'xx/yy
Next yy
Next xx
#endmacro
' ______________________________________________________
Dim callcount As Integer
Do
callcount=callcount+1
If callcount>1e6 Then callcount=0
check_side_collisions()
check_ball_to_ball_collisions()
Screenlock
Cls
Put(0,0),im
For z As Integer=1 To n
balls(z).ang=balls(z).ang+.5
balls(z)=balls(z)+direction(z)
draw_balls(balls(z))
'damper when needed
If length(direction(z))>2.5 Then direction(z)=.999*direction(z)
If length(direction(z))<.2 Then direction(z)=1.01*direction(z)
'reset collisions
If callcount Mod 4=0 Then
If collision(z)=1 Then collision(z)=0
End If
Next z
framecounter
Screenunlock
Sleep 1,1
Loop Until Inkey=Chr(27)
imagedestroy im
Sleep
Here's an old port which uses impulses. It preserves energy perfectly, but the code may be a little hard to read.
Here's another thread dealing with the same subject:
http://www.freebasic.net/forum/viewtopi ... ht=impulse
Cheers,
Mike
Here's another thread dealing with the same subject:
http://www.freebasic.net/forum/viewtopi ... ht=impulse
Cheers,
Mike
Code: Select all
'' physics engine that simulates bouncing balls using vector math
'' This code is based on the 2D elastic collision tutorial found at:
'' http://www.geocities.com/vobarian/2dcollisions/
Randomize Timer
Type Vector_2D
As Single X, Y
End Type
Type Ball
As Uinteger Col
As Vector_2D Pos_New, Vel
As Single Mass, Density, Radius
End Type
Declare Function Vector_Sub (Byref v1 As Vector_2D, Byref v2 As Vector_2D) As Vector_2D
Declare Function Vector_Add (Byref v1 As Vector_2D, Byref v2 As Vector_2D) As Vector_2D
Declare Function Vector_Magnitude (Byref vector As vector_2d) As Single
Declare Function Vector_Normalize (Byref vector As vector_2d) As Vector_2D
Declare Function Dot_Product (Byref v1 As vector_2d, Byref v2 As vector_2d) As Single
Declare Function Vector_Scalar_Mul (Byref s1 As Single, Byref v1 As vector_2d) As vector_2D
Declare Sub DoElasticCollision (Byref Ball_1 As Ball, Byref Ball_2 As Ball)
Const Pi = 4*Atn(1)
Dim As Vector_2D Dist
Dim As Single Distance, Dist_Min
Dim As String X_Clicked = Chr(255)+"k"
Dim As Integer Screen_x, Screen_Y, i, i2
Dim Ball(1 to 5) As Ball
'' screen settings
screen_x = 600 '' screen width
screen_y = 400 '' screen height
screenres screen_x, screen_y, 16
With Ball(1)
.Mass = 10
.Density = 0.001
.Radius = (((.Mass/.Density)/((4/3)*pi))^(1/3))
.Pos_New.X = 100
.Pos_New.Y = Screen_Y\2
.Vel.X = 0
.Vel.Y = 0
.Col = RGB(255, 32, 32)
End With
With Ball(2)
.Mass = 20
.Density = 0.001
.Radius = (((.Mass/.Density)/((4/3)*pi))^(1/3))
.Pos_New.X = 200
.Pos_New.Y = (Screen_Y\2)
.Vel.X = 0
.Vel.Y = 0
.Col = RGB(255, 32, 255)
End With
With Ball(3)
.Mass = 40
.Density = 0.001
.Radius = (((.Mass/.Density)/((4/3)*pi))^(1/3))
.Pos_New.X = 300
.Pos_New.Y = (Screen_Y\2)
.Vel.X = 0
.Vel.Y = 0
.Col = RGB(32, 32, 255)
End With
With Ball(4)
.Mass = 80
.Density = 0.001
.Radius = (((.Mass/.Density)/((4/3)*pi))^(1/3))
.Pos_New.X = 400
.Pos_New.Y = (Screen_Y\2)
.Vel.X = 0
.Vel.Y = 0
.Col = RGB(32, 255, 32)
End With
With Ball(5)
.Mass = 160
.Density = 0.001
.Radius = (((.Mass/.Density)/((4/3)*pi))^(1/3))
.Pos_New.X = 500
.Pos_New.Y = (Screen_Y\2)
.Vel.X = -2
.Vel.Y = -(Rnd-Rnd)/3
.Col = RGB(255, 255, 32)
End With
Do
Screenlock
cls
For i = Lbound(Ball) to Ubound(Ball)
With Ball(i)
''ball - wall collision detection
If .Pos_New.X > screen_x-.Radius-1 Then
.Pos_New.X = screen_x-.Radius-1
.Vel.X = -.Vel.X
Elseif .Pos_New.X < .Radius Then
.Pos_New.X = .Radius
.Vel.X = -.Vel.X
End If
If .Pos_New.Y > screen_y-.Radius-1 Then
.Pos_New.Y = screen_y-.Radius-1
.Vel.Y = -.Vel.Y
Elseif .Pos_New.Y < .Radius Then
.Pos_New.Y = .Radius
.Vel.Y = -.Vel.Y
End If
'' ball - ball collision detection
For i2 = i+1 to Ubound(Ball)
Dist = Vector_Sub(.Pos_New, Ball(i2).Pos_New)
Distance = Vector_Magnitude(Dist)
Dist_Min = .Radius+Ball(i2).Radius
'' elastic bounce
If Distance <= Dist_Min Then
DoElasticCollision(Ball(i), Ball(i2))
End If
Next
.Pos_New = Vector_Add(.Pos_New, .Vel)
Circle (.Pos_New.X, .Pos_New.Y), .Radius, .col,,,1,f
End With
Next
screenunlock
sleep 1, 1
Loop Until Multikey(1) Or Inkey = X_Clicked
End
'-------------------------------------------------------------------------------
Function Vector_Sub (Byref v1 As Vector_2D, Byref v2 As Vector_2D) As Vector_2D
Dim As Vector_2D v
v.x = v1.x-v2.x
v.y = v1.y-v2.y
Return v
End Function
Function Vector_Add (Byref v1 As Vector_2D, Byref v2 As Vector_2D) As Vector_2D
Dim As Vector_2D v
v.x = v1.x+v2.x
v.y = v1.y+v2.y
Return v
End Function
Function Vector_Magnitude (Byref vector As vector_2d) As Single
Dim as Single x, y, r
x = Vector.x^2
y = Vector.y^2
r = Sqr(x+y)
Return r
End Function
Function Vector_Normalize (Byref vector As vector_2d) As Vector_2D
Dim As Vector_2D v
Dim as Single r
r = Vector_Magnitude(Vector)
v.x = vector.x/r
v.y = vector.y/r
Return v
End Function
Function Dot_Product (Byref v1 As vector_2d, Byref v2 As vector_2d) As Single
Return v1.x*v2.x+v1.y*v2.y
End Function
Function Vector_Scalar_Mul (Byref s1 As Single, Byref v1 As vector_2d) As vector_2D
Dim as Vector_2d v
v.x = v1.x*s1
v.y = v1.y*s1
Return v
End Function
Sub DoElasticCollision (Byref Ball_1 As Ball, Byref Ball_2 As Ball)
Dim As Vector_2D v_n, v_un, v_ut, v_v1tPrime, v_v2tPrime, v_v1nPrime, v_v2nPrime
Dim As Single v1n, v1t, v2n, v2t, v1tPrime, v2tPrime, v1nPrime, v2nPrime
'' vector normal to collision surface
v_n = Vector_Sub(Ball_2.Pos_New, Ball_1.Pos_New)
'' normalize vector - make it a unit vector
v_un = Vector_Normalize(v_n)
'' unit tangenti vector
v_ut.x = -v_un.y
v_ut.y = v_un.x
'' old normal and tangential velocity vectors
v1n = Dot_Product(v_un, Ball_1.vel)
v1t = Dot_Product(v_ut, Ball_1.vel)
v2n = Dot_Product(v_un, Ball_2.vel)
v2t = Dot_Product(v_ut, Ball_2.vel)
'' new tangential velocity (uncanged)
v1tPrime = v1t
v2tPrime = v2t
'' new normal velocity
v1nPrime = ((v1n * (ball_1.mass - ball_2.mass) + 2 * ball_2.mass * v2n)) / (ball_1.mass + ball_2.mass)
v2nPrime = ((v2n * (ball_2.mass - ball_1.mass) + 2 * ball_1.mass * v1n)) / (ball_1.mass + ball_2.mass)
'' new normal and tangential velocity vectors
v_v1nPrime = Vector_scalar_mul(v1nPrime, v_un)
v_v1tPrime = Vector_scalar_mul(v1tPrime, v_ut)
v_v2nPrime = Vector_scalar_mul(v2nPrime, v_un)
v_v2tPrime = Vector_scalar_mul(v2tPrime, v_ut)
'' new ball velocities
Ball_1.Vel = Vector_Add(v_v1nPrime, v_v1tPrime)
Ball_2.Vel = Vector_Add(v_v2nPrime, v_v2tPrime)
End Sub
Hi h4tt3nh4tt3n wrote:Here's an old port which uses impulses. It preserves energy perfectly, but the code may be a little hard to read.
Thanks for the links, but geocities is no more.
I've tried to keep the spheres in my post mathematically correct, for doodles anyway.
However to be a bit more pedantic, I've altered the masses to radius^3, representing a sphere rather than a disk.
I show the kinetic energy of the system now as .5*M*v^2, where M is the mass of each sphere assuming unit density.
I've still a little more to do with registering a side impact, but I've ommited that just now, and hope there is not a jam up.
Also, I've removed all damping so the motion is (as is).
Ive outlined the spheres and added a line segment in a really awkward place to test to destruction.
The frame rate fluctuates a bit for there is a bit of overhead in drawing the spheres.
I see that you are quite keen on this kind of stuff, and it is quite an interesting topic, but I wouldn't call it Physics, not until angular momentum of the spheres is considered.
It's SATURDAY night, so I'm going up to the County Hotel for a beer and a game of real POOL.
Code: Select all
Type d2
As Single mx,my,mw,ang
End Type
'ADD A LINE__________
Type line3d
As d2 v1,v2
End Type
dim as d2 linestart
linestart=type<d2>(300,100,0,0)
dim as d2 lineend
lineend=type<d2>(500,130,0,0)
dim as line3d linesegment(1)
linesegment(1)=type<line3d>(linestart,lineend)
linesegment(0).v1.mw=1
'_________________________
Operator + (v1 As d2,v2 As d2) As d2
Return Type<d2>(v1.mx+v2.mx,v1.my+v2.my,v1.mw+v2.mw,v1.ang+v2.ang)
End Operator
Operator -(v1 As d2,v2 As d2) As d2
Return Type<d2>(v1.mx-v2.mx,v1.my-v2.my,v1.mw-v2.mw)
End Operator
Operator * Overload (f As Single,v1 As d2) As d2 'scalar*d2
Return Type<d2>(f*v1.mx,f*v1.my,f*v1.mw)
End Operator
Operator * Overload (v1 As d2,v2 As d2) As Single 'dot product
Return v1.mx*v2.mx+v1.my*v2.my+v1.mw*v2.mw
End Operator
#define dot *
#define length(v) sqr(v.mx*v.mx+v.my*v.my)
#define normalize(v) Type<d2>(v.mx/length(v),v.my/length(v))
#define rr(f,l) Csng(Rnd*(l-f)+f)
Sub drawline(l As line3d,col As Uinteger)
for k as integer=-4 to 4
Line(l.v1.mx,l.v1.my+k)-(l.v2.mx,l.v2.my+k),col
next k
End Sub
Function drop_perpendicular(p As d2,L2 As line3d) As d2
Dim As Double M1,M2,C1,C2
Dim As d2 pt
M2=(L2.v2.my-L2.v1.my)/(L2.v2.mx-L2.v1.mx)
M1=-1/M2
C1=p.my-M1*p.mx
C2=(L2.v1.my*L2.v2.mx-L2.v1.mx*L2.v2.my)/(L2.v2.mx-L2.v1.mx)
pt.mx=(C2-C1)/(M1-M2)
pt.my=(M1*C2-M2*C1)/(M1-M2)
Return pt
End Function
Function segmentdistance(L() As line3d,p As d2,Byref p2 As d2=type<d2>(0,0,0)) As Single
Dim As d2 near,far,pp
Dim n As Integer=L(0).v1.mw
If length((p-L(n).v1)) > length((p-L(n).v2)) Then
far=L(n).v1
near=L(n).v2
Else
far=L(n).v2
near=L(n).v1
End If
pp=drop_perpendicular(p,L(n))
If length((far-pp))<length((L(n).v1-L(n).v2)) Then
p2=pp
Return length((p-pp))
Else
p2=near
Return length((p-near))
End If
End Function
Dim As Integer n=3
Dim balls(1 To n) As d2
Dim direction(1 To n) As d2
Dim collision(1 To n) As Integer
Sub draw_balls(b As d2)
#macro rotate(pivotx,pivoty,px,py,a,scale)
var Newx=scale*(Cos(a*.0174533)*(px-pivotx)-Sin(a*.0174533)*(py-pivoty))+pivotx
var Newy=scale*(Sin(a*.0174533)*(px-pivotx)+Cos(a*.0174533)*(py-pivoty))+pivoty
#endmacro
#macro incircle(cx,cy,radius,x,y)
(cx-x)*(cx-x) +(cy-y)*(cy-y)<= radius*radius
#endmacro
If b.mw=0 Then b.mw=1
b.mw=Abs(b.mw)
If b.mw=1 Then Circle(b.mx,b.my),40,0:Exit Sub
Redim As Uinteger array(1)
Dim As Integer count
For x As Integer=b.mx-40 To b.mx+40
For y As Integer=b.my-40 To b.my+40
If incircle(b.mx,b.my,40,x,y) Then
count=count+1
Redim Preserve array(count)
array(count)=Point(x,y)
End If
Next y
Next x
count=0
Dim As Single dil
For x As Integer=b.mx-40 To b.mx+40
For y As Integer=b.my-40 To b.my+40
If incircle(b.mx,b.my,40,x,y) Then
count=count+1
rotate(b.mx,b.my,x,y,b.ang,dil)
var dist=Sqr((b.mx-newx)*(b.mx-newx)+(b.my-newy)*(b.my-newy))
dil=(b.mw+(1-b.mw)*dist/(40*b.mw))
If incircle(b.mx,b.my,(20*b.mw),newx,newy) Then
Line(NewX-dil/2,NewY-dil/2)-(NewX+dil/2,NewY+dil/2),array(count),BF
End If
End If
Next y
Next x
circle(b.mx,b.my),20*b.mw
End Sub
Sub framecounter
Static As Single frame,fps
frame=frame+1
Static As Single t1,t2
If frame>=fps Then
t1 = Timer
fps = frame/(t1-t2)
Windowtitle "Frames per second = " & fps
t2=Timer
frame=0
End If
End Sub'
Dim As Any Pointer im
Dim As Integer xres,yres
Screen 19
Screeninfo xres,yres
im=imagecreate(xres,yres)
'draw background to image _________________________-
Paint im,(0,0),4
For x As Integer=0 To xres
For y As Integer=0 To yres
If x Mod 50=0 Then Circle im,(x,y),Rnd*10,Int(Rnd*30)
If y Mod 50=0 Then Circle im,(x,y),Rnd*10,Int(Rnd*30)
If x Mod 50=0 And y Mod 50=0 Then Draw String im,(x+25,y-30),Chr(Rnd*128)
Next y
Next x
'_______________________
Dim As Single seperation,temp
For z As Integer=1 To n 'set positions
balls(z).mx=rr(150,150)+seperation
balls(z).my=rr(150,150)+seperation
seperation=seperation+150
balls(z).mw=Sqr(z)+1.5
balls(z).ang=rr(-100,100)
Next z
balls(n).mw=1.5
For z As Integer=1 To n 'set speeds
temp=rr(.5,1.5)
direction(z).mx=temp
direction(z).my=temp
Next z
' _________Collision macros_____________________
Dim As Single dt
Dim As d2 impulse,impact
#macro check_side_collisions()
For z2 As Integer=1 To n
#macro redirect()
impact=-1*direction(z2)
dt=impact dot impulse
direction(z2)=direction(z2)+2*dt*impulse
#endmacro
If balls(z2).mx<20*balls(z2).mw Then
impulse=Type<d2>(1,0,0)
redirect()
End If
If balls(z2).mx>xres-20*balls(z2).mw Then
impulse=Type<d2>(-1,0,0)
redirect()
End If
If balls(z2).my>yres-20*balls(z2).mw Then
impulse=Type<d2>(0,-1,0)
redirect()
End If
If balls(z2).my<20*balls(z2).mw Then
impulse=Type<d2>(0,1,0)
redirect()
End If
Next z2
#endmacro
#macro check_ball_to_ball_collisions()
For xx As Integer=1 To n
For yy As Integer=1 To n
If xx<>yy Then
If collision(xx)+collision(yy)<2 Then
If length((balls(xx)-balls(yy)))<=20*balls(xx).mw+20*balls(yy).mw Then
impulse=normalize((balls(xx)-balls(yy)))
impact=direction(xx)-direction(yy)
dt=(impact dot impulse)
var mxx=balls(xx).mw*balls(xx).mw*balls(xx).mw 'the ball (weights)
var myy=balls(yy).mw*balls(yy).mw*balls(yy).mw
direction(xx)=direction(xx)-dt*(2*myy/(mxx+myy))*impulse
direction(yy)=direction(yy)+dt*(2*mxx/(myy+mxx))*impulse
collision(xx)=1
collision(yy)=1
End If 'seperation
End If 'collisions
End If'xx/yy
Next yy
Next xx
#endmacro
dim as d2 impact2
#macro check_line_segment()
for z2 as integer=1 to n
If segmentdistance(linesegment(1),balls(z2),impact2)<20*balls(z2).mw Then
impulse=normalize((balls(z2)-impact2))
impact=-1*direction(z2)
dt=impact dot impulse
direction(z2)=direction(z2)+2*dt*impulse
End If
next z2
#endmacro
' ______________________________________________________
Dim callcount As Integer
dim as single pi=4*atn(1)
dim as single coefficient=.5*(4/3)*pi
dim energy as single
Do
callcount=callcount+1
energy=0
If callcount>1e6 Then callcount=0
check_side_collisions()
check_ball_to_ball_collisions()
check_line_segment()
Screenlock
Cls
Put(0,0),im
drawline(linesegment(1),7)
For z As Integer=1 To n
balls(z).ang=balls(z).ang+.5
balls(z)=balls(z)+direction(z)
draw_balls(balls(z))
'damper when needed
'If length(direction(z))>2.5 Then direction(z)=.999*direction(z)
'If length(direction(z))<.2 Then direction(z)=1.01*direction(z)
'reset collisions
If callcount Mod 4=0 Then
If collision(z)=1 Then collision(z)=0
End If
'direction(z)=.999*direction(z)'uncheck to reduce energy by friction
energy=energy+coefficient*(balls(z).mw)^3*direction(z)*direction(z)
Next z
locate 2,2
print "KINETIC ENERGY "; energy
framecounter
Screenunlock
Sleep 1,1
Loop Until Inkey=Chr(27)
imagedestroy im
Sleep