## Simple 2D Ball Collision Demo

Post your FreeBASIC source, examples, tips and tricks here. Please don’t post code without including an explanation.
UEZ
Posts: 996
Joined: May 05, 2017 19:59
Location: Germany

### Simple 2D Ball Collision Demo

A simple 2D ball collision incl. mass demo

FB Gfx lib:

Code: Select all

``````'Coded by UEZ build 2024-04-10
#include "fbgfx.bi"
Using FB

Function Rnd2(min As Double, max As Double = &hFFFFFFFF) As Double
Dim As Double Rand = Rnd()
If max = &hFFFFFFFF Then Return Rand * min
If min > max Then Swap min, max
Return Rand * (max - min) + min
End Function

Const w = 1920
Const h = Int(w * 9 / 16)
Const h2 = h Shr 1
Const _t = 1 / 60

ScreenRes w, h, 32, 2, GFX_ALPHA_PRIMITIVES Or GFX_NO_SWITCH Or GFX_NO_FRAME
ScreenSet 1, 0
Color &hFF, &hFFFFFFFF

Randomize, 5

Type vecBalls
As Double x, y, vx, vy, d, r, m
As ULong c
End Type

Dim As ULong iFPS, cfps = 0, iBalls = 40
Dim As Double fTimer = Timer, dx, dy, dist, nx, ny, rvx, rvy, rvdotn, impulse, overlap, mx, my, t1, t2
Dim As Long i, j, nr = Sqr(iBalls), nc = iBalls \ nr, cw = w \ nc, ch = h \ nr, _row, _col
Dim As vecBalls aBalls(iBalls - 1)
For i = 0 To iBalls - 1
With aBalls(i)
.vx = Rnd() * 10 - 5
.vy = Rnd() * 10 - 5
.r = 50 + Rnd() * 64 - 32
.d = 2 * .r
'ordered position to avoid overlapping of balls
_col = i Mod nc
_row = Int(i / nc)
.x = Rnd2(_col * cw + .r, (_col + 1) * cw - .r)
.y = Rnd2(_row * ch + .r, (_row + 1) * ch - .r)
.c = &hFF000000 Or Int(Rnd() * &hFFFFFF)
.m = 1 + Rnd() * 50
End With
Next

Function _Dist(x1 As Double, y1 As Double, r1 As Double, x2 As Double, y2 As Double, r2 As Double) As Boolean
Return Sqr((x2 - x1) ^ 2 + (y2 - y1) ^ 2) < (r1 + r2)
End Function

Do
Cls
For i = 0 To iBalls - 1
With aBalls(i)
'move the ball
.x += .vx
.y += .vy

'check for collision with gui edges
If .x > w - 1 - .r  Then .vx = -.vx : .x = w - 1 - .r
If .x < .r Then .vx = -.vx : .x = .r

If .y > h - 1 - .r Then  .vy = -.vy : .y = h - 1 - .r
If .y < .r Then .vy = -.vy : .y = .r

'check for collision between balls
For j = i + 1 To iBalls - 1
If _Dist(.x, .y, .r, aBalls(j).x, aBalls(j).y, aBalls(j).r) Then
'balls distance To each other
dx = aBalls(j).x - .x
dy = aBalls(j).y - .y
dist = Sqr(dx * dx + dy * dy)

'normalize collision vector
nx = dx / dist
ny = dy / dist

'calculate relative velocity
rvx = aBalls(j).vx - .vx
rvy = aBalls(j).vy - .vy
rvdotn = rvx * nx + rvy * ny

'calculate impulse scalar
impulse = 2 * rvdotn / (.m + aBalls(j).m)

'update velocities
t1 = impulse * aBalls(j).m
.vx += t1 * nx
.vy += t1 * ny
t2 = impulse * .m
aBalls(j).vx -= t2 * nx
aBalls(j).vy -= t2 * ny

'avoid overlapped balls (satelitte effect)
overlap = (.r + aBalls(j).r) - dist
t1 = overlap / dist
mx = dx * t1
my = dy * t1
t1 = mx / 2
t2 = my / 2
.x -= t1
.y -= t2
aBalls(j).x += t1
aBalls(j).y += t2
End If
Next

'draw ball
Circle (.x, .y), .r, .c, , , , F
Draw String (.x - 40 / Len(Int(.m)), .y - 4), Str(Int(.m)), &hFF000000 Or ((&h00FFFFFF And .c) Xor &hBFBFBF)
End With
Next

Draw String(4, 4), iFPS & " fps", &hFF000000

Flip

cfps += 1
If Timer - fTimer > 0.99 Then
iFPS = cfps
cfps = 0
fTimer = Timer
End If
Sleep (1)
Loop Until Len(Inkey())
``````
Cairo:

Code: Select all

``````#include "cairo/cairo.bi"
#include "fbgfx.bi"
Using FB

#define _2pi  							(6.283185307179586)

Function Rnd2(min As Double, max As Double = &hFFFFFFFF) As Double '...'
Dim As Double Rand = Rnd()
If max = &hFFFFFFFF Then Return Rand * min
If min > max Then Swap min, max
Return Rand * (max - min) + min
End Function

Function _Dist(x1 As Double, y1 As Double, r1 As Double, x2 As Double, y2 As Double, r2 As Double) As Boolean '...'
Return Sqr((x2 - x1) ^ 2 + (y2 - y1) ^ 2) < (r1 + r2)
End Function

Dim As Long w = 1920, h = Int(w * 9 / 16)

ScreenRes w, h, 32, , GFX_ALPHA_PRIMITIVES Or GFX_NO_SWITCH Or GFX_NO_FRAME

Dim As Any Ptr pImage = ImageCreate(w, h)
Dim As Any Ptr imgData
ImageInfo(pImage, w, h, , , imgData)

Dim As Long stride = cairo_format_stride_for_width(CAIRO_FORMAT_ARGB32, w)
Dim As cairo_surface_t Ptr cs = cairo_image_surface_create_for_data(imgData, CAIRO_FORMAT_ARGB32, w, h, stride)
Dim As cairo_t Ptr cr = cairo_create(cs)

Randomize, 5

Type vecBalls
As Double x, y, vx, vy, d, r, m
As Double cr, cg, cb
End Type

Dim As ULong iFPS, cfps = 0, iBalls = 40
Dim As Double fTimer = Timer, dx, dy, dist, nx, ny, rvx, rvy, rvdotn, impulse, overlap, mx, my, t1, t2
Dim As Long i, j, nr = Sqr(iBalls), nc = iBalls \ nr, cw = w \ nc, ch = h \ nr, _row, _col
Dim As vecBalls aBalls(iBalls - 1)
For i = 0 To iBalls - 1
With aBalls(i)
.vx = Rnd() * 10 - 5
.vy = Rnd() * 10 - 5
.r = 50 + Rnd() * 64 - 32
.d = 2 * .r
'ordered position to avoid overlapping of balls
_col = i Mod nc
_row = Int(i / nc)
.x = Rnd2(_col * cw + .r, (_col + 1) * cw - .r)
.y = Rnd2(_row * ch + .r, (_row + 1) * ch - .r)
.cr = Rnd()
.cg = Rnd()
.cb = Rnd()
.m = 1 + Rnd() * 50
End With
Next

Do
cairo_set_source_rgb(cr, 1, 1, 1)
cairo_paint(cr)

For i = 0 To iBalls - 1
With aBalls(i)
'move the ball
.x += .vx
.y += .vy

'check for collision with gui edges
If .x > w - 1 - .r  Then .vx = -.vx : .x = w - 1 - .r
If .x < .r Then .vx = -.vx : .x = .r

If .y > h - 1 - .r Then  .vy = -.vy : .y = h - 1 - .r
If .y < .r Then .vy = -.vy : .y = .r

'check for collision between balls
For j = i + 1 To iBalls - 1
If _Dist(.x, .y, .r, aBalls(j).x, aBalls(j).y, aBalls(j).r) Then
'balls distance To each other
dx = aBalls(j).x - .x
dy = aBalls(j).y - .y
dist = Sqr(dx * dx + dy * dy)

'normalize collision vector
nx = dx / dist
ny = dy / dist

'calculate relative velocity
rvx = aBalls(j).vx - .vx
rvy = aBalls(j).vy - .vy
rvdotn = rvx * nx + rvy * ny

'calculate impulse scalar
impulse = 2 * rvdotn / (.m + aBalls(j).m)

'update velocities
t1 = impulse * aBalls(j).m
.vx += t1 * nx
.vy += t1 * ny
t2 = impulse * .m
aBalls(j).vx -= t2 * nx
aBalls(j).vy -= t2 * ny

'avoid overlapping balls (satelitte effect)
overlap = (.r + aBalls(j).r) - dist
t1 = overlap / dist
mx = dx * t1
my = dy * t1
t1 = mx / 2
t2 = my / 2
.x -= t1
.y -= t2
aBalls(j).x += t1
aBalls(j).y += t2
End If
Next

'draw ball
cairo_arc(cr, .x, .y, .r, 0, _2pi)
cairo_set_source_rgba(cr, .cr, .cg, .cb, 1)
cairo_fill(cr)
End With
Next
cairo_move_to(cr, 4, 12)
cairo_set_source_rgba(cr, 0, 0, 0, 1)
cairo_show_text(cr, Str(iFPS) & " fps")

ScreenLock
Put (0, 0), pImage, PSet
ScreenUnlock

cfps += 1
If Timer - fTimer > 0.99 Then
iFPS = cfps
cfps = 0
fTimer = Timer
End If

Sleep 1
Loop Until Len(Inkey)

cairo_destroy(cr)
cairo_surface_destroy(cs)
ImageDestroy(pImage)
``````
Last edited by UEZ on Apr 11, 2024 6:32, edited 1 time in total.
neil
Posts: 594
Joined: Mar 17, 2022 23:26

### Re: Simple 2D Ball Collision Demo

The FB Gfx lib: version won't compile because of this line.

Line 103 .x -= t1Sleep (1)
fxm
Moderator
Posts: 12182
Joined: Apr 22, 2009 12:46
Location: Paris suburbs, FRANCE

### Re: Simple 2D Ball Collision Demo

neil wrote: Apr 10, 2024 22:36 The FB Gfx lib: version won't compile because of this line.

Line 103 .x -= t1Sleep (1)
easy (stuttering):
.x -= t1
UEZ
Posts: 996
Joined: May 05, 2017 19:59
Location: Germany

### Re: Simple 2D Ball Collision Demo

Code corrected - thanks for your feedback.
UEZ
Posts: 996
Joined: May 05, 2017 19:59
Location: Germany

### Re: Simple 2D Ball Collision Demo

Billiard opening simulation:

Code: Select all

``````'Coded by UEZ build 2024-04-12
#include "fbgfx.bi"
Using FB

#define _pi (Acos(-1))

Function _Dist(x1 As Double, y1 As Double, r1 As Double, x2 As Double, y2 As Double, r2 As Double) As Boolean
Return Sqr((x2 - x1) * (x2 - x1) + (y2 - y1) * (y2 - y1)) < (r1 + r2)
End Function

Dim As Long w, h, h2
Screeninfo w, h
w = Int(w * 0.9)
h = Int(w * 9 / 16)
h2 = h Shr 1

ScreenRes w, h, 32, 2, GFX_ALPHA_PRIMITIVES Or GFX_NO_SWITCH
ScreenSet 1, 0
Color &hFF, &hFF006600

Randomize, 5

Type vecBalls
As Double x, y, vx, vy, d, r, m
As ULong c, c2
End Type

Dim As ULong iFPS, cfps = 0, iBalls = 16
Dim As Double fTimer = Timer, dx, dy, dist, nx, ny, rvx, rvy, rvdotn, impulse, overlap, mx, my, t1, t2, friction = 0.993, w23 = w * 2 / 3
Dim As Long i, j, bc, x, y, Ballradius = h \ 32, BallDiameter = Ballradius * 2, Balls_Rows = 5, Balls_Cols = 5, Balls_Offset_x = w / 8, Balls_Offset_y = h2 - (Balls_Cols - 1) * Ballradius, _
Row_Offset_x = BallDiameter, Row_Offset_y = BallDiameter
Dim As vecBalls aBalls(iBalls - 1)

#macro ResetBalls()
bc = 0
For y = 0 To Balls_Rows - 1  'object balls in a triangle order
For x = y To 0 Step -1
With aBalls(bc)
.vx = 0
.vy = 0
.d = 2 * .r
.x = Balls_Offset_x + x * (Row_Offset_x - Ballradius / 4)
.y = Balls_Offset_y + y * Row_Offset_y - Ballradius * x - 1
.c = &hFFC32148
.c2 = &h80631128
.m = 1
End With
bc += 1
Next
Next
bc = iBalls - 1
With aBalls(bc) 'cue ball
.vx = -BallDiameter - Rnd() * Ballradius / 2
.vy = (Rnd() - 0.5)
.d = 2 * .r
.x = w23 + BallDiameter - .vx
.y = h2 + Rnd() - 0.5
.c = &hFFFEFCFF
.c2 = &h40101010
.m = 1
End With
#endmacro

ResetBalls()

Dim As Long mmx, mmy, mmb, clip

Do
GetMouse(mmx, mmy, , mmb, clip)
If (mmb And 1) And clip = 0 Then
ResetBalls()
End If

Cls
Circle (w23 - 2, h2), h Shr 2, &hFF007F00, 4.71238898, 1.57079632  'pi * 3 / 2, pi / 2
Line (w23 - 1, 0) - (w23 + 1, h), &hF0007700, BF

For i = 0 To iBalls - 1
With aBalls(i)
'move the ball
.x += .vx
.y += .vy

.vx *= friction
.vy *= friction

'check for collision with gui edges
If .x > w - 1 - .r  Then .vx = -.vx : .x = w - 1 - .r
If .x < .r Then .vx = -.vx : .x = .r
If .y > h - 1 - .r Then  .vy = -.vy : .y = h - 1 - .r
If .y < .r Then .vy = -.vy : .y = .r

'check for collision between balls
For j = i + 1 To iBalls - 1
If _Dist(.x, .y, .r, aBalls(j).x, aBalls(j).y, aBalls(j).r) Then
'balls distance To each other
dx = aBalls(j).x - .x
dy = aBalls(j).y - .y
dist = Sqr(dx * dx + dy * dy)

'normalize collision vector
nx = dx / dist
ny = dy / dist

'calculate relative velocity
rvx = aBalls(j).vx - .vx
rvy = aBalls(j).vy - .vy
rvdotn = rvx * nx + rvy * ny

'calculate impulse scalar
impulse = 2 * rvdotn / (.m + aBalls(j).m)

'update velocities
t1 = impulse * aBalls(j).m
.vx += t1 * nx
.vy += t1 * ny
t2 = impulse * .m
aBalls(j).vx -= t2 * nx
aBalls(j).vy -= t2 * ny

'avoid overlapped balls (satelitte effect)
overlap = (.r + aBalls(j).r) - dist
t1 = overlap / dist
mx = dx * t1
my = dy * t1
t1 = mx / 2
t2 = my / 2
.x -= t1
.y -= t2
aBalls(j).x += t1
aBalls(j).y += t2
End If
Next

'draw ball
Circle (.x, .y), .r, .c, , , , F
Circle (.x, .y), .r, .c2
'Draw String (.x - 40 / Len(Int(.m)), .y - 4), Str(Int(.m)), &hFFF0F0F0 'display mass value
End With
Next

Draw String(4, 4), iFPS & " fps", &hFFFFFFFF

Flip

cfps += 1
If Timer - fTimer > 0.99 Then
iFPS = cfps
cfps = 0
fTimer = Timer
End If
Sleep (1)
Loop Until Len(Inkey())
``````
Press lmb to restart.
Last edited by UEZ on Apr 12, 2024 19:23, edited 1 time in total.
hhr
Posts: 216
Joined: Nov 29, 2019 10:41

### Re: Simple 2D Ball Collision Demo

@ UEZ
My screen is too small.

Code: Select all

``````Const w = 1920
Const h = Int(w * 9 / 16)
Const h2 = h Shr 1
``````
I tried

Code: Select all

``````Dim As Long w, h, h2
Screeninfo w, h
h2 = h Shr 1
``````
neil
Posts: 594
Joined: Mar 17, 2022 23:26

### Re: Simple 2D Ball Collision Demo

Here's an elastic bouncing ball simulation.
It has settings for mass, velocities, elasticity, friction, and gravity.

Code: Select all

``````' elastic bouncing ball by neil

Const w = 1080
Const h = 720

Screenres w, h, 32
Dim As Single x, y, vx, vy, radius, mass, gravity, elasticity, friction

x = 20
y = 20

vx = 6 'velocity x
vy = 0 'velocity y

gravity = 0.3
elasticity = 0.9
friction = 0.99
mass = 1.3

Sub delay(ByVal amt As Single, ByVal thr As Ulong = 32)
Dim As Double t1 = Timer
Dim As Double t2 = t1 + amt / 1000
If amt > thr + 0.5 Then Sleep amt - thr, 1
Do
Loop Until Timer >= t2
End Sub

Do
ScreenLock
Cls

' Update ball position
vy = vy + gravity * mass
x = x + vx
y = y + vy

' Check for collision with walls
If x - radius < 0 Then
vx = -vx * elasticity
ElseIf x + radius > w Then
x = w - radius
vx = -vx * elasticity
End If

' Check for collision with floor
If y + radius > h Then
y = h - radius
vy = -vy * elasticity
vx = vx * friction
End If

' Draw ball
Circle (x, y), radius, RGB(0, 250, 180),,,,F
ScreenUnlock

delay 12

Loop Until len(Inkey)``````
Last edited by neil on Apr 13, 2024 6:47, edited 1 time in total.
neil
Posts: 594
Joined: Mar 17, 2022 23:26

### Re: Simple 2D Ball Collision Demo

I updated the elastic bouncing ball. I added mass and slowed down the speed.
UEZ
Posts: 996
Joined: May 05, 2017 19:59
Location: Germany

### Re: Simple 2D Ball Collision Demo

Nice neil.
I added to your example to catch and throw the ball around:

Code: Select all

``````' elastic bouncing ball by neil

Const w = 1080
Const h = 720

ScreenRes w, h, 32
Dim As Single x, y, vx, vy, radius, mass, gravity, elasticity, friction, px, py

x = 20
y = 20

vx = 6 'velocity x
vy = 0 'velocity y

gravity = 0.3
elasticity = 0.9
friction = 0.99
mass = 1.3

Sub delay(ByVal amt As Single, ByVal thr As ULong = 32)
Dim As Double t1 = Timer
Dim As Double t2 = t1 + amt / 1000
If amt > thr + 0.5 Then Sleep amt - thr, 1
Do
Loop Until Timer >= t2
End Sub

Dim As Long mmx, mmy, mmb, clip, b

Do
ScreenLock
Cls
GetMouse(mmx, mmy, , mmb, clip)
If (mmb And 1) And clip = 0 Then
If b = 0 Then
px = mmx
py = mmy
b = 1
End If
x = mmx
y = mmy
vx = (x - px) / 12
vy = (y - py) / 12
Else
b = 0
' Update ball position
vy = vy + gravity * mass
x = x + vx
y = y + vy

' Check for collision with walls
If x - radius < 0 Then
vx = -vx * elasticity
ElseIf x + radius > w Then
x = w - radius
vx = -vx * elasticity
End If

' Check for collision with floor
If y + radius > h Then
y = h - radius
vy = -vy * elasticity
End If

If y - radius < 0 Then
vy = -vy * elasticity
End If

End If
' Draw ball
Circle (x, y), radius, RGB(0, 250, 180), , , , F
ScreenUnlock

delay 12

Loop Until Len(Inkey)``````
neil
Posts: 594
Joined: Mar 17, 2022 23:26

### Re: Simple 2D Ball Collision Demo

Nice catch and throw, UEZ. I gave the ball a 3D look and put it in a sprite.

Code: Select all

``````' elastic bouncing ball sprite version by neil

Const w = 1080
Const h = 720
Screenres w, h, 32

Dim As Any Ptr DrawBall = ImageCreate(75, 75, RGB(0, 0, 0))
Dim As Any Ptr EraseBall = ImageCreate(75, 75, RGB(0, 0, 0))

Dim As Single x, y, vx, vy, mass, gravity, elasticity, friction
Dim As UByte Red = 0, Green = 255, Blue = 255, cnt = 0,radius = 37, bsize = 82
x = 37: y = 37

for cnt = 1 to radius
CIRCLE DrawBall, (x, y ),cnt, RGB(Red, Green, Blue)
CIRCLE DrawBall, (x, y + 1), cnt, RGB(Red, Green, Blue)
green -= 6: blue -= 6
next

x = 20
y = 20

vx = 6 'velocity x
vy = 1 'velocity y

gravity = 0.4
elasticity = 0.9
friction = 0.99
mass = 1.3

Sub delay(ByVal amt As Single, ByVal thr As Ulong = 32)
Dim As Double t1 = Timer
Dim As Double t2 = t1 + amt / 1000
If amt > thr + 0.5 Then Sleep amt - thr, 1
Do
Loop Until Timer >= t2
End Sub

Do
ScreenLock
Put (x, y), EraseBall, Pset

' Update ball position
vy = vy + gravity * mass
x = x + vx
y = y + vy

' Check for collision with walls
If x <= 0 Then
x = 0
vx = -vx * elasticity
ElseIf x + bsize > w Then
x = w - bsize
vx = -vx * elasticity
End If

' Check for collision with floor
If y + bsize > h Then
y = h - bsize
vy = -vy * elasticity
vx = vx * friction
End If

Put (X, Y), DrawBall, Pset
ScreenUnlock

delay 12
Loop Until len(Inkey)

ImageDestroy DrawBall
ImageDestroy EraseBall``````
neil
Posts: 594
Joined: Mar 17, 2022 23:26

### Re: Simple 2D Ball Collision Demo

Here's a tornado illusion spinning effect. I came up with this while experimenting with the circle function. Maybe someone could make improvements to how it looks and to its random behavior.

Code: Select all

``````' tornado simulation demo by neil

ScreenRes 1024, 768, 32

Dim As Integer i = 0, x = 500, y = 380, n = 0

Sub delay(ByVal amt As Single, ByVal thr As Ulong = 32)
Dim As Double t1 = Timer
Dim As Double t2 = t1 + amt / 1000
If amt > thr + 0.5 Then Sleep amt - thr, 1
Do
Loop Until Timer >= t2
End Sub

Randomize

Do

ScreenLock
Cls

For i = 1 To 50
Circle (x, y ), Rnd * 140, rgb(255,255,255)

ScreenUnlock

' how fast it spins
delay 2.5

Next i

n = int(rnd * 8) + 1

' direction and how fast the tornado moves
if n = 1 Then x += 6: y += 4
if n = 2 Then x -= 6: y -= 4
if n = 3 Then x += 4: y += 6
if n = 4 Then x -= 4: y -= 6
if n = 5 Then x += 20
if n = 6 Then y += 20
If n = 7 Then x -= 20
if n = 8 Then y -= 20

' Screen limits
if x < 140 Then x = 140
if y < 140 Then y = 140
if x > 880 Then x = 880
if y > 620 Then y = 620

Loop Until len(Inkey)
Sleep``````
UEZ
Posts: 996
Joined: May 05, 2017 19:59
Location: Germany

### Re: Simple 2D Ball Collision Demo

Any idea how to rotate the mapped texture of the ball properly?

Code: Select all

``````'Coded by UEZ build 2024-05-10
#include "fbgfx.bi"
Using FB

#define _pi (Acos(-1))
#define _2pi (2 * Acos(-1))

Function MapCoordinate(i1 As Double, i2 As Double, w1 As Double, w2 As Double, p As Double) As Double '...'
Return ((p - i1) / (i2 - i1)) * (w2 - w1) + w1
End Function

Sub RotX(angle As Double, ByRef y As Double, ByRef z As Double) '...'
Dim As Double ca = Cos(angle), sa = Sin(angle), y1 = y * ca - z * sa, z1 = y * sa + z * ca
y = y1
z = z1
End Sub

Sub RotY(angle As Double, ByRef x As Double, ByRef z As Double) '...'
Dim As Double ca = Cos(angle), sa = Sin(angle), x1 = x * ca - z * sa, z1 = x * sa + z * ca
x = x1
z = z1
End Sub

Sub RotZ(angle As Double, ByRef x As Double, ByRef y As Double) '...'
Dim As Double ca = Cos(angle), sa = Sin(angle), x1 = x * ca - y * sa, y1 = x * sa + y * ca
x = x1
y = y1
End Sub

Sub MapImage2Sphere(px As Short, py As Short, w As UShort, h As UShort, radius As Double, pSourceImage As Any Ptr, xa As Double = 0, ya As Double = 0, za As Double = 0, theta0 As Double = 0, theta1 As Double = _2pi, phi0 As Double = 0, phi1 As Double = _pi, pImage As Any Ptr = 0) '...'
Dim As UShort i, j
Dim As ULong c
Dim As Double theta, phi, x, y, z, sp
For i = 0 To w - 1
theta = MapCoordinate(0, w - 1, theta1, theta0, i)
For j = 0 To h -1
phi = MapCoordinate(0, h - 1, phi0, phi1, j)
sp = Sin(phi)
x = radius * sp * Cos(theta)
y = radius * sp * Sin(theta)
z = radius * Cos(phi)
If xa Then RotX(xa, y, z)
If ya Then RotY(ya, x, z)
If za Then RotZ(za, x, y)
If z > 0 Then
c = Point(i, j, pSourceImage)
PSet pImage, (px + x, py + y), c
End If
Next
Next
End Sub

Function _Dist(x1 As Double, y1 As Double, r1 As Double, x2 As Double, y2 As Double, r2 As Double) As Boolean
Return Sqr((x2 - x1) * (x2 - x1) + (y2 - y1) * (y2 - y1)) < (r1 + r2)
End Function

Dim As Long w, h, h2
ScreenInfo w, h
w = Int(w * 0.9)
h = Int(w * 9 / 16)
h2 = h Shr 1

ScreenRes w, h, 32, 2, GFX_ALPHA_PRIMITIVES Or GFX_NO_SWITCH
ScreenSet 1, 0
Color &hFF, &hFF006600

Randomize, 5

Type vecBalls '...'
As Double x, y, vx, vy, d, r, m
As ULong c, c2
End Type

Dim As ULong iFPS, cfps = 0, iBalls = 16
Dim As Double fTimer = Timer, dx, dy, dist, nx, ny, rvx, rvy, rvdotn, impulse, overlap, mx, my, t1, t2, friction = 0.993, w23 = w * 2 / 3
Dim As Long i, j, bc, x, y, Ballradius = h \ 32, BallDiameter = Ballradius * 2, Balls_Rows = 5, Balls_Cols = 5, Balls_Offset_x = w / 8, Balls_Offset_y = h2 - (Balls_Cols - 1) * Ballradius, _
Row_Offset_x = BallDiameter, Row_Offset_y = BallDiameter
Dim As vecBalls aBalls(iBalls - 1)

Dim As Long pitch
Dim As UShort iW = 309, iH = 156
Dim As Any Ptr pImg8 = ImageCreate(iW, iH, 0, 32), pixels
ImageInfo(pImg8 , , , , pitch, pixels)
Dim As Double ax = _pi / 2, ay, az, _dir

#macro ResetBalls()
bc = 0
ax = _pi / 2
_dir = 0
For y = 0 To Balls_Rows - 1  'object balls in a triangle order
For x = y To 0 Step -1
With aBalls(bc)
.vx = 0
.vy = 0
.d = 2 * .r
.x = Balls_Offset_x + x * (Row_Offset_x - Ballradius / 4)
.y = Balls_Offset_y + y * Row_Offset_y - Ballradius * x - 1
.c = &hFFC32148
.c2 = &h80631128
.m = 1
End With
bc += 1
Next
Next
bc = iBalls - 1
With aBalls(bc) 'cue ball '...'
.vx = -BallDiameter - Rnd() * Ballradius / 2
.vy = (Rnd() - 0.5)
.d = 2 * .r
.x = w23 + BallDiameter - .vx
.y = h2 + Rnd() - 0.5
.c = &hFFFEFCFF
.c2 = &h40101010
.m = 1
End With
#endmacro

ResetBalls()

Dim As Long mmx, mmy, mmb, clip

Do
GetMouse(mmx, mmy, , mmb, clip)
If (mmb And 1) And clip = 0 Then
ResetBalls()
End If

Cls
Circle (w23 - 2, h2), h Shr 2, &hFF007F00, 4.71238898, 1.57079632  'pi * 3 / 2, pi / 2
Line (w23 - 1, 0) - (w23 + 1, h), &hF0007700, BF

For i = 0 To iBalls - 1
With aBalls(i)
'move the ball
.x += .vx
.y += .vy

.vx *= friction
.vy *= friction

'check for collision with gui edges
If .x > w - 1 - .r  Then .vx = -.vx : .x = w - 1 - .r
If .x < .r Then .vx = -.vx : .x = .r
If .y > h - 1 - .r Then  .vy = -.vy : .y = h - 1 - .r
If .y < .r Then .vy = -.vy : .y = .r

'check for collision between balls
For j = i + 1 To iBalls - 1
If _Dist(.x, .y, .r, aBalls(j).x, aBalls(j).y, aBalls(j).r) Then
'balls distance To each other
dx = aBalls(j).x - .x
dy = aBalls(j).y - .y
dist = Sqr(dx * dx + dy * dy)

'normalize collision vector
nx = dx / dist
ny = dy / dist

'calculate relative velocity
rvx = aBalls(j).vx - .vx
rvy = aBalls(j).vy - .vy
rvdotn = rvx * nx + rvy * ny

'calculate impulse scalar
impulse = 2 * rvdotn / (.m + aBalls(j).m)

'update velocities
t1 = impulse * aBalls(j).m
.vx += t1 * nx
.vy += t1 * ny
t2 = impulse * .m
aBalls(j).vx -= t2 * nx
aBalls(j).vy -= t2 * ny

'avoid overlapped balls (satelitte effect)
overlap = (.r + aBalls(j).r) - dist
t1 = overlap / dist
mx = dx * t1
my = dy * t1
t1 = mx / 2
t2 = my / 2
.x -= t1
.y -= t2
aBalls(j).x += t1
aBalls(j).y += t2
End If
Next

'draw ball
If i = 7 Then
_dir = Atan2(.vy, .vx)
MapImage2Sphere(.x, .y, iW, iH, .r, pImg8, Cos(_dir) * .r * .vx * _dir, Sin(_dir) * .r * .vy * _dir)
Else
Circle (.x, .y), .r, .c, , , , F
Circle (.x, .y), .r, .c2
'Draw String (.x - 40 / Len(Int(.m)), .y - 4), Str(Int(.m)), &hFFF0F0F0 'display mass value
End If

End With
Next

Draw String(4, 4), iFPS & " fps", &hFFFFFFFF

Flip

cfps += 1
If Timer - fTimer > 0.99 Then
iFPS = cfps
cfps = 0
fTimer = Timer
End If
Sleep (1)
Loop Until Len(Inkey())

ImageDestroy(pImg8)
``````
The needed bitmap can be found on my OneDrive: FB Simple 2D Ball Collision)
Last edited by UEZ on May 18, 2024 10:16, edited 1 time in total.
UEZ
Posts: 996
Joined: May 05, 2017 19:59
Location: Germany

### Re: Simple 2D Ball Collision Demo

I made some progress here but I'm still not satisfied with the result.

Code: Select all

``````'Coded by UEZ build 2024-05-16 beta
#cmdline "-gen gcc -Wc -Ofast -Wc -march=native -Wc -funroll-loops -Wc -mfpmath=sse"
#include "fbgfx.bi"
#include "crt/math.bi"
Using FB

#define _pi (Acos(-1))
#define _2pi (2 * Acos(-1))

Dim Shared As Long pitchS, bppS
Dim Shared As Any Ptr pixelS

Function _ASM_Cos6th2 Naked cdecl(ByVal fX As Double) As Double 'by Eukalyptus '...'
'By Eukalyptus - modified by srvaldez
Asm
' if FB-32-bit, then load fx from stack, else it's already in xmm0
' ebx/rbx needs to be preserved, not sure about ecx/rcx
#ifndef __FB_64BIT__
lea eax, [esp+4]
push ebx
push ecx
movq xmm0, [eax]
#else
push rbx
push rcx
#endif
mulsd xmm0, [1f]
movd ebx, xmm0

add ebx, 0x40000000 'SinToCos

lea  eax, [ebx * 2 + &h80000000]
sar  eax, 2
imul eax
sar  ebx, 31
lea  eax, [edx * 2 - &h70000000]
lea  ecx, [edx * 8 + edx - &h24000000]
imul edx
xor  ecx, ebx
lea  eax, [edx * 8 + edx + &h44A00000]
imul ecx

cvtsi2sd xmm0, edx
mulsd xmm0, [2f]
' if FB-32-bit, then transfer xmm0 into fpu, else we are done
' restore saved registers
#ifndef __FB_64BIT__
pop ecx
pop ebx
movq [esp - 12], xmm0
fld qword ptr [esp - 12]
#else
pop rcx
pop rbx
#endif
ret
1: .Double 683565275.57643158
2: .Double -0.0000000061763971109087229
3: .Double 6755399441055744.0
End Asm
End Function

Function _ASM_Sin6th2 Naked cdecl(ByVal fX As Double) As Double 'by Eukalyptus '...'
'By Eukalyptus - modified by srvaldez
Asm
' if FB-32-bit, then load fx from stack, else it's already in xmm0
' ebx/rbx needs to be preserved, not sure about ecx/rcx
#ifndef __FB_64BIT__
lea eax, [esp + 4]
push ebx
push ecx
movq xmm0, [eax]
#else
push rbx
push rcx
#endif
mulsd xmm0, [1f]
movd ebx, xmm0

lea  eax, [ebx * 2 + &h80000000]
sar  eax, 2
imul eax
sar  ebx, 31
lea  eax, [edx * 2 - &h70000000]
lea  ecx, [edx * 8 + edx - &h24000000]
imul edx
xor  ecx, ebx
lea  eax, [edx * 8 + edx + &h44A00000]
imul ecx

cvtsi2sd xmm0, edx
mulsd xmm0, [2f]
' if FB-32-bit, then transfer xmm0 into fpu, else we are done
' restore saved registers
#ifndef __FB_64BIT__
pop ecx
pop ebx
movq [esp-12], xmm0
fld qword ptr [esp-12]
#else
pop rcx
pop rbx
#endif
ret
1: .Double 683565275.57643158
2: .Double -0.0000000061763971109087229
3: .Double 6755399441055744.0
End Asm
End Function

Function MapCoordinate(i1 As Double, i2 As Double, w1 As Double, w2 As Double, p As Double) As Double '...'
Return ((p - i1) / (i2 - i1)) * (w2 - w1) + w1
End Function

Sub RotX(angle As Double, ByRef y As Double, ByRef z As Double) '...'
Dim As Double ca = _ASM_Cos6th2(angle), sa = _ASM_Sin6th2 (angle), y1 = y * ca - z * sa, z1 = y * sa + z * ca
y = y1
z = z1
End Sub

Sub RotY(angle As Double, ByRef x As Double, ByRef z As Double) '...'
Dim As Double ca = _ASM_Cos6th2(angle), sa = _ASM_Sin6th2 (angle), x1 = x * ca - z * sa, z1 = x * sa + z * ca
x = x1
z = z1
End Sub

Sub RotZ(angle As Double, ByRef x As Double, ByRef y As Double) '...'
Dim As Double ca = _ASM_Cos6th2(angle), sa = _ASM_Sin6th2 (angle), x1 = x * ca - y * sa, y1 = x * sa + y * ca
x = x1
y = y1
End Sub

Sub MapImage2Sphere(px As Short, py As Short, w As UShort, h As UShort, radius As Double, pSourceImage As Any Ptr, xa As Double = 0, ya As Double = 0, za As Double = 0, theta0 As Double = 0, theta1 As Double = _2pi, phi0 As Double = 0, phi1 As Double = _pi, pImage As Any Ptr = 0) '...'
Dim As UShort i, j
Dim As ULong c
Dim As Double theta, phi, x, y, z, sp, rsp
Dim As ULong Ptr pCol
ImageInfo(pSourceImage, , , bppS, pitchS, pixelS)
For i = 0 To w - 1
theta = MapCoordinate(0, w - 1, theta1, theta0, i)
For j = 0 To h -1
phi = MapCoordinate(0, h - 1, phi0, phi1, j)
sp = _ASM_Sin6th2 (phi)
rsp = radius * sp
x = rsp * _ASM_Cos6th2(theta)
y = rsp * _ASM_Sin6th2(theta)
z = radius * _ASM_Cos6th2(phi)
If xa Then RotX(xa, y, z)
If ya Then RotY(ya, x, z)
If za Then RotZ(za, x, y)
If z > 0 Then
pCol = pixelS + j * pitchS + i * bppS
PSet pImage, (px + x, py + y), pCol[0]
End If
Next
Next
End Sub

Function _Dist(x1 As Double, y1 As Double, r1 As Double, x2 As Double, y2 As Double, r2 As Double) As Boolean '...'
Dim As Double xd = x2 - x1, yd = y2 - y1
Return Sqr(xd * xd + yd * yd) < (r1 + r2)
End Function

Dim As Long w, h, h2
ScreenInfo w, h
w = Int(w * 0.75)
h = Int(w * 9 / 16)
h2 = h Shr 1

ScreenRes w, h, 32, 2, GFX_ALPHA_PRIMITIVES Or GFX_NO_SWITCH
ScreenSet 1, 0
Color &hFF, &hFF006600

Randomize, 5

Type vecBalls '...'
As Double x, y, vx, vy, d, r, m, ox, oy
As ULong c, c2
End Type

Dim As ULong iFPS, cfps = 0, iBalls = 16
Dim As Double fTimer = Timer, dx, dy, dist, nx, ny, rvx, rvy, rvdotn, impulse, overlap, mx, my, t1, t2, friction = 0.993, w23 = w * 2 / 3
Dim As Long i, j, bc, x, y, Ballradius = h \ 32, BallDiameter = Ballradius * 2, Balls_Rows = 5, Balls_Cols = 5, Balls_Offset_x = w / 8, Balls_Offset_y = h2 - (Balls_Cols - 1) * Ballradius, _
Row_Offset_x = BallDiameter, Row_Offset_y = BallDiameter, U = BallDiameter * _pi
Dim As vecBalls aBalls(iBalls - 1)

Dim As UShort iW = 309, iH = 156
Dim As Any Ptr pBalls(iBalls  - 1)
For i = 1 To iBalls - 1
pBalls(i - 1) = ImageCreate(iW, iH, 0, 32)
BLoad(Str(i) & ".bmp", pBalls(i - 1))
Next

Dim As Double ax = _pi / 2, a

#macro ResetBalls()
bc = 0
For y = 0 To Balls_Rows - 1  'object balls in a triangle order
For x = y To 0 Step -1
With aBalls(bc)
.vx = 0
.vy = 0
.d = 2 * .r
.x = Balls_Offset_x + x * (Row_Offset_x - Ballradius / 4)
.y = Balls_Offset_y + y * Row_Offset_y - Ballradius * x - 1
.m = 1
End With
bc += 1
Next
Next
bc = iBalls - 1
With aBalls(bc) 'cue ball
.vx = -BallDiameter - Rnd() * Ballradius / 2
.vy = (Rnd() - 0.5)
.d = 2 * .r
.x = w23 + BallDiameter - .vx
.y = h2 + Rnd() - 0.5
.c = &hFFFEFCFF
.c2 = &h40101010
.m = 1
End With
#endmacro

ResetBalls()

Dim As Long mmx, mmy, mmb, clip

Do
GetMouse(mmx, mmy, , mmb, clip)
If (mmb And 1) And clip = 0 Then
ResetBalls()
End If

Cls
Circle (w23 - 2, h2), h2 Shr 1, &hFF007F00, 4.71238898, 1.57079632  'pi * 3 / 2, pi / 2
Line (w23 - 1, 0) - (w23 + 1, h), &hF0007700, BF

For i = 0 To iBalls - 1
With aBalls(i)
'move the ball
.ox = .x
.oy = .y
.x += .vx
.y += .vy

.vx *= friction
.vy *= friction

'check for collision with gui edges
If .x > w - 1 - .r  Then .vx = -.vx : .x = w - 1 - .r
If .x < .r Then .vx = -.vx : .x = .r
If .y > h - 1 - .r Then  .vy = -.vy : .y = h - 1 - .r
If .y < .r Then .vy = -.vy : .y = .r

'check for collision between balls
For j = i + 1 To iBalls - 1 '...'
If _Dist(.x, .y, .r, aBalls(j).x, aBalls(j).y, aBalls(j).r) Then
'balls distance To each other
dx = aBalls(j).x - .x
dy = aBalls(j).y - .y
dist = Sqr(dx * dx + dy * dy)

'normalize collision vector
nx = dx / dist
ny = dy / dist

'calculate relative velocity
rvx = aBalls(j).vx - .vx
rvy = aBalls(j).vy - .vy
rvdotn = rvx * nx + rvy * ny

'calculate impulse scalar
impulse = 2 * rvdotn / (.m + aBalls(j).m)

'update velocities
t1 = impulse * aBalls(j).m
.vx += t1 * nx
.vy += t1 * ny
t2 = impulse * .m
aBalls(j).vx -= t2 * nx
aBalls(j).vy -= t2 * ny

'avoid overlapped balls (satelitte effect)
overlap = (.r + aBalls(j).r) - dist
t1 = overlap / dist
mx = dx * t1
my = dy * t1
t1 = mx / 2
t2 = my / 2
.x -= t1
.y -= t2
aBalls(j).x += t1
aBalls(j).y += t2

End If
Next

'draw balls
If i < iBalls - 1 Then
a = Atan2(.vy, .vx)
MapImage2Sphere(.x, .y, iW, iH, .r, pBalls(i), ax + a *.vy * _pi, (_pi + a) * .vx * _pi)
Else 'cue ball
Circle (.x, .y), .r, .c, , , , F
Circle (.x, .y), .r, .c2
EndIf
End With
Next

Draw String(4, 4), iFPS & " fps", &hFFFFFFFF

Flip

cfps += 1
If Timer - fTimer > 0.99 Then
iFPS = cfps
cfps = 0
fTimer = Timer
End If
Sleep (1)
Loop Until Len(Inkey())

For i = 0 To iBalls - 1
ImageDestroy(pBalls(i))
Next
``````
Download of the bitmaps: OneDrive or Simple 2D Ball Collision - Billiard Opening2