Real snooker game with very effective physics

Game development specific discussions.
Post Reply
jepalza
Posts: 136
Joined: Feb 24, 2010 10:08
Location: Spain (Bilbao)

Real snooker game with very effective physics

Post by jepalza »

This code is not mine, it comes from B4A Android forum:
https://www.b4x.com/android/forum/threa ... tion.7899/

With heavly modifications made from me in order to run in FB , and for best visualization. The next: to put sounds effect !!

NEW: now with sounds, look below --> https://freebasic.net/forum/viewtopic.p ... 19#p294919

Simple version, without sounds

Code: Select all

' 2D Snooker physics (basic simulation)- Jim Brown (2011)
' v1.02 - Added additional comments and relabelled variables
' Credits: Joseph Humfrey
' NOTE: Uses the "Phone" library (keep phone awake)
'
' heavily changes by jepalza (Joseba Epalza <jepalza_at_gmail_com> 2022)

'#Include "fbgfx.bi"
#Include "windows.bi" ' only for BOOL

 Randomize timer

	' Process_Globals
	Dim Shared FRICTION  As Single		' fiction of the balls
	Dim Shared BALL_MASS  As Single		' weight of the balls
	Dim Shared BALL_RADIUS As Single	' radius of the balls
	Dim Shared BALL_DIAMETER As Single	' diameter of the balls
	Dim Shared NUMBALLS As Integer			' how many balls to control
	Dim Shared ballsmoving As BOOL	' flag to indicate whether or not any of the balls are moving
		
	Dim Shared As Single mouseX,mouseY
	Dim Shared As Single cueAngle,cuePower

	
	Type balltype 
		x As Single
		y As Single
		dx As Single
		dy As Single
		color_ As Integer
	End Type
	Dim Shared ball(50) As balltype


	' Globals
	Dim Shared As Integer centerX,centerY	' center of the snooker table display area (panel 2)
	Dim Shared As Integer powerBarX,powerBarY,powerBarWidth,powerBarHeight	' power bar positions (panel 1)
	Dim Shared As Integer count
	Dim Shared As BOOL win1_Invalidate=FALSE
	
	' display-related variables
	Type Win 
		As Integer WinXpos
		As Integer WinYpos
		As Integer WinHeight
		As Integer WinWidth
	End Type
	Dim Shared As Win win1,win2

	
	Declare Sub RenderPanel1()
	Declare Sub RenderPanel2()
	Declare Sub UpdatePhysics()
	Declare Sub SetupTriangle()
	Declare Sub SetupCueBall()
	Declare Function RNum() As Single
	Declare Function AreBallsMoving() As BOOL
	Declare Function RangeRND(a As Integer, b As Integer) As Single


' user has touched Panel 1 (the left panel)
Sub panel1_Touch (X As Single, Y As Single)
	If ballsmoving=TRUE Or win1_Invalidate=TRUE Then Return
	' check if touched point is over the 'power bar' indicator
	If Y>=powerBarY AND Y<=powerBarHeight Then
		Dim As Integer range=(powerBarHeight-powerBarY)
		Dim As single scale=range/100
		cuePower=(range-(Y-powerBarY-5))/scale
		If cuePower<5 Then cuePower=5
		If cuePower>100 Then cuePower=100
		RenderPanel1()
		Return
	End If
	' check if touch point is over the 'take shot' ball
	If Y>powerBarY+powerBarHeight And Y<powerBarY+powerBarHeight+(BALL_DIAMETER*2) Then
		cueAngle=ATan2(mouseX-ball(0).X,mouseY-ball(0).Y)
		ball(0).dx=Sin(cueAngle)*cuePower
		ball(0).dy=Cos(cueAngle)*cuePower
		Color(RGB(0,0,0))
		win1_Invalidate=TRUE
		ballsmoving=TRUE
	End If
End Sub

' user has touched Panel 2 (the snooker table panel)
Sub panel2_Touch (X As Single, Y As Single)
	mouseX=X : mouseY=Y 
	RenderPanel2()
End Sub


Sub Run_All()
	count=count+1
	
	Cls
	RenderPanel1()
	RenderPanel2()
	screencopy
	
	If ballsmoving=TRUE Then
		UpdatePhysics()
		RenderPanel2()
		If count Mod 20=0 Then
			If AreBallsMoving=FALSE Then
				ballsmoving=FALSE : RenderPanel1() : RenderPanel2()
			End If
		End If
	End If
End Sub

Sub RenderPanel1()

	' power bar indicator
	Dim As Integer col
	Dim As Integer range=(powerBarHeight-powerBarY)
	Dim As Single  scale=range/100
	Dim As Integer bargr=powerBarY+5+(range -(cuePower*scale))
	Line(powerBarX,powerBarY)-(powerBarWidth,powerBarHeight),RGB(0,0,230),bf
	' if we wants ramp effect
	For f As Integer=bargr To powerBarHeight-5
		If ((f/8) Mod 2)=0 Then col=RGB(255,255,255) Else col=RGB(200,200,200)
		Line(powerBarX+(f/scale)-10,f)-(powerBarWidth-5,f),col
	Next
	' little bug !! needs to clear upper-left corner of bar... 
	Line(powerBarX,powerBarY)-step(5,50),RGB(0,0,230),bf
	Line(0,0)-step(10,50),RGB(0,0,0),bf
	' if we wants only rectangle
	'Line(powerBarX+5,powerBarY+5+(range -(cuePower*scale)))-(powerBarWidth-5,powerBarHeight-5),RGB(255,255,255),bf
	' take shot ball
	Circle(powerBarX+(powerBarWidth/2.0),powerBarY+powerBarHeight+50),win1.WinWidth/2-20,RGB(200,200,200),,,,f
	Circle(powerBarX+(powerBarWidth/2.0),powerBarY+powerBarHeight+50),win1.WinWidth/2-26,RGB(255,255,255),,,,f

End Sub

Sub RenderPanel2()
	
	' borde
	Line(win2.WinXpos+5,win2.WinYpos+5)-Step(win2.WinWidth-8,win2.WinHeight-8),RGB(150,50,0),bf 
	' mesa
	Line(win2.WinXpos+20,win2.WinYpos+20)-step(win2.WinWidth-40,win2.WinHeight-40),RGB(16,127,78),bf 
		
	' Draw each ball. Note that ball(0) is the cue ball
	Dim As integer col,col2
	For i As Integer=0 To NUMBALLS
		' complex, but simple system to get shaded balls without images or sprites
		col2=ball(i).color_
		For g As Integer=0 To BALL_RADIUS-2
			If col2=1 Then col=RGB(255-((BALL_RADIUS-g)*3),255-((BALL_RADIUS-g)*3),255-((BALL_RADIUS-g)*3))
			If col2=2 Then col=RGB(255-((BALL_RADIUS-g)*3),0,0)
			If col2=3 Then col=RGB(255-((BALL_RADIUS-g)*3),255-((BALL_RADIUS-g)*3),0)
			Circle(ball(i).x, ball(i).y), BALL_RADIUS-g, col,,,,f
		Next
	Next
	
	' Render the aiming line and circle (only when all balls have stopped moving)
	If ballsmoving=FALSE Then
		win1_Invalidate=FALSE
		Line (ball(0).x,ball(0).y)-(mouseX,mouseY),RGB(0,0,0),,&hF0F0
		Circle (mouseX,mouseY),BALL_RADIUS,RGB(0,0,0)
	End If

End Sub

' Arrange balls in a triangle formation
Sub SetupTriangle()
	Dim As Integer ballTriangleSize,i,xloop,yloop
	i=0
	Do Until i>=NUMBALLS
		ballTriangleSize=ballTriangleSize+1
		i=i+ballTriangleSize
	Loop
	i=1
	Dim As Integer adjustX= win2.WinWidth/3
	Dim As Integer adjustY=-win2.WinHeight/2 -8
	For xloop=ballTriangleSize To 1 Step -1
		For yloop=1 To xloop
			ball(i).x=adjustX+((5+xloop)*(BALL_DIAMETER*1.2)+150+RNum)
			ball(i).y=adjustY+((yloop*(BALL_DIAMETER*1.2))-(xloop*(BALL_DIAMETER*1.2))/2+(centerX)+RNum)
			ball(i).dx=0.0
			ball(i).dy=0.0
			' yellow or red ball colour
			If i Mod(2)=0 Then
				ball(i).color_=2 'RGB(210,30,20)
			Else
				ball(i).color_=3 'RGB(240,200,18)
			End If
			i=i+1
		Next
	Next
End Sub


' Position the cue ball and set the aiming direction to point above the ball
Sub SetupCueBall()
	Dim As Integer adjustX= win2.WinWidth/5
	ball(0).x=((win2.WinWidth/2)-BALL_RADIUS-RangeRND(60,65))-adjustX ' inital position random, like a real human use
	ball(0).y=(centerY+BALL_RADIUS+RNum)-27
	ball(0).dx=0.0
	ball(0).dy=0.0
	ball(0).color_=1
	mouseY=(centerY+BALL_RADIUS+RangeRND(-10,10))
	'mouseX=(win2.WinHeight/2.75)+350
	mouseX=((win2.WinWidth/2)-BALL_RADIUS)+200
	cuePower=RangeRND(70,80)
End Sub

Sub UpdatePhysics()
	Dim As Integer i,b
	Dim As Single actualDist, collisionNormalAngle, moveDist
	Dim As Single nX,nY,a1,a2,optimisedP
	
	For i=0 To NUMBALLS
		
		' MOVEMENT
		' Update ball postion
		ball(i).x=ball(i).x+ball(i).dx
		ball(i).y=ball(i).y+ball(i).dy
		' Slow the ball down via the global friction value
		ball(i).dx=ball(i).dx*FRICTION
		ball(i).dy=ball(i).dy*FRICTION
		' Stop ball completely when below certain speed
		If Abs(ball(i).dx)<0.068 Then ball(i).dx=0.0
		If Abs(ball(i).dy)<0.068 Then ball(i).dy=0.0
		' COLLISION CHECKS
		' Check each other ball (b) against current ball (i)
		For b=i To NUMBALLS
			' No need to check ball against itself
			If b=i Then Continue For
			' Get the distance between the 2 balls being checked
			actualDist=Sqr( ((ball(b).x-ball(i).x) ^ 2) + ((ball(b).y-ball(i).y) ^ 2) )
			' Collided? Check actual distance against ball diameter
			If actualDist<BALL_DIAMETER Then
				' Obtain the angle of ball (b) against ball (i)
				collisionNormalAngle=ATan2(ball(b).y-ball(i).y,ball(b).x-ball(i).x)
				' Position exact touch (no intersection)
				moveDist=(BALL_DIAMETER-actualDist)*0.5
				ball(i).x=ball(i).x+moveDist*Cos(collisionNormalAngle+180)
				ball(i).y=ball(i).y+moveDist*Sin(collisionNormalAngle+180)
				ball(b).x=ball(b).x+moveDist*Cos(collisionNormalAngle)
				ball(b).y=ball(b).y+moveDist*Sin(collisionNormalAngle)
				' COLLISION RESPONSE
				' n = vector connecting centres of balls
				'     Find components normalised vector
				nX=Cos(collisionNormalAngle)
				nY=Sin(collisionNormalAngle)
				' Find length of components movement vectors (via dot product)
				a1=ball(i).dx*nX + ball(i).dy*nY
				a2=ball(b).dx*nX + ball(b).dy*nY
				' Optimised = 2*(a1-a2)/(BallMass1+BallMass2)
				optimisedP=(2.0 * (a1-a2) ) / (BALL_MASS*2)
				' Find resultant vectors
				ball(i).dx=ball(i).dx-(optimisedP*BALL_MASS*nX)
				ball(i).dy=ball(i).dy-(optimisedP*BALL_MASS*nY)
				ball(b).dx=ball(b).dx+(optimisedP*BALL_MASS*nX)
				ball(b).dy=ball(b).dy+(optimisedP*BALL_MASS*nY)
			End If
		Next
		
		' Simple bounce off walls check
		' left and right
		If ball(i).x<(win2.WinXpos+20)+BALL_RADIUS Then
			ball(i).x=(win2.WinXpos+20)+BALL_RADIUS : ball(i).dx=ball(i).dx*-0.9
		End If
		If ball(i).x>(win2.WinXpos+win2.WinWidth-20)-BALL_RADIUS Then
			ball(i).x=(win2.WinXpos+win2.WinWidth-20)-BALL_RADIUS : ball(i).dx=ball(i).dx*-0.9
		End If
		'  up and down
		If ball(i).y<(win2.WinYpos+20)+BALL_RADIUS Then
			ball(i).y=(win2.WinYpos+20)+BALL_RADIUS : ball(i).dy=ball(i).dy*-0.9
		End If
		If ball(i).y>(win2.WinHeight-20)-BALL_RADIUS Then
			ball(i).y=(win2.WinHeight-20)-BALL_RADIUS : ball(i).dy=ball(i).dy*-0.9
		End If

	Next
End Sub


Function RangeRND(a As Integer, b As Integer) As Single
	Return (Rnd(1)*Abs(b-a))+a
End Function

' Return TRUE if any of the balls are moving
Function AreBallsMoving() As BOOL
	For obj As Integer=0 To NUMBALLS
		If ball(obj).dx<>0.0 OR ball(obj).dy<>0.0 Then Return TRUE 
	Next
	Return FALSE 
End Function

' Return a random float between -0.5 and +0.5
' Used to add a slight re-positioning of the balls
Function RNum() As Single
	Dim f As Single = RangeRND(-100,100)
	Return f/200.0
End Function






 ' ======================================== MAIN ===============================================


	' display / system setup
	Dim As Integer WinW,WinH
	Screenres 1280,600,32,2
	ScreenSet 1,0
	ScreenInfo WinW,WinH

	win1.WinXpos=0
	win1.WinYpos=0
	win1.WinWidth=(WinW/10)
	win1.WinHeight=WinH-1
	
	win2.WinXpos=(WinW/10)+1
	win2.WinYpos=0
	win2.WinWidth=(WinW-win2.WinXpos)-1
	win2.WinHeight=WinH-1
	
	Line(win1.WinXpos,win1.WinYpos)-(win1.WinWidth,win1.WinHeight),RGB(100,100,100),b
	Line(win2.WinXpos,win2.WinYpos)-step(win2.WinWidth,win2.WinHeight),RGB(150,150,150),b

	' table center
	centerX=win2.WinWidth/2
	centerY=win2.WinHeight/2
	
	' How many pottable balls in game (excluding cue ball)
	' NOTE: Use 3,6,10,15,21 ... (since the balls are placed in a triangle format)
	NUMBALLS=15
	
	' General physics settings
	FRICTION=0.981
	BALL_MASS=60.0
	BALL_RADIUS=win2.WinWidth/(NUMBALLS*3.0)
	BALL_DIAMETER=BALL_RADIUS*2.0

	' power bar position and dimensions
	powerBarX=10
	powerBarY=10
	powerBarWidth=win1.WinWidth-10-10
	powerBarHeight=win1.WinHeight-(128*2)

	' put Triangle of balls
	SetupTriangle()
	
	' setup our ball
	' note: inital position and power are random into a little range!!! (like real human use)
	SetupCueBall()
	
	ballsmoving=FALSE ' first time
	RenderPanel1()
	RenderPanel2()
	
   Dim As Integer win1_mouseX,win1_mouseY,win1_mouseB
   Dim As Integer win2_mouseX,win2_mouseY,win2_mouseB
   
	While inkey()<>chr(27)
		
	  if GetMouse(win1_mouseX,win1_mouseY)=0 then
	    If win1_mouseX>0 And win1_mouseY>0 Then 
	      If win1_mouseX<(WinW/10) Then
	        if GetMouse(win1_mouseX,win1_mouseY,,win1_mouseB)=0 then
	          If win1_mouseB And 1 Then panel1_Touch(win1_mouseX,win1_mouseY)
	        endif
	      Else
	        if GetMouse(win2_mouseX,win2_mouseY,,win2_mouseB)=0 then
	          If win2_mouseB And 1 Then panel2_Touch(win2_mouseX,win2_mouseY)
	        endif  
	      EndIf
	    EndIf
	  endif  
	  
	  Run_All()	
	  
	  Sleep 5 ' try this into 1-50 for example
	  
	Wend
Last edited by jepalza on Sep 28, 2022 10:43, edited 3 times in total.
D.J.Peters
Posts: 8575
Joined: May 28, 2005 3:28
Contact:

Re: Real snooker game with very effective physics

Post by D.J.Peters »

nice game :-)

Joshy

Here are a suggestion for your physics loops (the b for loop doesn't need to start with 0!)

Code: Select all

For i=0 To NUMBALLS
  ' MOVEMENT Update ball postion
  ' ...
  ' COLLISION CHECKS Check each other ball (b) against current ball (i)
  For b = i To NUMBALLS
   ' No need to check ball against itself
    If b=i Then Continue For
    '...
And a tip for the main loop. Allow [ESC] to quit the game and use getMouse() as function with error code !

Code: Select all

While inkey()<>chr(27)
  if GetMouse(win1_mouseX,win1_mouseY)=0 then
    If win1_mouseX>0 And win1_mouseY>0 Then 
      If win1_mouseX<(WinW/10) Then
        if GetMouse(win1_mouseX,win1_mouseY,,win1_mouseB)=0 then
          If win1_mouseB And 1 Then panel1_Touch(win1_mouseX,win1_mouseY)
        endif
      Else
        if GetMouse(win2_mouseX,win2_mouseY,,win2_mouseB)=0 then
          If win2_mouseB And 1 Then panel2_Touch(win2_mouseX,win2_mouseY)
        endif  
      EndIf
    EndIf
  endif  
  Run_All()	
  Sleep 5 ' try this into 1-50 for example
Wend
jepalza
Posts: 136
Joined: Feb 24, 2010 10:08
Location: Spain (Bilbao)

Re: Real snooker game with very effective physics

Post by jepalza »

Thanks. The code is intact, comes from the android version, without the "esc" key :D
My conversion is just for fun, converted in a few hours, without thinking about several things, but I want to improve with sound effects and score.
jepalza
Posts: 136
Joined: Feb 24, 2010 10:08
Location: Spain (Bilbao)

Re: Real snooker game with very effective physics

Post by jepalza »

Ok, now with effect sounds!!!
Using BASS library

It's not very refined yet, because the blow between the balls, the sounds are unbalanced. I don't know why it happens, but when there are only a few hits, the sound is accompanied.

Get it from my google drive:
https://drive.google.com/file/d/1C6f0Bv ... sp=sharing
Post Reply