Simple 2D Ball Collision Demo

UEZ · Post by **UEZ** » Apr 10, 2024 20:53

A simple 2D ball collision incl. mass demo

FB Gfx lib:

'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 · Post by **neil** » Apr 10, 2024 22:36

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

Line 103 .x -= t1Sleep (1)

Post by **fxm** » Apr 11, 2024 5:13

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 · Post by **UEZ** » Apr 11, 2024 6:33

Code corrected - thanks for your feedback.

UEZ · Post by **UEZ** » Apr 11, 2024 12:15

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 · Post by **hhr** » Apr 12, 2024 16:45

@ 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 · Post by **neil** » Apr 13, 2024 1:20

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 · Post by **neil** » Apr 13, 2024 6:42

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

UEZ · Post by **UEZ** » Apr 13, 2024 8:15

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 · Post by **neil** » Apr 13, 2024 9:34

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 · Post by **neil** » Apr 18, 2024 2:51

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

Simple 2D Ball Collision Demo

Simple 2D Ball Collision Demo

Re: Simple 2D Ball Collision Demo

Re: Simple 2D Ball Collision Demo

Re: Simple 2D Ball Collision Demo

Re: Simple 2D Ball Collision Demo

Re: Simple 2D Ball Collision Demo

Re: Simple 2D Ball Collision Demo

Re: Simple 2D Ball Collision Demo

Re: Simple 2D Ball Collision Demo

Re: Simple 2D Ball Collision Demo

Re: Simple 2D Ball Collision Demo