Share My Creation Snooker / Billiards - Basic simulation

EDIT: v1.02 update. Tided up the code


Hi folks

A Snooker/Billards simulation for Basic4Android
This example is fully operational although there is no code to "pot" a ball
All you can do here is aim and shoot. Its enough to get you going though

INSTRUCTIONS
# Touch / Move finger on the table to position cue ball travel direction
# Slide the power bar to set the cue power
# Touch the lower/left white ball to shoot
# Use MENU option to reset ball layout

#Region Module Attributes
    #FullScreen: False
    #IncludeTitle: True
    #ApplicationLabel: SnookerSim
    #VersionCode: 1
    #VersionName: 1.02
    #SupportedOrientations: portrait
    #CanInstallToExternalStorage: False
#End Region

' 2D Snooker physics (basic simulation)- Jim Brown
' v1.02 - Added additional comments and relabelled variables
' Credits: Joseph Humfrey
' NOTE: Uses the "Phone" library (keep phone awake)

Sub Process_Globals
    Dim time As Timer
    Dim awake As PhoneWakeState
    Dim FRICTION  As Float        ' fiction of the balls
    Dim BALL_MASS  As Float        ' weight of the balls
    Dim BALL_RADIUS As Float    ' radius of the balls
    Dim BALL_DIAMETER As Float    ' diameter of the balls
    Dim NUMBALLS As Int            ' how many balls to control
    Dim mouseX,mouseY,cueAngle,cuePower As Float
    Dim ballsmoving As Boolean    ' flag to indicate whether or not any of the balls are moving
    Type balltype (x As Float, y As Float, dx As Float, dy As Float, color As Int)
    Dim ball(50) As balltype
End Sub

Sub Globals
    Dim centerX,centerY As Int    ' center of the snooker table display area (panel 2)
    Dim powerBarX,powerBarY,powerBarWidth,powerBarHeight As Int    ' power bar positions (panel 1)
    Dim count As Int
    ' display-related variables
    Dim pan1,pan2 As Panel
    Dim can1,can2 As Canvas
    Dim rec As Rect
End Sub

Sub Activity_Create(FirstTime As Boolean)
    ' display / system setup
    pan1.Initialize("panel1")    ' this panel will display the 'power bar' and 'take shot' ball
    pan2.Initialize("panel2")    ' this panel is the main snooker table area
    Activity.AddView(pan1,0%x,0%y,12%x,100%y)
    Activity.AddView(pan2,14%x,0%y,100%x-14%x,100%y)
    can1.Initialize(pan1) : can2.Initialize(pan2)
    centerX=pan2.Width/2 : centerY=pan2.Height/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=pan2.Width/(NUMBALLS*1.5)
    BALL_DIAMETER=BALL_RADIUS*2.0
    ' Timer
    time.Initialize("Timer1",12)
    ' Menus
    Activity.AddMenuItem("Reset","Menu_ResetTable")
    Activity.AddMenuItem("Exit","Menu_ExitGame")
    ' power bar position
    powerBarX=10 : powerBarY=pan1.Height-128 : powerBarWidth=pan1.Width-20 : powerBarHeight=pan1.Height/2.5
    '
    If FirstTime=True Then Menu_ResetTable_Click
End Sub

Sub Activity_Resume
    time.Enabled=True
    awake.KeepAlive(True)
End Sub

Sub Activity_Pause (UserClosed As Boolean)
    time.Enabled=False
    awake.ReleaseKeepAlive
End Sub

' user has touched Panel 1 (the left panel)
Sub panel1_Touch (Action As Int, X As Float, Y As Float)
    If ballsmoving=True Then Return
    ' check if touched point is over the 'power bar' indicator
    If Y>=powerBarY-powerBarHeight AND Y<=powerBarY Then
        If Y<powerBarY-powerBarHeight+8 Then Y=powerBarY-powerBarHeight+8
        If Y>powerBarY-16 Then Y=powerBarY-16
        cuePower=(powerBarY-Y)/8.0
        RenderPanel1
        Return
    End If
    ' check if touch point is over the 'take shot' ball
    If Y>=powerBarY+32 Then
        cueAngle=180.0-ATan2D(mouseX-ball(0).X,mouseY-ball(0).y)
        ball(0).dx=SinD(cueAngle)*cuePower : ball(0).dy=-CosD(cueAngle)*cuePower
        can1.DrawColor(Colors.Black) : pan1.Invalidate
        ballsmoving=True
    End If
End Sub

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

' Reset the table
Sub Menu_ResetTable_Click()
    SetupTriangle : SetupCueBall : ballsmoving=True
    RenderPanel1 : RenderPanel2
End Sub

Sub Menu_ExitGame_Click()
    Activity.Finish
End Sub

Sub Timer1_Tick
    count=count+1
    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
    rec.Initialize(powerBarX,powerBarY-powerBarHeight,powerBarX+powerBarWidth,powerBarY)
    can1.DrawRect(rec,Colors.Blue,True,0)
    rec.Initialize(powerBarX+5,powerBarY-(cuePower*8),powerBarX+powerBarWidth-6,powerBarY-8)
    can1.DrawRect(rec,Colors.White,True,0)
    ' take shot ball
    can1.DrawCircle(powerBarX+(powerBarWidth/2.0),powerBarY+64,pan1.Width/2-20,Colors.LightGray,True,0)
    can1.DrawCircle(powerBarX+(powerBarWidth/2.0),powerBarY+64,pan1.Width/2-26,Colors.White,True,0)
    pan1.Invalidate
End Sub

Sub RenderPanel2()
    can2.DrawColor(Colors.RGB(16,127,78))    ' erase the background with the given colour
    ' Draw each ball. Note that ball(0) is the cue ball
    For i=0 To NUMBALLS
        can2.DrawCircle(ball(i).x, ball(i).y, BALL_RADIUS, ball(i).color, True,0)
    Next
    ' Render the aiming line and circle (only when all balls have stopped moving)
    If ballsmoving=False Then
        can2.DrawLine(ball(0).x,ball(0).y,mouseX,mouseY,Colors.Black,4.0)
        can2.DrawCircle(mouseX,mouseY,BALL_RADIUS,Colors.Black,False,6.0)
    End If
    pan2.Invalidate
End Sub

' Arrange balls in a triangle formation
Sub SetupTriangle()
    Dim ballTriangleSize,i As Int
    i=0
    Do Until i>=NUMBALLS
        ballTriangleSize=ballTriangleSize+1
        i=i+ballTriangleSize
    Loop
    i=1
    For xloop=ballTriangleSize To 1 Step -1
        For yloop=1 To xloop
            ball(i).y=(5-xloop)*BALL_DIAMETER+120+RNum
            ball(i).x=(yloop*BALL_DIAMETER)-(xloop*BALL_DIAMETER)/2.0+(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=Colors.RGB(210,30,20)
            Else
                ball(i).color=Colors.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()
    ball(0).x=centerX+BALL_RADIUS+RNum
    ball(0).y=pan2.Height-BALL_RADIUS-Rnd(60,65)
    ball(0).dx=0.0 : ball(0).dy=0
    ball(0).color=Colors.White
    mouseX=centerX+BALL_RADIUS+Rnd(-10,10) : mouseY=pan2.Height/2.75 : cuePower=Rnd(70,80)
End Sub

Sub UpdatePhysics()
    Dim actualDist, collisionNormalAngle,moveDist As Float
    Dim nX,nY,a1,a2,optimisedP As Float
    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=0 To NUMBALLS
            ' No need to check ball against itself
            If b=i Then Continue
            ' Get the distance between the 2 balls being checked
            actualDist=Sqrt( Power(ball(b).x-ball(i).x,2) + Power(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=ATan2D(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*CosD(collisionNormalAngle+180)
                ball(i).y=ball(i).y+moveDist*SinD(collisionNormalAngle+180)
                ball(b).x=ball(b).x+moveDist*CosD(collisionNormalAngle)
                ball(b).y=ball(b).y+moveDist*SinD(collisionNormalAngle)
                ' COLLISION RESPONSE
                ' n = vector connecting centres of balls
                '     Find components normalised vector
                nX=CosD(collisionNormalAngle)
                nY=SinD(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
        If ball(i).x<BALL_RADIUS Then
            ball(i).x=BALL_RADIUS : ball(i).dx=ball(i).dx*-0.9
        End If
        If ball(i).x>pan2.Width-BALL_RADIUS Then
            ball(i).x=pan2.Width-BALL_RADIUS : ball(i).dx=ball(i).dx*-0.9
        End If
        If ball(i).y<BALL_RADIUS Then
            ball(i).y=BALL_RADIUS : ball(i).dy=ball(i).dy*-0.9
        End If
        If ball(i).y>pan2.Height-BALL_RADIUS Then
            ball(i).y=pan2.Height-BALL_RADIUS : ball(i).dy=ball(i).dy*-0.9
        End If
    Next
End Sub

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

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

 

[susu]

It looks great! Thank for your sharing

 

[bazp]

I am amazed how you controled the seperate balls. It will take a while to figure out your code. Manipulating the seperate objects must have been difficult. Good job! :sign0060:

 

[Jim Brown]

Updated code above. The implementation should be a little more battery-friendly now. That is, redrawing only happens when needed (rather than the 'every 12 ticks' method before)
This version uses two panels, one for the controls on the left (pan1) and the other for the main table (pan2)

 

[ZJP]

Nice one. :sign0060:

JP

 

[Beja]

Hi Jim, and thanks for sharing this smart project.
I tried to run it (AS IS) and got this message:

Parsing code. Error
Error parsing program.
Error description: Sub atan2d is not a valid identifier.

Please see the atached screenshot. when you first open the project, the variables are normal (not red), but
when you run it then you get the above error msg and the variables turn red.

p.s.
This is an old post, but I found it interesting and useful.

 

[Beja]

Any explanation appreciated..

thanks in advance.

 

[klaus]

You should simply remove the ATan2D routine and the program runs OK.
Jim wrote this program some ago and at that time the function ATan2D didn't exist as a keyword in B4A.
In the mean time Erel added ATan2D to the B4A language.

 

[Beja]

Thank you Klaus,
Will try to figure out how to number them from 1 to 15. (Billiards).