Ball collisions

General FreeBASIC programming questions.
owen
Posts: 432
Joined: Apr 19, 2006 10:55
Location: Kissimmee, FL
Contact:

Re: Ball collisions

Postby owen » Aug 31, 2017 4:32

in an attempt to learn how to bounce balls i decided to give h4tt3n's rework of vobarian's work a try.

I have a real hard time seeing the big picture with too much oop.
so i broke it all down and re worked h4tt3n's rework of vobarian's work.

in this example i do use oop for the balls but not the vectors (in other words vectorx is vextorx not v.x but ballx is b.x)

in my mind, in order to see the big picture i think a ball as an angular direction, i have a hard time thinking in radians so i use 360 degrees to represent the direction a ball is going. then of course there's speed, if the speed is 1 and the direction is 0 degrees the ball will move 1 on the x axis and 0 on the y. if the direction is 45 degrees then the ball will move to x = 0.7 and y = 0.7. Also a ball has mass which i simply convert it from the ball's area. pi*r^2. In my example game (freeze tag) i set the main ball (the ball you move around) mass to 3 times that of the others so it is simpler to control.

the game, source code, exe, pics and sound files are at fbcadcam.com/freezetag/freeze-tag.zip

here is my rework of vorbarian's work. see the sub routine at the bottom called bounce.

Code: Select all

#include "fbgfx.bi"
#If __FB_LANG__ = "fb"
Using FB '' Scan code constants are stored in the FB namespace in lang 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,d
   As Double s,x,y,t
   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,timeout,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
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
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,rip_apart,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=13
maxspeed=5
delay 4
ReDim b(50)
Randomize Timer
Do
   emps=3
   empm=3
   empa=FALSE
   empat=FALSE
   empc=0
   If level>19 Then
      ammor=level
      ap=TRUE
   Else
      ammor=level*4
   EndIf
   ammors=ammor
   ammoc=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
   timeout=level*2
   If timeout>30 Then timeout=30
   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 = 30'Int(Rnd*20)+10
      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+.3
         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
                           b(i).x+=Cos((b(i).d+180)*pi/180)*b(i).s
                           b(i).y+=Sin((b(i).d+180)*pi/180)*b(i).s
                           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
                           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
                           rip_apart=abtp(b(i).x,b(i).y,b(j).x,b(j).y)
                           b(j).x+=cos(rip_apart*pi/180)*b(j).s
                           b(j).y+=sin(rip_apart*pi/180)*b(j).s
                           rip_apart+=180
                           b(i).x+=Cos(rip_apart*pi/180)*b(i).s
                           b(i).y+=Sin(rip_apart*pi/180)*b(i).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
                           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
                                    empat=FALSE
                                 EndIf
                              Next
                              If catch=0 Then
                                 level+=1
                              EndIf
                              For k=0 To ammoc
                                 a(k).a=FALSE
                              Next
                           EndIf
                        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+=level
                        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+=1
                           ammor+=1
                           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
            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 i=0 To ammoc
                  If a(i).a = FALSE Then
                     If ap=TRUE Then
                        FSOUND_PlaySound(FSOUND_FREE, game_sound(12))
                     Else
                        FSOUND_PlaySound(FSOUND_FREE, game_sound(10))
                     EndIf
                     
                     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
                     a(i).r=4
                     a(i).a=TRUE
                     a(i).b=0
                     ammor-=1
                     If ammor=0 And ap=TRUE Then
                        ammor=level*4
                        ammors=ammor
                        ap=FALSE
                     EndIf
                     Exit For
                  EndIf
               Next
            EndIf
         EndIf
      EndIf
      If MultiKey(SC_LEFT ) Then
         b(0).d+=2
         If b(0).d > 360 Then b(0).d=0
      EndIf
      If MultiKey(SC_RIGHT) Then
         b(0).d-=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 ball_1_x_v,ball_1_y_v,ball_2_x_v,ball_2_y_v
   Dim As Double ball_1_x_nv,ball_1_y_nv,ball_2_x_nv,ball_2_y_nv
   Dim As Double b1nx,b1ny,b2nx,b2ny
   Dim As Double ball_1_a,ball_2_a
   Dim As Double v_n_x,v_n_y
   Dim As Double v_un_x,v_un_y,v_ut_x,v_ut_y
   Dim As Double v1n,v2n,v1t,v2t
   Dim As Double v1np,v2np,v1tp,v2tp
   Dim As Double speedin,speedout,s1,s2
   speedin=b(ball_1).s+b(ball_2).s
   ball_1_x_v=cos(b(ball_1).d*pi/180)*b(ball_1).s
   ball_1_y_v=sin(b(ball_1).d*pi/180)*b(ball_1).s
   ball_2_x_v=cos(b(ball_2).d*pi/180)*b(ball_2).s
   ball_2_y_v=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*=3
   If ball_2=0 Then ball_2_a*=3
   v_n_x = b(ball_2).x-b(ball_1).x
   v_n_y = b(ball_2).y-b(ball_1).y
   v_un_x=v_n_x/Sqr((v_n_x)^2)
   v_un_y=v_n_y/Sqr((v_n_y)^2)
   v_ut_x=v_un_y*-1
   v_ut_y=v_un_x
   v1n=v_un_x*ball_1_x_v+v_un_y*ball_1_y_v
   v1t=v_ut_x*ball_1_x_v+v_ut_y*ball_1_y_v
   v2n=v_un_x*ball_2_x_v+v_un_y*ball_2_y_v
   v2t=v_ut_x*ball_2_x_v+v_ut_y*ball_2_y_v
   v1np=((v1n * (ball_1_a - ball_2_a) + 2 * ball_2_a * v2n)) / (ball_1_a + ball_2_a)
   v2np=((v2n * (ball_2_a - ball_1_a) + 2 * ball_1_a * v1n)) / (ball_1_a + ball_2_a)
   v1tp=v1t
   v2tp=v2t
   ball_1_x_nv=(v1np*v_un_x+v1tp*v_ut_x)
   ball_1_y_nv=(v1np*v_un_y+v1tp*v_ut_y)
   ball_2_x_nv=(v2np*v_un_x+v2tp*v_ut_x)
   ball_2_y_nv=(v2np*v_un_y+v2tp*v_ut_y)
   b1nx=b(ball_1).x+ball_1_x_nv
   b1ny=b(ball_1).y+ball_1_y_nv
   b2nx=b(ball_2).x+ball_2_x_nv
   b2ny=b(ball_2).y+ball_2_y_nv
   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(ball_1_x_nv^2+ball_1_y_nv^2)
   s2=Sqr(ball_2_x_nv^2+ball_2_y_nv^2)
   speedout=s1+s2
   b(ball_1).s=s1/speedout*speedin*.987
   b(ball_2).s=s2/speedout*speedin*.987
   'If ball_1<>0 Or ball_2<>0 Then
   'b(ball_1).s-=.1
   'b(ball_2).s-=.1
   'EndIf
   If b(ball_1).s<.0001 Then b(ball_1).s=.0001
   If b(ball_2).s<.0001 Then b(ball_2).s=.0001
   
End Sub

owen
Posts: 432
Joined: Apr 19, 2006 10:55
Location: Kissimmee, FL
Contact:

Re: Ball collisions

Postby owen » Aug 31, 2017 5:35

here is a simpler example similar to vorbarian's

Code: Select all

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 bounce(ball_1 As Integer, ball_2 As Integer)
Declare Sub calc_bnd()

Const Pi = 4*Atn(1)
Type balls
   As Integer r,d
   As Double s,x,y,c
   '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
End Type
Dim Shared As balls b(5)
Dim As Integer i,j,k,bw,bh
Dim As Double rip_apart
Dim Shared As Double normal,rot,bid,bnd,boid',maxspeed

''  screen settings
bw = 600          ''  screen width
bh = 400          ''  screen height
screenres bw, bh, 16


With b(1)
  .r = 20
  .x = 100
  .y = 200
  .c = RGB(255, 32, 32)
  .s = 3
  .d = 0
End With

With b(2)
  .r = 25
  .x = 200
  .y = 200
  .c = RGB(255, 32, 255)
  .s = 3
  .d = 0
End With

With b(3)
  .r = 30
  .x = 300
  .y = 200
  .c = RGB(32, 32, 255)
  .s = 3
  .d = 0
End With

With b(4)
  .r = 35
  .x = 400
  .y = 200
  .c = RGB(32, 255, 32)
  .s = 3
  .d = 0
End With

With b(5)
  .r = 40
  .x = 500
  .y = 200
  .c = RGB(255, 255, 32)
  .s = 3
  .d = 0
End With

Do
 
  Screenlock
   
    Cls
   
      For i=1 To 5
         '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
            'bounce the balls off each other
            For j=1 To 5
               If j<>i Then
                  If dist(b(i).x,b(i).y,b(j).x,b(j).y)<=b(i).r+b(j).r Then
                     b(i).x+=Cos((b(i).d+180)*pi/180)*b(i).s
                     b(i).y+=Sin((b(i).d+180)*pi/180)*b(i).s
                     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
                     bounce(i,j)
                     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
                     rip_apart=abtp(b(i).x,b(i).y,b(j).x,b(j).y)
                     b(j).x+=cos(rip_apart*pi/180)*b(j).s
                     b(j).y+=sin(rip_apart*pi/180)*b(j).s
                     rip_apart+=180
                     b(i).x+=Cos(rip_apart*pi/180)*b(i).s
                     b(i).y+=Sin(rip_apart*pi/180)*b(i).s
                     Exit For
                  EndIf
               EndIf
            Next
         '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
         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
         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
         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
         EndIf
         'draw circles
         Circle (b(i).x,b(i).y),b(i).r,b(i).c,,,,f

      Next
   
  screenunlock
 
  Sleep 1
    If InKey=Chr(27) Then Exit Do
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 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 ball_1_x_v,ball_1_y_v,ball_2_x_v,ball_2_y_v
   Dim As Double ball_1_x_nv,ball_1_y_nv,ball_2_x_nv,ball_2_y_nv
   Dim As Double b1nx,b1ny,b2nx,b2ny
   Dim As Double ball_1_a,ball_2_a
   Dim As Double v_n_x,v_n_y
   Dim As Double v_un_x,v_un_y,v_ut_x,v_ut_y
   Dim As Double v1n,v2n,v1t,v2t
   Dim As Double v1np,v2np,v1tp,v2tp
   Dim As Double speedin,speedout,s1,s2
   speedin=b(ball_1).s+b(ball_2).s
   ball_1_x_v=cos(b(ball_1).d*pi/180)*b(ball_1).s
   ball_1_y_v=sin(b(ball_1).d*pi/180)*b(ball_1).s
   ball_2_x_v=cos(b(ball_2).d*pi/180)*b(ball_2).s
   ball_2_y_v=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
   v_n_x = b(ball_2).x-b(ball_1).x
   v_n_y = b(ball_2).y-b(ball_1).y
   v_un_x=v_n_x/Sqr((v_n_x)^2)
   v_un_y=v_n_y/Sqr((v_n_y)^2)
   v_ut_x=v_un_y*-1
   v_ut_y=v_un_x
   v1n=v_un_x*ball_1_x_v+v_un_y*ball_1_y_v
   v1t=v_ut_x*ball_1_x_v+v_ut_y*ball_1_y_v
   v2n=v_un_x*ball_2_x_v+v_un_y*ball_2_y_v
   v2t=v_ut_x*ball_2_x_v+v_ut_y*ball_2_y_v
   v1np=((v1n * (ball_1_a - ball_2_a) + 2 * ball_2_a * v2n)) / (ball_1_a + ball_2_a)
   v2np=((v2n * (ball_2_a - ball_1_a) + 2 * ball_1_a * v1n)) / (ball_1_a + ball_2_a)
   v1tp=v1t
   v2tp=v2t
   ball_1_x_nv=(v1np*v_un_x+v1tp*v_ut_x)
   ball_1_y_nv=(v1np*v_un_y+v1tp*v_ut_y)
   ball_2_x_nv=(v2np*v_un_x+v2tp*v_ut_x)
   ball_2_y_nv=(v2np*v_un_y+v2tp*v_ut_y)
   b1nx=b(ball_1).x+ball_1_x_nv
   b1ny=b(ball_1).y+ball_1_y_nv
   b2nx=b(ball_2).x+ball_2_x_nv
   b2ny=b(ball_2).y+ball_2_y_nv
   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(ball_1_x_nv^2+ball_1_y_nv^2)
   s2=Sqr(ball_2_x_nv^2+ball_2_y_nv^2)
   speedout=s1+s2
   b(ball_1).s=s1/speedout*speedin*.987
   b(ball_2).s=s2/speedout*speedin*.987
   'If ball_1<>0 Or ball_2<>0 Then
   'b(ball_1).s-=.1
   'b(ball_2).s-=.1
   'EndIf
   If b(ball_1).s<.0001 Then b(ball_1).s=.0001
   If b(ball_2).s<.0001 Then b(ball_2).s=.0001
   
End Sub

owen
Posts: 432
Joined: Apr 19, 2006 10:55
Location: Kissimmee, FL
Contact:

Re: Ball collisions

Postby owen » Aug 31, 2017 13:04

i have a hard time understanding vector math which is why i converted vorbarians / h4tt3n's work to non oop.

now that i can see the algorithm all together in a few lines instead of spread out in oop, perhaps i will be able to wrap my head around it.

perhaps i will be able to see it and explain it in laymen terms. but at the moment i am still thinking about it.

all the explanations i read about this subject have explanations which use vector math. effectively they say things like well you go to do this and that and then "Normalize the dot product" as relsoft would say...

and i really appreciate what has been contributed so far but i feel like an old dog that can't learn a new trick.

at the moment, my rework of the algo seems to be working fine.
in order to address possible over lap i re position the two colliding balls to where they were just prior to the detected moment of collision.

Code: Select all

                  If dist(b(i).x,b(i).y,b(j).x,b(j).y)<=b(i).r+b(j).r Then
                     b(i).x+=Cos((b(i).d+180)*pi/180)*b(i).s
                     b(i).y+=Sin((b(i).d+180)*pi/180)*b(i).s
                     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
                     bounce(i,j)
                     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
                     rip_apart=abtp(b(i).x,b(i).y,b(j).x,b(j).y)
                     b(j).x+=cos(rip_apart*pi/180)*b(j).s
                     b(j).y+=sin(rip_apart*pi/180)*b(j).s
                     rip_apart+=180
                     b(i).x+=Cos(rip_apart*pi/180)*b(i).s
                     b(i).y+=Sin(rip_apart*pi/180)*b(i).s
                     Exit For
                  EndIf

then after bounce(i,j)
i set the two balls x,y to their new locations
then i rip them apart a bit (separate them) in order to avoid the stick situation which effectively results in the two balls spinning around one another rather then bouncing off and heading in their new trajectories. ripping them apart each in the opposite relative direction. the relative direction to separate them has nothing to do with what direction they were heading in. any how it is subtle but does cause a bit of a glitch (unless you look at it under a microscope)

the stuff happening in the bounce routine for the most part i am still studying.
but at the end of the bounce routine, i adjust the speed of algo's output.
the idea of an elastic collision where no energy is lost is the combined speed in equals the combined speed out.

Code: Select all

   s1=Sqr(ball_1_x_nv^2+ball_1_y_nv^2)
   s2=Sqr(ball_2_x_nv^2+ball_2_y_nv^2)
   speedout=s1+s2
   b(ball_1).s=s1/speedout*speedin*.987
   b(ball_2).s=s2/speedout*speedin*.987


the bit at the bottom which is commented out just slows the balls down a bit in my game.

Code: Select all

   'If ball_1<>0 Or ball_2<>0 Then
   'b(ball_1).s-=.1
   'b(ball_2).s-=.1
   'EndIf

when i move around (using the up arrow key to accelerate), acceleration adds energy to the ball you collide with. this additional energy effectively gets spread out among all the balls as they eventually collide with one another, so much so that unless i slow them down they would keep bouncing around to fast to play the game.

interesting to run that last simplified example for 10 minutes or so. the balls slow down on their own (without forcing them to slow down). this must be due to accumulative precision loss in the algo.
dafhi
Posts: 922
Joined: Jun 04, 2005 9:51

Re: Ball collisions

Postby dafhi » Aug 31, 2017 17:57

cool. i researched inelastic circle collisions once. the one piece i was missing was "completing the square"

if you can run gfx32, this will do aa

replace

Code: Select all

''  screen settings
bw = 600          ''  screen width
bh = 400          ''  screen height
screenres bw, bh, 16

with

Code: Select all

type imagevars '2017 Aug 31 - by dafhi
  '1. quick reference for ScreenInfo & ImageInfo
  '2. encapsulate standard metrics
  '3. convenient additional vars, subs and functions
  as integer            w,h, bpp,bypp,pitch, rate
  as string             driver_name
  as any ptr            im
  as any ptr            pixels    'same address
  as ulong ptr          p32       '
  as single             midx,midy
  as integer            pitchBy, wm = -1, hm = -1, ub = -1, is_screen
  declare sub           screen_init(w as integer=0, h as integer=0, bpp as integer=32, npages as integer=1, flags as integer=0)
  declare sub           create(w as integer=0, h as integer=0, col as ulong=&HFF000000)
                        '2017 Aug 17
  declare sub           get_info(im as any ptr=0)
  declare               destructor
  declare sub           release
 private:
  declare sub           destroy
  as any ptr            hRelease
end type
Destructor.imagevars:  release
End Destructor
sub imagevars.release                             '2016 Aug 30
  w=0: h=0: bpp=0: bypp=0: im=0: pixels=0
  If ImageInfo(hRelease) = 0 Then ImageDestroy hRelease:  hRelease = 0
End Sub
sub imagevars.get_info(im as any ptr)
  if im=0 then
    ScreenInfo w,h, bpp, bypp, pitch, rate, driver_name:  pixels=screenptr
    is_screen = -1: im=0
  elseif Imageinfo(im)=0 then
    ImageInfo im, w, h, bypp, pitch, pixels:  bpp = bypp * 8
    this.im = im:  is_screen = 0
  endif: hRelease = im:  p32=pixels
  wm=w-1:  midx=w/2:  pitchBy=pitch/bypp '' crashes if \ and bypp = 0
  hm=h-1:  midy=h/2:  ub = h*pitchBy - 1
end sub
sub imagevars.screen_init(w as integer, h as integer, bpp as integer, npages as integer, flags as integer)
  release '2017 July 3
  if w=0 or h=0 then get_info: w=this.w: h=this.h
  screenres w,h,bpp,npages,flags: pixels = screenptr
  get_info:  if npages > 1 then screenset 0,1
end sub
sub imagevars.create(_w as integer, _h as integer, col as ulong)
  release:  get_info imagecreate(_w,_h,col)
End Sub

#Macro Alpha256(ret,back, fore, a256) '2017 Mar 26
  ret=((_
  (fore And &Hff00ff) * a256 + _
  (back And &Hff00ff) * (256-a256) + &H800080) And &Hff00ff00 Or (_
  (fore And &H00ff00) * a256 + _
  (back And &H00ff00) * (256-a256) + &H008000) And &H00ff0000) Shr 8
#EndMacro


type dotvars
  as ulong            col=-1
  as single           rad=1,slope=1
End Type


type AaDot
  as dotvars          o
  as dotvars ptr      p
  declare sub         render_target(byref buf as imagevars)
  declare sub         draw(x as single=0, y as single=0)
  declare constructor
 private:
  as single           dy,dxLeft,salpha,cone_h,coneSq,sq
  as long             x0,y0,x1,y1,alph,alpha_max
  as imagevars ptr    pim
end type
constructor.AaDot: p=@o
end constructor
sub AaDot.render_target(byref buf as imagevars)
  pim = @buf
end sub
sub AaDot.draw(x as single, y as single)

  salpha=(p->col shr 24)/255:  alpha_max=salpha*256
  var slope = p->slope
 
  'slope = 1 .. 1 pixel aa edge
  'slope = 2 .. 1/2 pixel (sharp)
  'slope = 1/p->rad .. max blur
  'slope < 1/p->rad .. rendering artifact
 
  sq=1/p->rad                   '' clamp prevents artifact
  slope=iif(slope<sq,sq,slope)  ''
 
  cone_h=slope*p->rad     'pre-inverted aadot imagined as side-viewed cone \/
  coneSq=cone_h*cone_h    'avoid sqr() at blit corners
  sq=(cone_h-1)*(cone_h-1)'avoid sqr() in dot center at max brightness
 
  dim as long x0=x-p->rad:  if x0<0 then x0=0
  dim as long y0=y-p->rad:  if y0<0 then y0=0
  dim as long x1=x+p->rad:  if x1>pim->wm then x1=pim->wm
  dim as long y1=y+p->rad:  if y1>pim->hm then y1=pim->hm
  dy=(y0-y)*slope: dxLeft=(x0-x)*slope
 
  for py as long ptr = @pim->p32[ y0*pim->pitchBy ] to @pim->p32[ y1*pim->pitchBy ] step pim->pitchBy
    dim as single dx=dxleft, dySq=dy*dy
    for px as ulong ptr = @py[x0] to @py[x1]
      salpha = dx*dx+dySq
      if salpha<sq then
          Alpha256(*px,*px,p->col,alpha_max)
      elseif salpha<=coneSq then
          alph=(cone_h-sqr(salpha))*alpha_max
          Alpha256(*px,*px,p->col,alph)
      endif:  dx+=slope
    next: dy+=slope
  next
end sub

''  screen settings
bw = 600          ''  screen width
bh = 400          ''  screen height

dim as imagevars  buf:  buf.screen_init bw,bh

dim as aadot dot:  dot.render_target buf


and then

Code: Select all

         'Circle (b(i).x,b(i).y),b(i).r,b(i).c,,,,f
         with b(i)
         dot.o.rad = .r
         dot.o.col = .c
         dot.draw .x,.y
         end with
Last edited by dafhi on Sep 01, 2017 7:56, edited 1 time in total.
dodicat
Posts: 4338
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Ball collisions

Postby dodicat » Aug 31, 2017 22:13

Without any outside energy pumping.
The kinetic energy of a system should be constant (in practice, fluctuate, but keep a constant average with elastic collisions)
and
The balls should not leak out of the screen.
These vector collisions are hopefully arithmetically correct, but because a computer uses digital jumps, whereas in reality a smooth motion prevails, there is always a chance a ball could go off screen.
So I have added a check function for this.
Also your demo is very nice.

Code: Select all

Screen 20,32
Dim Shared As Integer xres,yres
Screeninfo xres,yres

Type v2D
    As Single x,y
    Declare function length As Single
    Declare function unit As v2D
    #define vct Type<v2D>
    #define dot *
End Type

Type line
    As v2D v1,v2
End Type

Type _object
    As v2D position,velocity
    As Single mass,radius
    as ulong colour
End Type

Operator + (v1 As v2D,v2 As v2D) As v2D
Return vct(v1.x+v2.x,v1.y+v2.y)
End Operator
Operator -(v1 As v2D,v2 As v2D) As v2D
Return vct(v1.x-v2.x,v1.y-v2.y)
End Operator
Operator * (f As Single,v1 As v2D) As v2D 'scalar*v2D
Return vct(f*v1.x,f*v1.y)
End Operator
Operator * (v1 As v2D,v2 As v2D) As Single 'dot product
Return v1.x*v2.x+v1.y*v2.y
End Operator

function v2D.length As Single
Return Sqr(this.x*this.x+this.y*this.y)
End function

function v2D.unit As v2D
Dim n As Single=this.length
If n=0 Then n=1e-20
Return vct(this.x/n,this.y/n)
End function

'=========== VARIABLES ==============================
Redim  As _object ball()

dim  as line Ln(1 to 8)
'the central box
ln(1)=type<line>(vct(.5*xres,.3*yres),vct(.65*xres,.5*yres))
ln(2)=type<line>(vct(.65*xres,.5*yres),vct(.5*xres,.7*yres))
ln(3)=type<line>(vct(.5*xres,.7*yres),vct(.35*xres,.5*yres))
ln(4)=type<line>(vct(.35*xres,.5*yres),vct(.5*xres,.3*yres))
'the screen edges
ln(5)=type<line>(vct(0,yres),vct(xres,yres))'base
ln(6)=type<line>(vct(xres,0),vct(xres,yres))'right
ln(7)=type<line>(vct(0,0),vct(0,yres))'left
ln(8)=type<line>(vct(0,0),vct(xres,0))'top

'================ subs and macros =====================
#define rr(f,l) (Rnd*(l-f)+f)
#define incircle(cx,cy,radius,x,y) (cx-x)*(cx-x) +(cy-y)*(cy-y)<= radius*radius

    Sub setup(ball() as _object,num As long)
        Dim As long count
        Dim As v2D ppos
        For n As long=1 To num
            ppos=vct(rr(30,(xres-30)),rr(30,(yres-30)))
                if incircle((xres/2),(yres/2),.2*yres,ppos.x,ppos.y)=0 then
                count=count+1
                Redim Preserve ball(1 To count)
                ball(count).position=ppos
                ball(count).radius=rr(10,30)
                ball(count).mass=ball(count).radius^2
                ball(count).velocity=2*(vct(rr(-1,1),rr(-1,1))).unit
                ball(count).colour=Rgb(50+Rnd*205,50+Rnd*205,50+Rnd*205)
            End If
        Next
    End Sub
   
    sub drawlines(z() as line)
        for n as long=lbound(z) to 4
            line(z(n).v1.x,z(n).v1.y)-(z(n).v2.x,z(n).v2.y)
            next n
    end sub
       
Function segment_distance(l As line,p As v2D,Byref ip As v2D=vct(0,0)) As Single             
             Dim As Single M1,M2,C1,C2,B
             B=(l.v2.x-l.v1.x):If B=0 Then B=1e-20
             M2=(l.v2.y-l.v1.y)/B:If M2=0 Then M2=1e-20
             M1=-1/M2
             C1=p.y-M1*p.x
             C2=(l.v1.y*l.v2.x-l.v1.x*l.v2.y)/B
    var L1=((p.x-l.v1.x)*(p.x-l.v1.x)+(p.y-l.v1.y)*(p.y-l.v1.y)),L2=((p.x-l.v2.x)*(p.x-l.v2.x)+(p.y-l.v2.y)*(p.y-l.v2.y))
    var a=((l.v1.x-l.v2.x)*(l.v1.x-l.v2.x) + (l.v1.y-l.v2.y)*(l.v1.y-l.v2.y))
        var a1=a+L1
        var a2=a+L2
        var f1=a1>L2,f2=a2>L1
         If f1 Xor f2 Then
    var d1=((p.x-l.v1.x)*(p.x-l.v1.x)+(p.y-l.v1.y)*(p.y-l.v1.y))
    var d2=((p.x-l.v2.x)*(p.x-l.v2.x)+(p.y-l.v2.y)*(p.y-l.v2.y))
    If d1<d2 Then ip.x=l.v1.x:ip.y=l.v1.y : Return Sqr(d1) Else  ip.x=l.v2.x:ip.y=l.v2.y:Return Sqr(d2)
End If
var M=M1-M2:if M=0 then M=1e-20
    ip.x=(C2-C1)/(M1-M2)
    ip.y=(M1*C2-M2*C1)/M
    Return Sqr((p.x-ip.x)*(p.x-ip.x)+(p.y-ip.y)*(p.y-ip.y))
  End Function
 
Function DetectBallCollisions(Byref _that As _object,_this As _object) As Single
    Dim As Single xdiff = _this.position.x-_that.position.x
    Dim As Single ydiff = _this.position.y-_that.position.y
    If Abs(xdiff) > (_this.radius+_that.radius) Then Return 0
    If Abs(ydiff) > (_this.radius+_that.radius) Then Return 0
    var L=Sqr(xdiff*xdiff+ydiff*ydiff)
    If L<=(_this.radius+_that.radius) Then Function=L
End Function

Sub check_ball_to_ball_collisions(ball() as _object)
    For x As long=lbound(ball) To Ubound(ball)-1
        For y As long=x+1 To Ubound(ball)
               if DetectBallCollisions(ball(x),ball(y)) then
            var impulse=(ball(x).position-ball(y).position).unit
                'put ball into real physical location
                ball(x).position=ball(y).position+(ball(x).radius+ball(y).radius)*impulse
                var impact=ball(x).velocity-ball(y).velocity
                var dv=impact dot impulse
                var ma=ball(x).mass: var mb=ball(y).mass
                ball(x).velocity=ball(x).velocity-dv*((2*mb/(ma+mb)))*impulse
                ball(y).velocity=ball(y).velocity+dv*((2*ma/(mb+ma)))*impulse
            End If
        Next y
    Next x
End Sub

sub check_ball_to_line_collisions(Ball() as _object,Ln() as line)
For z As long=lbound(ball) To Ubound(ball)
    For z2 As long=lbound(Ln) To Ubound(Ln)
        dim as v2D closepoint,test
        var seperation=segment_distance(Ln(z2),ball(z).position,closepoint)
        If seperation<=ball(z).radius Then
            var impact=-1*ball(z).velocity
            var impulse=(closepoint-ball(z).position).unit
            'put ball into real physical location
            ball(z).position=closepoint-(ball(z).radius)*impulse
                var dv=(impact dot impulse)
                ball(z).velocity=ball(z).velocity+2*dv*impulse
            End If
    Next z2
Next z
end sub

function AllIn(b() as _object) as long
    for n as long=lbound(b) to ubound(b)
        if b(n).position.x<0 or b(n).position.x>xres then return 0
          if b(n).position.y<0 or b(n).position.y>yres then return 0
        next
        return 1
    end function

Sub drawballs(ball() as _object,Byref ke As long,fps as long)
    For n As long=1 To Ubound(ball)
        ball(n).position=ball(n).position+ball(n).velocity
        ke=ke+.5*ball(n).mass*ball(n).velocity*ball(n).velocity' kinetic energy
        Circle (ball(n).position.x,ball(n).position.y),ball(n).radius,ball(n).colour,,,,f
    Next n
    Draw String(10,10), " Number= "  & Ubound(ball) & ",  Kinetic energy " & ke
    Draw String(10,30), "FPS  "  & fps
    Draw String(10,50), "STATUS:  "  & iif(AllIn(ball()),"OK","Escapees")
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


setup(ball(),80)

Dim As String i
dim as long fps
Do
 
    check_ball_to_line_collisions(ball(),Ln())
    check_ball_to_ball_collisions(ball())
   
    var    ke=0
    i=Inkey
    Screenlock
    Cls
   
    drawballs(ball(),ke,fps)
    drawlines(ln())'only the inner box
   
    Screenunlock
    Sleep regulate(60,fps),1
Loop Until I=Chr(27)
'print tally
Sleep


 
dafhi
Posts: 922
Joined: Jun 04, 2005 9:51

Re: Ball collisions

Postby dafhi » Sep 01, 2017 2:11

I also considered mass. Nice. I see it's the classic circle against every other circle test, also like I did.

I'm sensing fun to be had. Like quicksort's divide-and-conquer strategy which I haven't fully wrapped my head around, there could be a similar approach to this problem.
owen
Posts: 432
Joined: Apr 19, 2006 10:55
Location: Kissimmee, FL
Contact:

Re: Ball collisions

Postby owen » Sep 01, 2017 14:24

@ dodicat
WOW

@ dafhi
what does your example do?
dafhi
Posts: 922
Joined: Jun 04, 2005 9:51

Re: Ball collisions

Postby dafhi » Sep 01, 2017 14:40

anti-aliased circles
owen
Posts: 432
Joined: Apr 19, 2006 10:55
Location: Kissimmee, FL
Contact:

Re: Ball collisions

Postby owen » Sep 01, 2017 14:45

oh, ok.
thanks that might come in handy for my ammo and emp level indicators.
owen
Posts: 432
Joined: Apr 19, 2006 10:55
Location: Kissimmee, FL
Contact:

Re: Ball collisions

Postby owen » Sep 03, 2017 4:46

i think this will be my last update to the bounce algo.
while breaking it down i noticed there were multiple pieces that basically represented a negative or positive sqr(2)

so this is how it looks now.
ps i call the sqr(2) hippasus

Code: Select all

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 hippasus_x,hippasus_y
   
   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
   Select Case b(ball_2).x-b(ball_1).x
      Case 0
         hippasus_x=0
      Case Is > 0
         hippasus_x=hippasus
      Case Is < 0
         hippasus_x=hippasus*-1
   End Select
   Select Case b(ball_2).y-b(ball_1).y
      Case 0
         hippasus_y=0
      Case Is > 0
         hippasus_y=hippasus
      Case Is < 0
         hippasus_y=hippasus*-1
   End Select
   
   b1xnv=(((((hippasus_x*b1xv+hippasus_y*b1yv) * (ball_1_a - ball_2_a) + 2 * ball_2_a * (hippasus_x*b2xv+hippasus_y*b2yv))) / (ball_1_a + ball_2_a))*hippasus_x+(hippasus_y*-1*b1xv+hippasus_x*b1yv)*hippasus_y*-1)
   b1ynv=(((((hippasus_x*b1xv+hippasus_y*b1yv) * (ball_1_a - ball_2_a) + 2 * ball_2_a * (hippasus_x*b2xv+hippasus_y*b2yv))) / (ball_1_a + ball_2_a))*hippasus_y+(hippasus_y*-1*b1xv+hippasus_x*b1yv)*hippasus_x)
   b2xnv=(((((hippasus_x*b2xv+hippasus_y*b2yv) * (ball_2_a - ball_1_a) + 2 * ball_1_a * (hippasus_x*b1xv+hippasus_y*b1yv))) / (ball_1_a + ball_2_a))*hippasus_x+(hippasus_y*-1*b2xv+hippasus_x*b2yv)*hippasus_y*-1)
   b2ynv=(((((hippasus_x*b2xv+hippasus_y*b2yv) * (ball_2_a - ball_1_a) + 2 * ball_1_a * (hippasus_x*b1xv+hippasus_y*b1yv))) / (ball_1_a + ball_2_a))*hippasus_y+(hippasus_y*-1*b2xv+hippasus_x*b2yv)*hippasus_x)

   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/speedout*speedin*.987
   b(ball_2).s=s2/speedout*speedin*.987
   If b(ball_1).s<.0001 Then b(ball_1).s=.0001
   If b(ball_2).s<.0001 Then b(ball_2).s=.0001
   
End Sub

dodicat
Posts: 4338
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Ball collisions

Postby dodicat » Sep 03, 2017 22:35

Looks good owen.
Here's my last, no vector operators and simpler,
Attenuation is done on .dx and .dy, either in the open (friction) -- sub moveanddraw, or in sub BallCollisions (restitution), which I left blank,

(It's alright, I looked up attenuation and restitution)
Aso line 52/53 lets the balls wriggle themselves free if they start their journey from the same point.

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

 sub MoveAndDraw( b() as ball,byref e as Long)'get energy also
    for n as Long=lbound(b) to ubound(b)
       
   ' b(n).dx=.995*b(n).dx
    'b(n).dy=.995*b(n).dy
   
   b(n).x+=b(n).dx:b(n).y+=b(n).dy
    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
end sub

 sub edges(b() as ball,xres as Long,yres as Long,byref status as Long ) '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 single xdiff = B2.x-B1.x
    Dim As single 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) 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)/L
       dim as single  impulsey=(b(n1).y-b(n2).y)/L
       '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
       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 Start()
    dim  as ball b(0 to 10)
    dim as Long fps,energy,status=1
    dim as integer xres,yres
    screen 20,32
     color ,rgb(0,0,50)
    screeninfo xres,yres
   
    for n as Long=lbound(b) to ubound(b)
        with b(n)
            .x=xres/2
            .y=yres/2
            .dx=rnd*5-rnd*5
            .dy=rnd*5-rnd*5
            .col=rgb(rnd*255,rnd*255,rnd*255)
            .r=20+rnd*40
            .m=.r^2
            end with
        next
   
   while 1
        energy=0
      edges(b(),xres,yres,status)
      BallCollisions(b())

      screenlock
        cls
       
        MoveAndDraw(b(),energy)
      draw string(50, 10), " Press escape key to end", rgb(255, 200, 0)
      draw string(50, 55), "framerate " &fps , rgb(0, 200, 0)
      draw string (50,100),"System energy " &energy
        draw string (50,145),"System stauus " & iif(1,"OK","Leaks")
      screenunlock
   
      sleep regulate(65, fps)
      if inkey=chr(27) then exit while
   wend
end sub

Start
sleep




The system energy fluctuates a bit, but it doesn't go into critical.
owen
Posts: 432
Joined: Apr 19, 2006 10:55
Location: Kissimmee, FL
Contact:

Re: Ball collisions

Postby owen » Sep 04, 2017 3:49

dodicat that simplified version is great. i think im getting the picture now.

ps wouldn't you readjust impules x and y after the move

Code: Select all

 sub BallCollisions(b() as ball)
    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)/L
       dim as single  impulsey=(b(n1).y-b(n2).y)/L
       '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
'readjust impulse x and y
       impulsex=(b(n1).x-b(n2).x)/(b(n1).r+b(n2).r)
       impulsey=(b(n1).y-b(n2).y)/(b(n1).r+b(n2).r)


       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

dodicat
Posts: 4338
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Ball collisions

Postby dodicat » Sep 04, 2017 9:55

There is a sight difference in impulses -- true

Code: Select all

impulsex
old               renewed
-0.1886361    -0.1886362
 0.4466563     0.4466564
-0.8825526    -0.8825528
-0.3068343    -0.3068347
 0.2552532     0.2552534
 0.7791622     0.7791622
-0.3976328    -0.3976327
-0.9436295    -0.9436297
-0.4231996    -0.4231995
 0.7869689     0.7869692
-0.173381     -0.173381
 0.858995      0.8589947
 0.02620443    0.02620409


( I got these by writing the values to a text file, before and after re-setting the ball)
The difference seems small here.
Re setting the ball gets rid of those discrete jumps as best as possible, your code also does this.
So the first impulse might be the true one (from actual motion data).
But I'll let you ponder over which is properly correct.
srvaldez
Posts: 1354
Joined: Sep 25, 2005 21:54

Re: Ball collisions

Postby srvaldez » Sep 04, 2017 12:05

<off-topic> I saw this game http://www.ticalc.org/archives/files/fi ... 46908.html and thought that it might interest you to make a clone.
I personally have no time for playing games but it looked like an interesting concept.
dodicat
Posts: 4338
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Ball collisions

Postby dodicat » Sep 04, 2017 12:24

Thanks srvaldez
A paracetamol clone perhaps.

Return to “General”

Who is online

Users browsing this forum: No registered users and 3 guests