Simple 2D Ball Collision Demo

[UEZ]

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)

[neil]

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

Line 103 .x -= t1Sleep (1)

[fxm]

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

Line 103 .x -= t1Sleep (1)

easy (stuttering):
.x -= t1

[UEZ]

Code corrected - thanks for your feedback.

[UEZ]

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
				.r = Ballradius
				.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)
		.r = Ballradius
		.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

			'add friction
			.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.

[hhr]

@ UEZ
My screen is too small.
Instead of

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]

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

radius = 35
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
        x = radius
        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)

[neil]

I updated the elastic bouncing ball. I added mass and slowed down the speed.

[UEZ]

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

radius = 35
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
	        x = radius
	        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
	        y = radius
	        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]

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]

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]

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
BLoad("08f_309x156.bmp", pImg8)
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
				.r = Ballradius
				.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)
		.r = Ballradius
		.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

			'add friction
			.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)

[UEZ]

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]
         addsd xmm0, [3f]
         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]
         addsd xmm0, [3f]
         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
				.r = Ballradius
				.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)
		.r = Ballradius
		.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

			'add friction
			.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