because i think in degrees i couldn't help myself. one more time around.
the thing you call impulse to me is the normal (the angle from ball 2's center to ball 1's center (at point of collision)
and the thing about hippasus (a few posts back) was due to a lot of beer. (i was investigating head on collision stuff)
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.freebasic.net/forum/viewtopic.php?f=3&t=8903&sid=960dda2e5d05f308250b7017ff5f5629
'' inactive link http://www.geocities.com/vobarian/2dcollisions/
'' perhaps the original author was Chad Berchek which i found at vobarian.com
'' i reworked the algo removing the oop and condensing it into something that i can kinda understand
'' but still credit goes to vobarian.
'' also dodicat from the freebasic.net community helped me out a lot.
'' http://www.freebasic.net/forum/viewtopic.php?f=3&t=8903&start=15
'' see sub routine bouce at the bottom of this code.
'' conversation of this game can be found @ http://www.thejoyfulprogrammer.com/qb64/forum/showthread.php?tid=961
'' special thanks to waltersmind and bplus @ thejoyfulprogrammer.com
#include "fbgfx.bi"
#If __FB_LANG__ = "fb"
Using FB
#EndIf
#include once "fmod.bi"
Declare Function dist(x1 As Double,y1 As Double,x2 As Double,y2 As Double) As Double
Declare Function abtp(abtpx1 as Double,abtpy1 as Double,abtpx2 as Double,abtpy2 as Double) as Double
Declare Sub delay(delay_sec As Double)
Declare Sub calc_bnd()
Declare Sub bounce(ball_1 As Integer, ball_2 As Integer)
Type balls
As Integer c,r
As Double s,x,y,t,d
As BOOLEAN a
'x,y coordinates
'c color
'r radius
'd direction in degrees: 0 degrees is at 3 O'clock, 90 degrees is at 12
's speed
't timer
End Type
Type ammo
As Integer b,c,r,d
As Double s,x,y
As BOOLEAN a
'x,y coordinates
'c color
'r radius
'd direction in degrees: 0 degrees is at 3 O'clock, 90 degrees is at 12
's speed
'a active
End Type
Type emp_obj
r As Integer'radius
c As Integer'color
x As Integer
y As Integer
'x,y coordinates
End Type
Const pi As Double = 4 * Atn(1)
Const hippasus As Double = Sqr(2)
Dim Shared As Integer bc
DIM AS Integer game_sound(12)
Dim As Integer i,j,k,bf(15),c,catch,level,bw,bh,game_level_val
Dim As BOOLEAN pass,fail,skip
Dim Shared As balls b()
Dim As ammo a()
Dim As Integer ammoc,ammor,ammors,abc,multibursts,multibursts_degrees
Dim As BOOLEAN ap
Dim As String game_level
Dim Shared As Double normal,rot,bid,bnd,boid,maxspeed
Dim As Integer b1d,b2d,sit
Dim As Double firet,timeout
Dim As BOOLEAN empa,empat,empcut
Dim As Integer empc,emps,empm,empct,empcutc,empcc
empcc=60
Dim As emp_obj emp(empcc)
Dim As Double empx,empy,empd
Dim As Double rip1,rip2,heading
' 48kHz sample rate, 8 channels.
FSOUND_Init(48000, 8, 0)
game_sound(0) = FSOUND_Sample_Load(FSOUND_FREE, "splash-screen-audio-clip.wav", 0, 0, 0)
game_sound(1) = FSOUND_Sample_Load(FSOUND_FREE, "Bounce-SoundBible.com-12678623.wav", 0, 0, 0)
game_sound(2) = FSOUND_Sample_Load(FSOUND_FREE, "Clean_Paper_Rip-Mike_Koenig-259504794.wav", 0, 0, 0)
game_sound(3) = FSOUND_Sample_Load(FSOUND_FREE, "UFO_Takeoff-Sonidor-1604321570.wav", 0, 0, 0)
game_sound(4) = FSOUND_Sample_Load(FSOUND_FREE, "Wood Whack-SoundBible.com-1254461064.wav", 0, 0, 0)
game_sound(5) = FSOUND_Sample_Load(FSOUND_FREE, "Audience_Applause-Matthiew11-1206899159.wav", 0, 0, 0)
game_sound(6) = FSOUND_Sample_Load(FSOUND_FREE, "1_person_cheering-Jett_Rifkin-1851518140.wav", 0, 0, 0)
game_sound(7) = FSOUND_Sample_Load(FSOUND_FREE, "Baby_Boy_Laugh-Mike_Koenig-1622212130.wav", 0, 0, 0)
game_sound(8) = FSOUND_Sample_Load(FSOUND_FREE, "Short_triumphal_fanfare-John_Stracke-815794903.wav", 0, 0, 0)
game_sound(9) = FSOUND_Sample_Load(FSOUND_FREE, "Ta Da-SoundBible.com-1884170640.wav", 0, 0, 0)
game_sound(10) = FSOUND_Sample_Load(FSOUND_FREE, "bullet_whizzing_by-Mike_Koenig-2005433595.wav", 0, 0, 0)
game_sound(11) = FSOUND_Sample_Load(FSOUND_FREE, "Metal_Gong-Dianakc-109711828-mod-1.wav", 0, 0, 0)
game_sound(12) = FSOUND_Sample_Load(FSOUND_FREE, "Mario_Jumping-Mike_Koenig-989896458-mod-1.wav", 0, 0, 0)
'FSOUND_Sample_SetMode(game_sound(0), FSOUND_LOOP_OFF)
'FSOUND_Sample_SetMode(game_sound(1), FSOUND_LOOP_OFF)
'FSOUND_Sample_SetMode(game_sound(2), FSOUND_LOOP_OFF)
'FSOUND_Sample_SetMode(game_sound(3), FSOUND_LOOP_OFF)
bw=600
bh=600
Randomize Timer
ScreenRes bw,bh
Window (0,0)-(bw,bh)
Dim img_splash As Any Ptr = ImageCreate( 600, 600 )
Dim img_level As Any Ptr = ImageCreate( 209, 75 )
Dim img_number_0 As Any Ptr = ImageCreate( 48, 67 )
Dim img_number_1 As Any Ptr = ImageCreate( 48, 67 )
Dim img_number_2 As Any Ptr = ImageCreate( 48, 67 )
Dim img_number_3 As Any Ptr = ImageCreate( 48, 67 )
Dim img_number_4 As Any Ptr = ImageCreate( 48, 67 )
Dim img_number_5 As Any Ptr = ImageCreate( 48, 67 )
Dim img_number_6 As Any Ptr = ImageCreate( 48, 67 )
Dim img_number_7 As Any Ptr = ImageCreate( 48, 67 )
Dim img_number_8 As Any Ptr = ImageCreate( 48, 67 )
Dim img_number_9 As Any Ptr = ImageCreate( 48, 67 )
BLoad "game_logo-1.bmp", img_splash
BLoad "level.bmp", img_level
BLoad "0.bmp", img_number_0
BLoad "1.bmp", img_number_1
BLoad "2.bmp", img_number_2
BLoad "3.bmp", img_number_3
BLoad "4.bmp", img_number_4
BLoad "5.bmp", img_number_5
BLoad "6.bmp", img_number_6
BLoad "7.bmp", img_number_7
BLoad "8.bmp", img_number_8
BLoad "9.bmp", img_number_9
Put (0,bh), img_splash
Draw String (10,492),"By Owen Reese Fbcadcam.com/freezetag opreese@gmail.com"
Draw String (30,475),"Using the FMOD Sound System by Firelight Technologies"
Draw String (50,463),"Free Sound bytes from SoundBible.com"
Draw String (60,454),"Thanks to Mike Koenig, Sonidor and Matthiew11"
FSOUND_PlaySound(FSOUND_FREE, game_sound(0))
ammoc=1
abc=1
level=6
maxspeed=5
delay 4
Randomize Timer
Do
emps=3
empm=3
empa=FALSE
empat=FALSE
empc=0
If level Mod 5 = 0 Then
multibursts=Int(level/4)+1
Else
multibursts=1'Int(level/4)+1
EndIf
multibursts_degrees=Int(360/multibursts)
If level Mod 10 = 0 Then
ammor=level*2
ap=TRUE
Else
If multibursts=1 Then
ammor=level*3
Else
ammor=level*multibursts/2
EndIf
EndIf
ammors=ammor
ammoc=Int(level*multibursts/2)'Int(level/3)
ReDim a(ammoc)
delay 3
Cls
Put (100,500),img_level
game_level=LTrim(Str(level))
For i=1 To Len(game_level)
game_level_val=Val(Mid(game_level,i,1))
Select Case game_level_val
Case 0
Put (i*45+310,490),img_number_0
Case 1
Put (i*45+310,490),img_number_1
Case 2
Put (i*45+310,490),img_number_2
Case 3
Put (i*45+310,490),img_number_3
Case 4
Put (i*45+310,490),img_number_4
Case 5
Put (i*45+310,490),img_number_5
Case 6
Put (i*45+310,490),img_number_6
Case 7
Put (i*45+310,490),img_number_7
Case 8
Put (i*45+310,490),img_number_8
Case 9
Put (i*45+310,490),img_number_9
End Select
Next
delay 2
Cls
bc=level
ReDim b(bc)
timeout=level*2
For i=1 To 15
bf(i)=0
Next
'new level, position the balls so that none of the overlap
For i = 0 To bc
b(i).x = Int(Rnd*(bw-60))+30
b(i).y = Int(Rnd*(bh-60))+30
If i=0 Then
b(i).r = 30
Else
b(i).r = Int(Rnd*20)+20
EndIf
pass=TRUE
For j=0 To i-1
If dist(b(i).x,b(i).y,b(j).x,b(j).y)-6 < b(i).r+b(j).r Then
i-=1
pass=FALSE
Exit For
EndIf
Next
If pass=TRUE Then
b(i).c = Int(Rnd*14)+1
'If i=0 Then b(i).r=30
b(i).d = Int(Rnd*360)
b(i).s = Rnd+1
If i<>0 Then
bf(b(i).c)+=1
EndIf
EndIf
Next
catch=0
For i =1 To 15
If bf(i)>catch Then
catch=bf(i)
b(0).c=i
EndIf
Next
Do
If level>bc Then
FSOUND_PlaySound(FSOUND_FREE, game_sound(Int(Rnd*5)+5))
delay(1)
Exit Do
EndIf
If empa=TRUE Then
If empc<empcc Then
empc+=1
emp(empc).x=empx' +cos(empc*36*pi/180)*b(0).r
emp(empc).y=empy' +sin(empc*36*pi/180)*b(0).r
emp(empc).r=0'b(0).r
emp(empc).c=empct
EndIf
EndIf
ScreenLock
Cls
For i=0 To bc
'move the balls
b(i).x=b(i).x+cos(b(i).d*pi/180)*b(i).s
b(i).y=b(i).y+sin(b(i).d*pi/180)*b(i).s
If i=0 Then heading=b(0).d
If b(i).s<>0 Then
'bounce the balls off each other
For j=0 To bc
If j<>i Then
If b(j).s<>0 Then
'If dist(b(i).x,b(i).y,b(j).x,b(j).y)<=b(i).r+b(j).r Then
' b(j).x+=Cos(b(j).d*pi/180)*b(j).s
' b(j).y+=Sin(b(j).d*pi/180)*b(j).s
If dist(b(i).x,b(i).y,b(j).x,b(j).y)<=b(i).r+b(j).r Then
If i=0 Or j=0 Then
If b(i).c=b(j).c Then
Exit For
Else
FSOUND_PlaySound(FSOUND_FREE, game_sound(4))
EndIf
EndIf
'put them back to where they were just prior to collision
bounce(i,j)
'If i=0 Then b(i).d=heading
'If j=0 Then b(j).d=heading
b(i).x+=Cos(b(i).d*pi/180)*b(i).s
b(i).y+=Sin(b(i).d*pi/180)*b(i).s
b(j).x+=Cos(b(j).d*pi/180)*b(j).s
b(j).y+=Sin(b(j).d*pi/180)*b(j).s
Exit For
'Else
' b(j).x+=Cos((b(j).d+180)*pi/180)*b(j).s
' b(j).y+=sin((b(j).d+180)*pi/180)*b(j).s
EndIf
'EndIf
End If
EndIf
Next
EndIf
'detect borders
If b(i).x + b(i).r > bw Then
bid=b(i).d
normal=180
calc_bnd
b(i).d=bnd
b(i).x = bw - b(i).r
FSOUND_PlaySound(FSOUND_FREE, game_sound(1))
EndIf
If b(i).x - b(i).r < 0 Then
bid=b(i).d
normal=0
calc_bnd
b(i).d=bnd
b(i).x = b(i).r
'FSOUND_PlaySound(FSOUND_FREE, game_sound(1))
EndIf
If b(i).y + b(i).r > bh Then
bid=b(i).d
normal=270
calc_bnd
b(i).d=bnd
b(i).y = bh - b(i).r
'FSOUND_PlaySound(FSOUND_FREE, game_sound(1))
EndIf
If b(i).y - b(i).r < 0 Then
bid=b(i).d
normal=90
calc_bnd
b(i).d=bnd
b(i).y = b(i).r
'FSOUND_PlaySound(FSOUND_FREE, game_sound(1))
EndIf
'freeze the balls
If i=0 Then
For j=1 To bc
If b(j).c=b(0).c Then
''freeze the balls via emp
If b(j).s<>0 Then
If empa=TRUE And empat=TRUE Then
If emp(1).r>dist(b(j).x,b(j).y,emp(1).x,emp(1).y)-b(j).r Then
b(j).s = 0
b(j).r = 4
b(j).t = Timer
bf(b(j).c)-=1
If bf(b(j).c)=0 Then
empat=FALSE
catch=0
For k =1 To 15
If bf(k)>catch Then
catch=bf(k)
b(0).c=k
EndIf
Next
If catch=0 Then
level+=1
EndIf
For k=0 To ammoc
a(k).a=FALSE
Next
EndIf
FSOUND_PlaySound(FSOUND_FREE, game_sound(2))
EndIf
EndIf
EndIf
''freeze the balls via collision
If b(j).s<>0 Then
If dist(b(0).x,b(0).y,b(j).x,b(j).y) < b(0).r + b(j).r Then
FSOUND_PlaySound(FSOUND_FREE, game_sound(2))
b(j).s = 0
b(j).r = 4
b(j).t = Timer
bf(b(j).c)-=1
If bf(b(j).c)=0 Then
catch=0
For k =1 To 15
If bf(k)>catch Then
catch=bf(k)
b(0).c=k
empa=FALSE
empc=0
EndIf
Next
If catch=0 Then
level+=1
EndIf
For k=0 To ammoc
a(k).a=FALSE
Next
EndIf
If ap=FALSE Then ammor+=Int(level/2)
If ammor>ammors Then ammor=ammors
EndIf
EndIf
Else
'check if you got a ball cornered
Select Case b(0).x
Case Is < bw/2
Select Case b(0).y
Case Is < bh/2
'blc
'other ball b1radius*hippasus+b0radius/2
Case Else
'tlc
End Select
Case Else
Select Case b(0).y
Case Is < bh/2
'brc
Case Else
'trc
End Select
End Select
EndIf
Next
Else
For j=1 To bc
If j<>i Then
If b(j).s = 0 Then
If b(j).c = b(i).c Then
If dist(b(i).x,b(i).y,b(j).x,b(j).y) < b(i).r + b(j).r Then
b(j).a=TRUE
EndIf
EndIf
EndIf
EndIf
Next
EndIf
'draw circles
If i=0 Then
Circle (b(0).x,b(0).y),b(0).r,b(0).c
Circle (b(0).x,b(0).y),b(0).r/4,b(0).c,,,,f
If ammor<>0 Then
Circle (b(0).x,b(0).y),b(0).r/2+8,b(0).c,(pi / 180),(360*ammor/ammors * pi / 180)
Circle (b(0).x,b(0).y),b(0).r/2+9,b(0).c,(pi / 180),(360*ammor/ammors * pi / 180)
EndIf
If emps<>0 Then
Circle (b(0).x,b(0).y),b(0).r/2+2,b(0).c,(pi / 180),(360*emps/empm * pi / 180)
Circle (b(0).x,b(0).y),b(0).r/2+3,b(0).c,(pi / 180),(360*emps/empm * pi / 180)
Circle (b(0).x,b(0).y),b(0).r/2+4,b(0).c,(pi / 180),(360*emps/empm * pi / 180)
Circle (b(0).x,b(0).y),b(0).r/2+5,b(0).c,(pi / 180),(360*emps/empm * pi / 180)
EndIf
Line(b(0).x,b(0).y)-(b(0).x+cos(b(0).d*pi/180)*b(0).r,b(0).y+sin(b(0).d*pi/180)*b(0).r)
Line(b(0).x+cos(b(0).d*pi/180)*b(0).r,b(0).y+sin(b(0).d*pi/180)*b(0).r)-(b(0).x+cos((b(0).d+15)*pi/180)*(b(0).r-10),b(0).y+sin((b(0).d+15)*pi/180)*(b(0).r-10))
Line(b(0).x+cos(b(0).d*pi/180)*b(0).r,b(0).y+sin(b(0).d*pi/180)*b(0).r)-(b(0).x+cos((b(0).d-15)*pi/180)*(b(0).r-10),b(0).y+sin((b(0).d-15)*pi/180)*(b(0).r-10))
Else
Circle (b(i).x,b(i).y),b(i).r,b(i).c,,,,f
If b(i).s=0 Then
If Timer>b(i).t+timeout Then
b(i).a=TRUE
EndIf
EndIf
EndIf
Next
'move ammo rounds and detect if round hits a target ball
For i=0 To ammoc
If a(i).a = TRUE Then
Circle (a(i).x,a(i).y),a(i).r,a(i).c,,,,f
a(i).x=a(i).x+cos(a(i).d*pi/180)*a(i).s
a(i).y=a(i).y+sin(a(i).d*pi/180)*a(i).s
For j=1 To bc
If b(j).s<>0 Then
If ap=TRUE Then
If a(i).c=b(j).c Then
If dist(a(i).x,a(i).y,b(j).x,b(j).y) < a(i).r + b(j).r Then
a(i).a = FALSE
FSOUND_PlaySound(FSOUND_FREE, game_sound(2))
b(j).s = 0
b(j).r = 4
b(j).t = Timer
bf(b(j).c)-=1
If bf(b(j).c)=0 Then
catch=0
For k =1 To 15
If bf(k)>catch Then
catch=bf(k)
b(0).c=k
EndIf
Next
If catch=0 Then
level+=1
EndIf
For k=0 To ammoc
a(k).a=FALSE
Next
EndIf
If ap=FALSE Then
ammor+=Int(level/2)
Else
ammor+=Int(level/4)
EndIf
Exit For
EndIf
EndIf
Else
If dist(a(i).x,a(i).y,b(j).x,b(j).y) < a(i).r + b(j).r Then
a(i).a = FALSE
If a(i).c=b(j).c Then
FSOUND_PlaySound(FSOUND_FREE, game_sound(2))
b(j).s = 0
b(j).r = 4
b(j).t = Timer
bf(b(j).c)-=1
If bf(b(j).c)=0 Then
catch=0
For k =1 To 15
If bf(k)>catch Then
catch=bf(k)
b(0).c=k
EndIf
Next
If catch=0 Then
level+=1
EndIf
For k=0 To ammoc
a(k).a=FALSE
Next
EndIf
Exit For
EndIf
EndIf
EndIf
EndIf
Next
'bounce the ammo off the borders
If a(i).x<0 Then
If a(i).b=abc Then a(i).a=FALSE
a(i).b+=1
bid=a(i).d
normal=0
calc_bnd
a(i).d=bnd
a(i).x = a(i).r
EndIf
If a(i).x>bw Then
If a(i).b=abc Then a(i).a=FALSE
a(i).b+=1
bid=a(i).d
normal=180
calc_bnd
a(i).d=bnd
a(i).x = bw - a(i).r
EndIf
If a(i).y<0 Then
If a(i).b=abc Then a(i).a=FALSE
a(i).b+=1
bid=a(i).d
normal=90
calc_bnd
a(i).d=bnd
a(i).y = a(i).r
EndIf
If a(i).y>bh Then
If a(i).b=abc Then a(i).a=FALSE
a(i).b+=1
bid=a(i).d
normal=270
calc_bnd
a(i).d=bnd
a(i).y = bh - a(i).r
EndIf
EndIf
Next
'draw emp
If empa=TRUE Then
For i=1 To empc
emp(i).r+=5
Circle (emp(i).x,emp(i).y),emp(i).r,emp(i).c
If emp(1).r>=empd Then
empa=FALSE
empat=FALSE
empc=0
EndIf
If empc=empcc Then empcut=TRUE
If i>empcutc Then Exit For
Next
If empcut=TRUE Then empcutc-=1
EndIf
ScreenUnLock
're-activate caught balls when there's enough space for it
For i=1 To bc
If b(i).a=TRUE Then
pass=TRUE
b(i).r = Int(Rnd*20)+10
For j=0 To bc
If j<>i And b(j).s<>0 Then
If dist(b(i).x,b(i).y,b(j).x,b(j).y)-6 < b(i).r+b(j).r Then
pass=FALSE
Exit For
EndIf
EndIf
Next
If pass=TRUE Then
b(i).a=FALSE
FSOUND_PlaySound(FSOUND_FREE, game_sound(3))
b(i).s = Rnd*2+.3
bf(b(i).c)+=1
If ap=FALSE Then ammor+=1
If ammor>ammors Then ammor=ammors
timeout+=.001
Else
b(i).r = 4
EndIf
EndIf
Next
'detect key press
Select Case InKey
Case "e","E"
If emps>0 And empa=FALSE Then
FSOUND_PlaySound(FSOUND_FREE, game_sound(11))
empa=TRUE
empat=TRUE
empx=b(0).x
empy=b(0).y
empct=b(0).c
emps-=1
empc=0
empcut=FALSE
empcutc=empcc
If b(0).x<bw/2 Then
If b(0).y<bh/2 Then
empd=Sqr((bw-b(0).x)^2 + (bh-b(0).y)^2)
Else
empd=Sqr((bw-b(0).x)^2 + (b(0).y)^2)
EndIf
Else
If b(0).y<bh/2 Then
empd=Sqr((b(0).x)^2 + (bh-b(0).y)^2)
Else
empd=Sqr((b(0).x)^2 + (b(0).y)^2)
EndIf
EndIf
EndIf
Case Chr(27),Chr(255)+"k"
FSOUND_Close
ImageDestroy(img_splash)
ImageDestroy(img_level)
ImageDestroy(img_number_0)
ImageDestroy(img_number_1)
ImageDestroy(img_number_2)
ImageDestroy(img_number_3)
ImageDestroy(img_number_4)
ImageDestroy(img_number_5)
ImageDestroy(img_number_6)
ImageDestroy(img_number_7)
ImageDestroy(img_number_8)
ImageDestroy(img_number_9)
End
End Select
If MultiKey(SC_SPACE ) Then
If ammor>0 Then
If Timer>firet Then
firet=Timer+.15
For j=0 To multibursts-1
For i=0 To ammoc
If a(i).a = FALSE Then
a(i).x=b(0).x
a(i).y=b(0).y
a(i).c=b(0).c
a(i).s=6
a(i).d=b(0).d+j*multibursts_degrees
a(i).r=4
a(i).a=TRUE
a(i).b=0
If ammor > 0 then ammor-=1
If ammor=0 And ap=TRUE Then
ammor=level*4
ammors=ammor
ap=FALSE
EndIf
If ap=TRUE Then
FSOUND_PlaySound(FSOUND_FREE, game_sound(12))
Else
FSOUND_PlaySound(FSOUND_FREE, game_sound(10))
EndIf
Exit For
EndIf
Next
Next
EndIf
EndIf
EndIf
If MultiKey(SC_LEFT ) Then
b(0).d+=2.2
If b(0).d > 360 Then b(0).d=0
EndIf
If MultiKey(SC_RIGHT) Then
b(0).d-=2.2
If b(0).d < 0 Then b(0).d=360
EndIf
If MultiKey(SC_UP ) Then
b(0).s+=.05
If b(0).s>maxspeed Then b(0).s=maxspeed
EndIf
If MultiKey(SC_DOWN ) Then
b(0).s-=.05
If b(0).s < .1 Then b(0).s = .1
EndIf
delay .01
Loop
Loop
End
Function dist(x1 As Double,y1 As Double,x2 As Double,y2 As Double) As Double
Return sqr((x1-x2)^2 + (y1-y2)^2)
End Function
Function abtp(abtpx1 as Double,abtpy1 as Double,abtpx2 as Double,abtpy2 as Double) as Double
Dim As Double angle
angle=atan2(abtpy2-abtpy1,abtpx2-abtpx1)/pi*180
If angle<0 then angle=360+angle
Return angle
End Function
Sub delay(delay_sec As Double)
Dim As Double dt=Timer
Do
Sleep 1
If Timer> dt+delay_sec Then Exit Do
Loop
End Sub
Sub calc_bnd()
boid=bid
rot=180-normal
normal=(normal+rot) Mod 360
bid=(bid+rot) Mod 360
If bid<0 Then bid=360+bid
Select Case bid
Case 0 To 90
bnd=180-bid
bnd=(bnd-rot) Mod 360
If bnd<0 Then bnd=360+bnd
Case 270 To 360
bnd=360-bid+180
bnd=(bnd-rot) Mod 360
If bnd<0 Then bnd=360+bnd
Case Else
bnd=boid
End Select
End Sub
Sub bounce(ball_1 As Integer, ball_2 As Integer)
Dim As Double b1xv,b1yv,b2xv,b2yv
Dim As Double b1xnv,b1ynv,b2xnv,b2ynv
Dim As Double b1nx,b1ny,b2nx,b2ny
Dim As Double ball_1_a,ball_2_a
Dim As Double speedin,speedout,s1,s2
Dim As Double norm,normx,normy
speedin=b(ball_1).s+b(ball_2).s
b1xv=cos(b(ball_1).d*pi/180)*b(ball_1).s
b1yv=sin(b(ball_1).d*pi/180)*b(ball_1).s
b2xv=cos(b(ball_2).d*pi/180)*b(ball_2).s
b2yv=sin(b(ball_2).d*pi/180)*b(ball_2).s
ball_1_a=(pi*b(ball_1).r)^2
ball_2_a=(pi*b(ball_2).r)^2
If ball_1=0 Then ball_1_a*=2
If ball_2=0 Then ball_2_a*=2
norm=abtp(b(ball_2).x,b(ball_2).y,b(ball_1).x,b(ball_1).y)
normx=Cos(norm*pi/180)
normy=Sin(norm*pi/180)
'set one ball to nearest non overlap position
b(ball_1).x=b(ball_2).x+(b(ball_2).r+b(ball_1).r)*normx
b(ball_1).y=b(ball_2).y+(b(ball_2).r+b(ball_1).r)*normy
norm=abtp(b(ball_2).x,b(ball_2).y,b(ball_1).x,b(ball_1).y)
'readjust norm x and y
normx=Cos(norm*pi/180)
normy=Sin(norm*pi/180)
b1xnv=(((((normx*b1xv+normy*b1yv) * (ball_1_a - ball_2_a) + 2 * ball_2_a * (normx*b2xv+normy*b2yv))) / (ball_1_a + ball_2_a))*normx+(normy*-1*b1xv+normx*b1yv)*normy*-1)
b1ynv=(((((normx*b1xv+normy*b1yv) * (ball_1_a - ball_2_a) + 2 * ball_2_a * (normx*b2xv+normy*b2yv))) / (ball_1_a + ball_2_a))*normy+(normy*-1*b1xv+normx*b1yv)*normx)
b2xnv=(((((normx*b2xv+normy*b2yv) * (ball_2_a - ball_1_a) + 2 * ball_1_a * (normx*b1xv+normy*b1yv))) / (ball_1_a + ball_2_a))*normx+(normy*-1*b2xv+normx*b2yv)*normy*-1)
b2ynv=(((((normx*b2xv+normy*b2yv) * (ball_2_a - ball_1_a) + 2 * ball_1_a * (normx*b1xv+normy*b1yv))) / (ball_1_a + ball_2_a))*normy+(normy*-1*b2xv+normx*b2yv)*normx)
b1nx=b(ball_1).x+b1xnv
b1ny=b(ball_1).y+b1ynv
b2nx=b(ball_2).x+b2xnv
b2ny=b(ball_2).y+b2ynv
b(ball_1).d=abtp(b(ball_1).x,b(ball_1).y,b1nx,b1ny)
b(ball_2).d=abtp(b(ball_2).x,b(ball_2).y,b2nx,b2ny)
s1=Sqr(b1xnv^2+b1ynv^2)
s2=Sqr(b2xnv^2+b2ynv^2)
speedout=s1+s2
b(ball_1).s=s1*speedin/speedout'*.987
b(ball_2).s=s2*speedin/speedout'*.987
If b(ball_1).s<.0000001 Then b(ball_1).s=.0000001
If b(ball_2).s<.0000001 Then b(ball_2).s=.0000001
End Sub