QB64 Phoenix Edition
Pool - Printable Version

+- QB64 Phoenix Edition (https://qb64phoenix.com/forum)
+-- Forum: QB64 Rising (https://qb64phoenix.com/forum/forumdisplay.php?fid=1)
+--- Forum: Prolific Programmers (https://qb64phoenix.com/forum/forumdisplay.php?fid=26)
+---- Forum: bplus (https://qb64phoenix.com/forum/forumdisplay.php?fid=36)
+---- Thread: Pool (/showthread.php?tid=178)

Pages: 1 2 3 4


Pool - bplus - 04-25-2022

Update: This thread in this little corner of Forum is for Pool apps or WIP. You are Welcome to share code and help others build their ideal Pool Game. I am big fan of Pool, played for years and it's not as fun playing alone. b = b + others  
________________________________________________________________________________________________

Pool 3.1 fixes

Code: (Select All)
Option _Explicit
_Title "Pool 3.1 fixes" ' b+ restart 2021-05-17
'QB64 version 2017 1106/82 (the day before they switched to version 1.2)
'translated from:
' pool table.bas SmallBASIC 0.12.9 (B+=MGA) 2017-09-06
' 2021-05-17 fix stuff start with Mouse constantly poll mouse and update shared mouse variables
' add ball collision code most recently worked out.
' Thanks to OldMoses for link to collision paper with vectors.
'     https://www.vobarian.com/collisions/2dcollisions2.pdf
'  The steps in the collision code follow directly from this paper

' bak 2021-05-18 version
' 2021-05-21 fix err with finding collisions
' 2021-05-22 it's not overlap that causes the hang, before drawing balls I inserted code to pull balls overlapping apart.
' The damn thing still hangs plus now get no ball action! and why does that happen?
' (Got to wait until balls stop moving before start pulling them apart, works good now!)
' 2021-05-23 Found the hang problem!!! fixed but left balls overlapping, fixed also!
' 2021-05-23 bak Pool 2 no overlap 2021-05-23
' 2021-05-23 Pool 3 make ball images bak 2021-05-23  added for uniform edges
' 2021-05-25 fix flicker, extend aiming line so can move cue ball angle and speed setting up or down that line
' for speed and not loose the precise angle needed at kiss point.
' 2021-05-25 gutted old aim cue ball and went back to circle at end of line and added a left and right arrow
' power setting, default at medium gets you across table, max power bust rack up nice!
' See power bar below the table orange line on white background. Press spacebar to shoot now.

Const xmax = 1280
Const ymax = 740
Screen _NewImage(xmax, ymax, 32)
_ScreenMove 80, 0

Randomize Timer
'balls
Const topBall = 15
Const BRad = 11 'ball radius 2.25"
Const BDia = BRad + BRad
'table
Const tl = 978 'table 100" for 9 foot table, adjust down for pixel ball radius
Const txo = (xmax - tl) * .5 'table x offset from left side of screen
Const tw = 489 'table 50" for 9 foot table, adjust down for pixel ball radius
Const tyo = (ymax - tw) \ 2 ' same border for 1280 wide screen
Const mt = txo + .5 * tl
'pockets
Const pw = 40 'pockey width less than 2 balls across
Const pr = 20
'rails
Const lr = txo
Const rr = txo + tl
Const tr = tyo
Const br = tyo + tw

'color
Const backColr = _RGB32(0, 94, 62)
Const bumperColr = _RGB32(10, 128, 60)
Type Ball
    As Double x, y
    As Double dx, dy, s ', z ' dx, dy = change x, y axis
    As _Unsigned Long colr
End Type
Dim Shared holeX(1 To 6), holeY(1 To 6)
Dim Shared b(topBall) As Ball, nf(topBall) As Ball
Dim Shared rack(topBall, 2)
Dim Shared BI(0 To topBall) As Long ' BallImages
Dim Shared mx, my, mb1DownX, mb1DownY, mb1UpX, mb1UpY, oldmb1 ' mouse event stuff
Dim Shared As Long TableImg
Dim Shared As Long scratch ' set in getting pocket list main, reset in BallInHand
Dim Shared As Long BallRemains ' still a ball not pocketed
Dim As Long i, j, saveJ, notDone
Dim As Double dist, minDist
Dim pocketed$ 'list balls that have been pocketed

Dim v1$, v2$, dv1$, dv2$, dv1u$, dv2u$, norm$, unitNorm$, unitTan$ 'vectors
Dim vp1n$, vp1t$, vp2n$, vp2t$ ' post collision vectors
Dim As Double v1n, v1t, v2n, v2t ' dot products
Dim As Double vp1n, vp1t, vp2n, vp2t ' post collision dot products
Dim As Double ai, aj, dxi, dyi, dxj, dyj

Dim pollTime
pollTime = _FreeTimer 'get a timer number from _FREETIMER ONLY!
On Timer(pollTime, .05) PollMouse
Timer(pollTime) On

' signal no button locations registered yet
mb1DownX = -1
mb1DownY = -1
mb1UpX = -1
mb1UpY = -1

MakeBalls
drawTable
restart:
eightBallRack
BallInHand
While 1
    If scratch Then BallInHand
    getCueBallAngle
    notDone = 1
    While notDone
        _PutImage , TableImg, 0
        CP 1, "Watch Ball Action!"
        notDone = 0
        For i = 0 To topBall ' draw balls then  update for next frame
            If b(i).x <> -1000 Then drawBall i
        Next
        CP 45, "Pocketed: " + pocketed$
        _Display
        _Limit 30
        For i = 0 To topBall
            minDist = 100000: saveJ = -1
            For j = 0 To topBall 'find deepest collision in case more than one we want earliest = deepest penetration
                If i <> j And b(i).x <> -1000 Then
                    dist = Sqr((b(i).x - b(j).x) * (b(i).x - b(j).x) + (b(i).y - b(j).y) * (b(i).y - b(j).y))
                    If dist < BDia Then ' collision but is it first or deepest collision
                        If dist < minDist Then minDist = dist: saveJ = j
                    End If
                End If
            Next
            If saveJ <> -1 Then ' found collision change ball i dx, dy   calc new course for ball i
                ''reflection  from circle  using Vectors  from JB, thanks tsh73
                v1$ = vect$(b(i).x, b(i).y) ' circle i
                v2$ = vect$(b(saveJ).x, b(saveJ).y) ' the other circle j
                dv1$ = vect$(b(i).dx, b(i).dy) ' change in velocity vector
                dv2$ = vect$(b(saveJ).dx, b(saveJ).dy)
                dv1u$ = vectUnit$(dv1$) '1 pixel
                dv2u$ = vectUnit$(dv2$)

                ' Here is the place where code hangs, make sure at least 1 vector has a decent length to change
                If vectLen(dv1u$) > .00001 Or vectLen(dv2u$) > .00001 Then
                    Do ' this should back up the balls to kiss point thanks tsh73
                        v1$ = vectSub$(v1$, dv1u$)
                        v2$ = vectSub(v2$, dv2u$)
                    Loop While vectLen(vectSub$(v1$, v2$)) < BDia 'back up our circle i to point on kiss
                End If

                ''now, get reflection speed
                ''radius to radius, norm is
                norm$ = vectSub$(v1$, v2$) ' this to this worked without all between from that collision paper
                '  step 1 unit norm and tangent
                unitNorm$ = vectUnit$(norm$)
                unitTan$ = vect$(-vectY(unitNorm$), vectX(unitNorm$))
                ' step 2 v$ and cv$ are 2 ball vectors (locations)  done already
                ' step 3 dot products before collision projecting onto normal and tangent vectors
                v1n = vectDotProduct(dv1$, unitNorm$)
                v1t = vectDotProduct(dv1$, unitTan$)
                v2n = vectDotProduct(dv2$, unitNorm$)
                v2t = vectDotProduct(dv2$, unitTan$)
                ' step 4 simplest  post collision dot products
                vp1t = v1t
                vp2t = v2t
                ' step 5  simplified by m = 1 for both balls just swap the numbers
                vp1n = v2n
                vp2n = v1n
                ' step 6  vp vectors mult the n, t numbers by unit vectors
                vp1n$ = vectScale$(vp1n, unitNorm$)
                vp1t$ = vectScale$(vp1t, unitTan$)
                vp2n$ = vectScale$(vp2n, unitNorm$)
                vp2t$ = vectScale$(vp2t, unitTan$)
                'step  7  add the 2 vectors n and t
                dv1$ = vectAdd$(vp1n$, vp1t$)

                ' store in next frame array
                nf(i).dx = vectX(dv1$)
                nf(i).dy = vectY(dv1$)
            Else ' no collision
                nf(i).dx = b(i).dx
                nf(i).dy = b(i).dy
            End If
            'update location of ball next frame
            If b(i).x <> -1000 Then
                nf(i).x = b(i).x + nf(i).dx
                nf(i).y = b(i).y + nf(i).dy
            Else
                nf(i).x = -1000: nf(i).y = -1000
            End If
            ' check in bounds next frame
            If nf(i).x <> -1000 Then
                If nf(i).x < lr + BRad Then
                    If nf(i).y > tr + 28 And nf(i).y < br - 28 Then
                        nf(i).dx = -nf(i).dx: nf(i).x = lr + BRad
                    Else
                        nf(i).x = -1000: nf(i).y = -1000: nf(i).dx = 0: nf(i).dy = 0: GoTo skip 'pocketed
                    End If
                End If

                If nf(i).x > rr - BRad Then
                    If nf(i).y > tr + 28 And nf(i).y < br - 28 Then
                        nf(i).dx = -nf(i).dx: nf(i).x = rr - BRad
                    Else
                        nf(i).x = -1000: nf(i).y = -1000: nf(i).dx = 0: nf(i).dy = 0: GoTo skip 'pocketed
                    End If
                End If

                If nf(i).y < tr + BRad Then
                    If (nf(i).x > lr + 28 And nf(i).x < mt - 40) Or (nf(i).x > mt + 40 And nf(i).x < rr - 28) Then
                        nf(i).dy = -nf(i).dy: nf(i).y = tr + BRad
                    Else
                        nf(i).x = -1000: nf(i).y = -1000: nf(i).dx = 0: nf(i).dy = 0: GoTo skip 'pocketed
                    End If
                End If

                If nf(i).y > br - BRad Then
                    If (nf(i).x > lr + 28 And nf(i).x < mt - 40) Or (nf(i).x > mt + 40 And nf(i).x < rr - 28) Then
                        nf(i).dy = -nf(i).dy: nf(i).y = br - BRad
                    Else
                        nf(i).x = -1000: nf(i).y = -1000: nf(i).dx = 0: nf(i).dy = 0: GoTo skip 'pocketed
                    End If
                End If
            End If
            skip:
        Next

        ''now that we've gone through all old locations update b() with nf() data
        pocketed$ = ""
        BallRemains = 0
        For i = 0 To topBall
            b(i).x = nf(i).x: b(i).y = nf(i).y
            b(i).dx = .99 * nf(i).dx: b(i).dy = .99 * nf(i).dy

            If b(i).dy * b(i).dy + b(i).dx * b(i).dx < .5 Then
                b(i).dx = 0: b(i).dy = 0
            Else
                notDone = 1
            End If
            If b(i).x = -1000 Then
                If i = 0 Then scratch = -1
                If Len(pocketed$) Then pocketed$ = pocketed$ + ", " + _Trim$(Str$(i)) Else pocketed$ = _Trim$(Str$(i))
            Else
                If i <> 0 Then BallRemains = -1
            End If
        Next
        If notDone = 0 Then 'separate overlapping balls now that they've stopped moving
            doAgain:
            For i = 1 To topBall 'separate overlapping balls
                If b(i).x <> -1000 Then
                    For j = i + 1 To topBall
                        If b(j).x <> -1000 Then
                            If Sqr((b(i).x - b(j).x) ^ 2 + (b(i).y - b(j).y) ^ 2) < BDia Then 'separate and start over
                                ai = _Atan2(b(i).y - b(j).y, b(i).x - b(j).x)
                                aj = _Atan2(b(j).y - b(i).y, b(j).x - b(i).x)
                                'update new dx, dy for i and j balls
                                dxi = Cos(ai)
                                dyi = Sin(ai)
                                dxj = Cos(aj)
                                dyj = Sin(aj)
                                b(i).x = b(i).x + dxi
                                b(i).y = b(i).y + dyi
                                b(j).x = b(j).x + dxj
                                b(j).y = b(j).y + dyj
                                GoTo doAgain:
                            End If
                        End If
                    Next
                End If
            Next
        End If

    Wend
    If BallRemains = 0 Then
        _PutImage , TableImg, 0
        CP 1, "Rack 'em!"
        _Display
        _Delay 1
        GoTo restart
    End If
Wend

Function rand% (lo%, hi%)
    rand% = Int(Rnd * (hi% - lo% + 1)) + lo%
End Function

Sub getCueBallAngle 'get speed too
    Dim As Long i, kh
    Dim As Double a, s
    _MouseHide
    s = 13
    _PutImage , TableImg, 0
    CP 1, "Set angle with mouse, set power with left or right arrows, shoot with spacebar."
    Line (txo, tyo + tw + 90)-(txo + tl, tyo + tw + 90 + 10), &HFFFFFFFF, BF
    For i = 0 To topBall
        drawBall i
    Next
    Dim temp As Long
    temp = _NewImage(_Width, _Height, 32)
    _PutImage , 0, temp
    Do
        _PutImage , temp, 0
        kh = _KeyHit
        If kh = 19712 Then 'right arrow move cx,cy down line
            s = s + 1
            If s > 26 Then s = 26
        End If
        If kh = 19200 Then 'left arrow move cx,cy down line
            s = s - 1
            If s < 1 Then s = 1
        End If
        ' angle line
        Line (b(0).x, b(0).y)-(mx, my), &HFFFFFFFF
        Circle (mx, my), BRad, &HFFFFFFFF
        ' power box
        Line (txo, tyo + tw + 90 + 2)-(txo + s * tl / 26, tyo + tw + 90 + 8), &HFFFF9900, BF
        _Display
        _Limit 200
    Loop Until kh = 32
    b(0).s = s
    a = _Atan2(my - b(0).y, mx - b(0).x)
    b(0).dx = b(0).s * Cos(a)
    b(0).dy = b(0).s * Sin(a)
    _MouseShow
    _FreeImage temp
End Sub

Sub BallInHand
    CP 1, "Ball 'in hand' behind table head line, click place for cue ball."
    Line (txo + .75 * tl, tyo)-(txo + .75 * tl, tyo + tw), bumperColr ' foul line
    _Display
    mb1DownX = -1 'reset to catch a down and a up
    mb1DownY = -1
    mb1UpX = -1
    mb1UpY = -1
    While mb1UpX = -1 'wait for click
    Wend
    b(0).x = mx: b(0).y = my ' assign cue ball
    drawBall 0
    scratch = 0
    _Display
End Sub

Sub eightBallRack
    Dim As Double xoff, yoff, spacer, i, b, xx, yy, rndB, saveI
    xoff = txo + .25 * tl
    yoff = tyo + .5 * tw
    spacer = BRad * 2 '
    b = 1
    For xx = 0 To 4
        For yy = 0 To xx
            b(b).x = xoff - spacer * (xx)
            b(b).y = yoff - .5 * spacer * xx + yy * spacer
            rack(b, 0) = b(b).x: rack(b, 1) = b(b).y
            b = b + 1
        Next
    Next
    Dim shuff(topBall)
    For i = 1 To topBall
        shuff(i) = i
    Next
    For i = topBall To 2 Step -1
        rndB = rand(1, i)
        Swap shuff(i), shuff(rndB)
    Next
    For i = 1 To topBall
        If shuff(i) = 8 Then saveI = i
        'b(i).z = _R2D(Rnd * 2 * _Pi)
    Next
    Swap shuff(saveI), shuff(5)
    For i = 1 To topBall
        b(shuff(i)).x = rack(i, 0)
        b(shuff(i)).y = rack(i, 1)
        drawBall shuff(i)
    Next
    _Display
End Sub

Sub drawTable
    Dim As _Unsigned Long feltColr
    Dim As Long i, j
    Dim As Double tl8

    feltColr = _RGB32(0, 118, 50)
    holeX(1) = txo - BRad: holeY(1) = tyo - BRad
    holeX(2) = txo + tw: holeY(2) = tyo + -1.5 * BRad
    holeX(3) = txo + tl + BRad: holeY(3) = tyo - BRad
    holeX(4) = txo - BRad: holeY(4) = tyo + tw + BRad
    holeX(5) = txo + tw: holeY(5) = tyo + tw + 1.5 * BRad
    holeX(6) = txo + tl + BRad: holeY(6) = tyo + tw + BRad
    TableImg = _NewImage(_Width, _Height, 32)
    Color &HFF000088, backColr
    Cls
    For i = 60 To 1 Step -1
        Line (txo - i, tyo - i)-(rr + i, br + i), _RGB32(100 - .9 * i, 55 - .7 * i, 50 - .5 * i), BF
    Next
    Line (txo - BRad, tyo - BRad)-(rr + BRad, br + BRad), bumperColr, BF
    Color feltColr
    Line (txo, tyo)-(rr, br), feltColr, BF
    tLine holeX(1), holeY(1), holeX(5), holeY(5), pw - 1 'drill pockets into wood
    tLine holeX(2), holeY(2), holeX(4), holeY(4), pw - 1
    tLine holeX(2), holeY(2), holeX(6), holeY(6), pw - 1
    tLine holeX(5), holeY(5), holeX(3), holeY(3), pw - 1
    tl8 = tl / 8
    Color &HFFFFFFFF
    For i = 1 To 7
        fcirc txo + i * tl8, tyo - 30, 3
        fcirc txo + i * tl8, tyo + tw + 30, 3
    Next
    For i = 1 To 3
        fcirc txo - 30, tyo + i * tl8, 3
        fcirc txo + tl + 30, tyo + i * tl8, 3
    Next
    For i = 1 To 6
        Color &HFF000000
        If i <> 2 And i <> 5 Then
            For j = 0 To 7
                Select Case i ' move hole to last location
                    Case 1: fcirc holeX(i) + j, holeY(i) + j, 20
                    Case 3: fcirc holeX(i) - j, holeY(i) + j, 20
                    Case 4: fcirc holeX(i) + j, holeY(i) - j, 20
                    Case 6: fcirc holeX(i) - j, holeY(i) - j, 20
                End Select
            Next
        Else
            fcirc holeX(i), holeY(i), 20
        End If
    Next
    'move corner holes
    holeX(1) = holeX(1) + 7: holeY(1) = holeY(1) + 7
    holeX(3) = holeX(3) - 7: holeY(1) = holeY(3) + 7
    holeX(4) = holeX(4) + 7: holeY(1) = holeY(4) - 7
    holeX(6) = holeX(6) - 7: holeY(1) = holeY(6) - 7
    'aiming diamond
    _Display
    _PutImage , 0, TableImg
End Sub

Sub tLine (x1, y1, x2, y2, rThick)
    Dim stepx, stepy, dx, dy
    Dim As Long length, i
    'x1, y1 is one endpoint of line
    'x2, y2 is the other endpoint of the line
    'rThick is the radius of the tiny circles that will be drawn
    '   from one end point to the other to create the thick line
    'Yes, the line will then extend beyond the endpoints with circular ends.
    'local length, stepx, stepy, dx, dy, i
    rThick = Int(rThick / 2): stepx = x2 - x1: stepy = y2 - y1
    length = Int((stepx ^ 2 + stepy ^ 2) ^ .5)
    If length Then
        dx = stepx / length: dy = stepy / length
        For i = 0 To length
            fcirc x1 + dx * i, y1 + dy * i, rThick
        Next
    Else
        fcirc x1, y1, rThick
    End If
End Sub

Sub drawBall (idx)
    _PutImage (b(idx).x - BRad, b(idx).y - BRad)-Step(BDia, BDia), BI(idx), 0
End Sub

Sub MakeBalls 'image
    Dim As Integer r, g, b
    Dim As Long i, x1, y1, x2, y2
    Dim ra
    For i = 0 To topBall
        BI(i) = _NewImage(BRad * 2 + 2, BRad * 2 + 2, 32)
        Select Case i
            Case 0: r = 255: g = 255: b = 255
            Case 1, 9: r = 255: g = 255: b = 0
            Case 2, 10: r = 0: g = 0: b = 255
            Case 3, 11: r = 180: g = 0: b = 0
            Case 4, 12: r = 60: g = 60: b = 140
            Case 5, 13: r = 255: g = 120: b = 0
            Case 6, 14: r = 0: g = 100: b = 0
            Case 7, 15: r = 180: g = 0: b = 100
            Case 8: r = 40: g = 40: b = 40
        End Select
        'For rad = BRad To 0 Step -1
        If i < 9 Then
            Color _RGB32(r, g, b)
            fcirc BRad + 1, BRad + 1, BRad
        Else
            Color _RGB32(235, 235, 235)
            fcirc BRad + 1, BRad + 1, BRad
        End If
        Circle (BRad + 1, BRad + 1), BRad, _RGB32(200, 200, 200)
        'Next

        If i > 8 Then
            ra = Int(Rnd * 360)

            x1 = BRad + 1 + BRad * Cos(_D2R(ra + 20)): y1 = BRad + 1 + BRad * Sin(_D2R(ra + 20))
            x2 = BRad + 1 + BRad * Cos(_D2R(ra + 180 - 20)): y2 = BRad + 1 + BRad * Sin(_D2R(ra + 180 - 20))
            Line (x1, y1)-(x2, y2), _RGB32(200, 200, 200)
            x1 = BRad + 1 + BRad * Cos(_D2R(ra - 20)): y1 = BRad + 1 + BRad * Sin(_D2R(ra - 20))
            x2 = BRad + 1 + BRad * Cos(_D2R(ra + 180 + 20)): y2 = BRad + 1 + BRad * Sin(_D2R(ra + 180 + 20))
            Line (x1, y1)-(x2, y2), _RGB32(200, 200, 200)

            Paint (BRad + 1, BRad + 1), _RGB32(r, g, b), _RGB32(200, 200, 200)
        End If
        _PutImage , 0, BI(i), (1, 1)-Step(BDia, BDia)
    Next
End Sub

Sub CP (lineNumber, mess$)
    Dim As Long ttw, tth
    ttw = 8: tth = 16
    Line (0, tth * lineNumber)-(xmax, tth * lineNumber + tth), backColr, BF
    Color _RGB32(255, 255, 255), _RGB32(0, 94, 62)
    _PrintString ((xmax - ttw * Len(mess$)) / 2, tth * lineNumber), mess$
    '_Display
End Sub

'Steve McNeil's  copied from his forum   note: Radius is too common a name
Sub fcirc (CX As Long, CY As Long, R As Long)
    Dim subRadius As Long, RadiusError As Long
    Dim X As Long, Y As Long

    subRadius = Abs(R)
    RadiusError = -subRadius
    X = subRadius
    Y = 0

    If subRadius = 0 Then PSet (CX, CY): Exit Sub

    ' Draw the middle span here so we don't draw it twice in the main loop,
    ' which would be a problem with blending turned on.
    Line (CX - X, CY)-(CX + X, CY), , BF

    While X > Y
        RadiusError = RadiusError + Y * 2 + 1
        If RadiusError >= 0 Then
            If X <> Y + 1 Then
                Line (CX - Y, CY - X)-(CX + Y, CY - X), , BF
                Line (CX - Y, CY + X)-(CX + Y, CY + X), , BF
            End If
            X = X - 1
            RadiusError = RadiusError - X * 2
        End If
        Y = Y + 1
        Line (CX - X, CY - Y)-(CX + X, CY - Y), , BF
        Line (CX - X, CY + Y)-(CX + X, CY + Y), , BF
    Wend
End Sub

Sub PollMouse ' catch locations of mouse button 1 down and up
    Dim As Long mb1
    While _MouseInput: Wend
    mx = _MouseX: my = _MouseY: mb1 = _MouseButton(1)
    If mb1 And oldmb1 = 0 Then
        mb1DownX = mx
        mb1DownY = my
    End If
    If mb1 = 0 And oldmb1 Then
        mb1UpX = mx
        mb1UpY = my
    End If
    oldmb1 = mb1
End Sub

Function vect$ (x, y) ' convert x, y to string for passing vectors with Functions
    vect$ = _Trim$(Str$(x)) + "," + _Trim$(Str$(y))
End Function

Function vectX# (v$)
    vectX# = Val(LeftOf$(v$, ","))
End Function

Function vectY# (v$)
    vectY# = Val(RightOf$(v$, ","))
End Function

Function vectLen# (v$)
    Dim As Double x, y
    x = Val(LeftOf$(v$, ","))
    y = Val(RightOf$(v$, ","))
    vectLen# = Sqr(x * x + y * y)
End Function

Function vectUnit$ (v$) ' fix possible 0 that might hang
    Dim As Double x, y, vl
    x = Val(LeftOf$(v$, ","))
    y = Val(RightOf$(v$, ","))
    vl = Sqr(x * x + y * y)
    If vl <> 0 Then vectUnit$ = vect$(x / vl, y / vl) Else vectUnit$ = vect$(x, y)
End Function

Function vectAdd$ (v1$, v2$)
    Dim As Double x1, y1, x2, y2
    x1 = Val(LeftOf$(v1$, ","))
    y1 = Val(RightOf$(v1$, ","))
    x2 = Val(LeftOf$(v2$, ","))
    y2 = Val(RightOf$(v2$, ","))
    vectAdd$ = vect$(x1 + x2, y1 + y2)
End Function

Function vectSub$ (v1$, v2$)
    Dim As Double x1, y1, x2, y2
    x1 = Val(LeftOf$(v1$, ","))
    y1 = Val(RightOf$(v1$, ","))
    x2 = Val(LeftOf$(v2$, ","))
    y2 = Val(RightOf$(v2$, ","))
    vectSub$ = vect$(x1 - x2, y1 - y2)
End Function

Function vectDotProduct# (v1$, v2$)
    Dim As Double x1, y1, x2, y2
    x1 = Val(LeftOf$(v1$, ","))
    y1 = Val(RightOf$(v1$, ","))
    x2 = Val(LeftOf$(v2$, ","))
    y2 = Val(RightOf$(v2$, ","))
    vectDotProduct# = x1 * x2 + y1 * y2
End Function

Function vectScale$ (a, v$) 'a * vector v$
    Dim As Double x, y
    x = Val(LeftOf$(v$, ","))
    y = Val(RightOf$(v$, ","))
    vectScale$ = vect$(a * x, a * y)
End Function

Function vectTangent$ (v$, base$)
    Dim n$
    n$ = vectUnit$(base$)
    vectTangent$ = vectScale$(vectDotProduct(n$, v$), n$)
End Function

Function vectNorm$ (v$, base$)
    vectNorm$ = vectSub$(v$, vectTangent$(v$, base$))
End Function

' update these 2 in case of$ is not found! 2021-02-13
Function LeftOf$ (source$, of$)
    If InStr(source$, of$) > 0 Then LeftOf$ = Mid$(source$, 1, InStr(source$, of$) - 1) Else LeftOf$ = source$
End Function

' update these 2 in case of$ is not found! 2021-02-13
Function RightOf$ (source$, of$)
    If InStr(source$, of$) > 0 Then RightOf$ = Mid$(source$, InStr(source$, of$) + Len(of$)) Else RightOf$ = ""
End Function

For Dimster and again thanks to OldMoses for pointing to a paper upon which collision code here is based.


RE: Pool - Dimster - 04-26-2022

Hey, thanks Mr. Plus


RE: Pool - vince - 04-27-2022

Nice, you should post air hockey soon


RE: Pool - bplus - 04-27-2022

Thanks, I am wondering when the other guys are going to peter out.
(That's a term from mid 1800's about mining.)

I checked out TheBob's PPong and nothing like Air Hockey, so sure!


RE: Pool - OldMoses - 11-02-2022

OK, I think I've finally got something worth sharing. It's still a bit bare bones, but the major hurdles are past. It's mostly just a matter of prettying it up.

Control:
Left mouse button spots the cueball. Once a number appears in the cueball, set the stroke power with the mouse wheel. Positive power (roll back) is for mouse behind the cueball while negative power (roll forward) is for mouse ahead of the cueball. This should minimize screen constraints for fine aiming. The blue dashed line will be the cueballs travel path. A ghost aiming ball will appear against the object balls as the path intersects them.

Pressing the third button mousewheel (if equipped) will set max stroke of 50/-50 (whichever sign is present)

Pressing the right button re-racks the table, first opening a dialog for confirmation, in case the button press was accidental.

Present issues:
Full power shots, particularly near a bumper, can often hurl balls off the table and into mathematical oblivion. If that ball is the cueball a re-rack will be necessary. I'll be working on retrieval code for re-spotting such balls. Occasionally, an otherwise good pocketing will leave the table.

Code: (Select All)
$COLOR:32
'$CONSOLE
_DISPLAYORDER _HARDWARE , _SOFTWARE

TYPE V2
    x AS SINGLE
    y AS SINGLE
END TYPE

TYPE ball
    sunk AS _BYTE '                                             has ball been sunk true/false
    c AS _UNSIGNED LONG '                                       ball color
    p AS V2 '                                                   position vector
    d AS V2 '                                                   direction vector
    n AS V2 '                                                   normalized direction vector
    r AS _BYTE '                                                rack position
END TYPE

TYPE hole '                                                     pockets
    p AS V2 '                                                   position
    r AS INTEGER '                                              radius
END TYPE

TYPE Bump '                                                     bumper vectors
    v AS V2
    n AS V2
    s AS V2
    e AS V2
    m AS V2
    l AS SINGLE
END TYPE


DIM SHARED xtable AS INTEGER '                                  x & y limits of screen/table
DIM SHARED ytable AS INTEGER
DIM SHARED xt5 AS INTEGER '                                     table border depth (5% of xtable)
DIM SHARED bsiz AS INTEGER '                                    radius of ball
DIM SHARED bsiz2 AS INTEGER '                                   ball diameter or sphere of contact
DIM SHARED bmpthk AS INTEGER '                                  bumper thickness
DIM SHARED bl(15) AS ball '                                     ball data
DIM SHARED hl(5) AS hole '                                      pockets (6)
DIM SHARED bmp(18) AS Bump '                                    bumper vectors
DIM SHARED bnum(15) AS LONG '                                   ball image handles
DIM SHARED tbl AS LONG '                                        table image handle
DIM SHARED origin AS V2 '                                       zero vector
DIM AS V2 path, pst
DIM maxstrk AS INTEGER
origin.x = 0: origin.y = 0
maxstrk = 50
scratch = -1

'Set the table size
IF _DESKTOPWIDTH > _DESKTOPHEIGHT * 1.6 THEN
    xtable = _DESKTOPWIDTH - 100: ytable = xtable / 2
ELSE
    ytable = _DESKTOPHEIGHT - 80: xtable = ytable * 2
END IF

bsiz = INT(((xtable / 118.1102) * 2.375) / 2) '                 size balls to table (radius)
bmpthk = INT(bsiz * 1.25) '                                     bumper 5/8 of ball diameter
bsiz2 = bsiz * 2 '                                              ball diameter/2 ball contact surface
xt5 = xtable * .05 '                                            5% setback of play surface from display

RANDOMIZE TIMER
RESTORE hue
FOR x = 0 TO 15 '                                               get ball main colors
    READ bl(x).c
NEXT x

_TITLE "OldMoses' Hustle"
SCREEN _NEWIMAGE(xtable, ytable, 32)
DO: LOOP UNTIL _SCREENEXISTS
MakeTable
Bump_Vectors
Pockets
MakeBalls
RackEmUp
bl(0).p.y = INT(ytable * .75) '                                  position the cue
bl(0).p.x = INT(xtable * .75)

_SCREENMOVE 5, 5

DO
    CLS , &H00000000 '                                          Thanks to Gets for this solution to the hardware overlay bug
    _PUTIMAGE , tbl '                                           overlay table
    'Draw_Vecs '                                                 checking vector form and position
    FOR x% = 0 TO 15 '                                          overlay balls
        'if ball leaves table
        'if cue
        '   scratch
        'else
        '   spot ball code
        'end if
        'end if
        IF bl(x%).sunk THEN
            IF x% = 0 THEN '                                    scratched the cueball
                scratch = -1
                bl(0).sunk = 0 '                                re-spot the cueball
                bl(0).d.x = 0
                bl(0).d.y = 0
            ELSE
                bl(x%).d.x = 0
                bl(x%).d.y = 0
                _PUTIMAGE (x% * bsiz2, ytable - bsiz2 - 5), bnum(x%) 'place sunk ball in tray
                _CONTINUE '                                     ball already off the table
            END IF
        END IF
        R2_Add bl(x%).p, bl(x%).d, 1 '                          Move the ball
        R2_Mult bl(x%).d, .995 '                                 Apply some rolling friction
        IF PyT(origin, bl(x%).d) < .1 THEN bl(x%).d = origin ' stop infinite creep of slowing balls
        ColCheck x%
        IF scratch AND x% = 0 THEN _CONTINUE
        _PUTIMAGE (INT(bl(x%).p.x) - _SHR(CINT(_WIDTH(bnum(x%))), 1), INT(bl(x%).p.y) - _SHR(CINT(_HEIGHT(bnum(x%))), 1)), bnum(x%)
    NEXT x%

    ms = MBS%
    IF ms AND 1 THEN
        ClearMB 1
        IF scratch THEN '                                       left click cue ball placing code
            IF NOT StillMoving THEN
                bl(0).p.x = Limit%(MinOf%(_MOUSEX, INT(xtable * .75)), xtable - xt5)
                bl(0).p.y = Limit%(MinOf%(_MOUSEY, xt5), ytable - xt5)
                scratch = NOT scratch
            END IF
        ELSE '                                                  shoot the cueball
            IF (origin.x = bl(0).d.x) AND (origin.y = bl(0).d.y) THEN
                bl(0).d.x = bl(0).p.x - _MOUSEX '                   get the cue strike vector
                bl(0).d.y = bl(0).p.y - _MOUSEY
                R2_Norm bl(0).d, bl(0).d, su
                DO UNTIL NOT _MOUSEBUTTON(1) '                      prevents cue thrusting,
                    WHILE _MOUSEINPUT: WEND '                       i.e. constant acceleration across table
                LOOP '                                              while holding down mouse button
                su = 0 '                                            reset strike units
            END IF
        END IF
    END IF
    IF ms AND 2 THEN '                                          if mouse right button reset the rack
        ClearMB 2
        Dialog_Box "Are you sure you wish to re-rack? Y/N", 350, 200, 200, Red, White
        _DISPLAY
        IF Key_In%(32, ytable / 2 - 16, 250, "", "YN") = 1 THEN
            scratch = -1
            BallStop '                                              all displacements to = origin
            bl(0).p.y = INT(ytable * .5)
            bl(0).p.x = INT(xtable * .75)
            RackEmUp
        END IF
    END IF
    IF ms AND 4 THEN '                                          if mouse center button, set full strike
        ClearMB 3
        IF ABS(su) <> ABS(maxstrk) THEN
            su = SGN(su) * maxstrk
        ELSE
            su = -su
        END IF
    END IF
    IF ms AND 512 THEN '                                        roll mousewheel back, accelerate away from mouse cursor
        su = Limit%(maxstrk, su + 1) '                               like pulling back a pinball spring
    END IF
    IF ms AND 1024 THEN '                                       roll mousewheel frw'd, accelerate towards mouse cursor
        su = su + 1 * (su > -maxstrk) '                              helpful in aiming from table edge
    END IF

    IF NOT StillMoving THEN '                                   AIMING BLOCK WHEN ALL STOPPED
        IF scratch THEN
            Xscr% = Limit%(MinOf%(_MOUSEX, INT(xtable * .75)), xtable - xt5)
            Yscr% = Limit%(MinOf%(_MOUSEY, xt5), ytable - xt5)
            _PUTIMAGE (Xscr% - _SHR(CINT(_WIDTH(bnum(0))), 1), Yscr% - _SHR(CINT(_HEIGHT(bnum(0))), 1)), bnum(0)
        ELSE
            outcol& = Blue
            incol& = White
            path.x = CINT(bl(0).p.x) - _MOUSEX
            path.y = CINT(bl(0).p.y) - _MOUSEY
            R2_Norm path, path, SGN(su) '                           set path direction, mouse relative
            in% = 0: u% = 0 '                                       reset loop controls
            DO
                u% = u% + 1 '                                       increment unit vector multiplier
                pst = bl(0).p '                                     start pst at cue
                R2_Norm path, path, u% '                            grow path vector * u%
                R2_Add pst, path, 1 '                               Add (path * u%) to pst
                FOR x% = 1 TO 15 '                                  iterate through balls
                    IF bl(x%).sunk THEN _CONTINUE
                    IF PyT(bl(x%).p, pst) <= bsiz2 THEN
                        CIRCLE (pst.x, pst.y), bsiz '               place target ghost
                        in% = -1: EXIT FOR
                    END IF
                NEXT x%
            LOOP UNTIL in% OR u% > xtable '                         loop until ghost placed or beyond table
            R2_Norm path, path, 1000
            LINE (CINT(bl(0).p.x), CINT(bl(0).p.y))-(CINT(bl(0).p.x) - path.x, CINT(bl(0).p.y) - path.y), incol& 'cue line
            LINE (CINT(bl(0).p.x), CINT(bl(0).p.y))-(CINT(bl(0).p.x) + path.x, CINT(bl(0).p.y) + path.y), outcol&, , &HF0F0 'path line

            _PRINTSTRING (bl(0).p.x - 8, bl(0).p.y - 8), STR$(su)
        END IF
    END IF
    _DISPLAY
    _LIMIT 100
LOOP UNTIL _KEYDOWN(27)

END

'                                                               DATA SECTION
hue:
DATA 4294967295,4294967040,4278190335,4294901760,4286578816,4294944000,4278222848,4286578688
DATA 4278190080,4294967040,4278190335,4294901760,4286578816,4294944000,4278222848,4286578688

start:
DATA 1,2,15,14,8,3,4,6,11,13,12,7,9,10,5,0

'²²²²²²²²Handles collision geometry of two moving balls²²²²²²²²²
SUB B2BCollision (ball1 AS ball, ball2 AS ball)
    DIM AS V2 un, ut, ncomp1, ncomp2, tcomp1, tcomp2
    P2V un, ball1.p, ball2.p: R2_Norm un, un, 1 '               establish unit normal
    Ortho_Norm ut, un '                                         establish unit tangent
    R2_Norm ncomp1, un, R2_Dot(un, ball2.d) '                   normal component/exit vector/ball1
    R2_Norm tcomp1, ut, R2_Dot(ut, ball1.d) '                   tangent component/exit vector/ball1
    R2_Norm ncomp2, un, R2_Dot(un, ball1.d) '                   normal component/exit vector/ball2
    R2_Norm tcomp2, ut, R2_Dot(ut, ball2.d) '                   tangent component/exit vector/ball2
    ball1.d = ncomp1: R2_Add ball1.d, tcomp1, 1 '               add normal and tangent exit vectors/ball1
    ball2.d = ncomp2: R2_Add ball2.d, tcomp2, 1 '               add normal and tangent exit vectors/ball2
    R2_Mult ball1.d, .95 '                                      let's take 5% of energy in entropic factors
    R2_Mult ball2.d, .95
END SUB 'B2BCollision

'²²²²²²²²Cease all ball motion for rerack²²²²²²²²²²²²²²²²²²²²²²²
SUB BallStop
    FOR x = 0 TO 15
        bl(x).d = origin
    NEXT x
END SUB 'BallStop

'²²²²²²²²Create bumper vector dimensions²²²²²²²²²²²²²²²²²²²²²²²²
SUB Bump_Vectors
    '18 bumper vectors 6 straight wall and 12 pocket angles
    ball_cf% = _SHL(bsiz2, 1) / 1.415 '                         ball corner pocket size factor
    ball_sf% = bsiz2 * 1.14 '                                   ball side pocket size factor
    b_eg% = ytable - xt5 '                                      bottom edge
    t_eg% = xt5 '                                               top edge
    l_eg% = xt5 '                                               left edge
    r_eg% = xtable - xt5 '                                      right edge
    c_ln% = _SHR(xtable, 1) '                                   width center line
    elng% = b_eg% - t_eg% - 2 * ball_cf% '                      end wall length
    slng% = (r_eg% - l_eg% - 2 * ball_sf% - 2 * ball_cf%) / 2 ' side wall length
    RESTORE bmp_vectors
    FOR l2r% = 0 TO 5
        FOR vwv% = 0 TO 2
            vnum% = (l2r% * 3) + vwv%
            READ bmp(vnum%).v.x
            READ bmp(vnum%).v.y
            R2_Norm bmp(vnum%).v, bmp(vnum%).v, 1 '             normalize bumper vector
            Ortho_Norm bmp(vnum%).n, bmp(vnum%).v '             get orthogonal
            SELECT CASE vnum% MOD 3
                CASE 0 '                                        start pocket bevel vector
                    SELECT CASE l2r% MOD 6
                        CASE 0 'left end start
                            R2_Norm bmp(vnum%).v, bmp(vnum%).v, -bmpthk * 1.415: bmp(vnum%).l = Mag(bmp(vnum%).v)
                            bmp(vnum%).s.x = l_eg% + bmp(vnum%).v.x: bmp(vnum%).s.y = b_eg% - ball_cf% + bmp(vnum%).v.y
                        CASE 1 'top left start
                            R2_Norm bmp(vnum%).v, bmp(vnum%).v, -bmpthk * 1.415: bmp(vnum%).l = Mag(bmp(vnum%).v)
                            bmp(vnum%).s.x = l_eg% + ball_cf% + bmp(vnum%).v.x: bmp(vnum%).s.y = t_eg% + bmp(vnum%).v.y
                        CASE 2 'top right start
                            R2_Norm bmp(vnum%).v, bmp(vnum%).v, -bmpthk * 1.118: bmp(vnum%).l = Mag(bmp(vnum%).v)
                            bmp(vnum%).s.x = c_ln% + ball_sf% + bmp(vnum%).v.x: bmp(vnum%).s.y = t_eg% + bmp(vnum%).v.y
                        CASE 3 'right end start
                            R2_Norm bmp(vnum%).v, bmp(vnum%).v, -bmpthk * 1.415: bmp(vnum%).l = Mag(bmp(vnum%).v)
                            bmp(vnum%).s.x = r_eg% + bmp(vnum%).v.x: bmp(vnum%).s.y = t_eg% + ball_cf% + bmp(vnum%).v.y
                        CASE 4 'bottom right start
                            R2_Norm bmp(vnum%).v, bmp(vnum%).v, -bmpthk * 1.415: bmp(vnum%).l = Mag(bmp(vnum%).v)
                            bmp(vnum%).s.x = r_eg% - ball_cf% + bmp(vnum%).v.x: bmp(vnum%).s.y = b_eg% + bmp(vnum%).v.y
                        CASE 5 'bottom left start
                            R2_Norm bmp(vnum%).v, bmp(vnum%).v, -bmpthk * 1.118: bmp(vnum%).l = Mag(bmp(vnum%).v)
                            bmp(vnum%).s.x = c_ln% - ball_sf% + bmp(vnum%).v.x: bmp(vnum%).s.y = b_eg% + bmp(vnum%).v.y
                    END SELECT
                    R2_Mult bmp(vnum%).v, -1 '    invert again after finished
                    bmp(vnum%).e = bmp(vnum%).s: R2_Add bmp(vnum%).e, bmp(vnum%).v, 1
                CASE 1 '                                        straight wall vector
                    SELECT CASE l2r% MOD 6
                        CASE 0, 3: lng% = elng%
                        CASE ELSE: lng% = slng%
                    END SELECT
                    bmp(vnum%).l = lng%
                    bmp(vnum%).s.x = bmp(vnum% - 1).e.x: bmp(vnum%).s.y = bmp(vnum% - 1).e.y
                    bmp(vnum%).e = bmp(vnum%).s: R2_Add bmp(vnum%).e, bmp(vnum%).v, lng%
                CASE 2 '                                        end pocket vector
                    SELECT CASE l2r% MOD 6
                        CASE 1, 4: R2_Norm bmp(vnum%).v, bmp(vnum%).v, bmpthk * 1.118
                        CASE ELSE: R2_Norm bmp(vnum%).v, bmp(vnum%).v, bmpthk * 1.415
                    END SELECT
                    bmp(vnum%).l = Mag(bmp(vnum%).v)
                    bmp(vnum%).s = bmp(vnum% - 1).e
                    bmp(vnum%).e = bmp(vnum%).s: R2_Add bmp(vnum%).e, bmp(vnum%).v, 1
                    R2_Mult bmp(vnum%).v, 1
            END SELECT
        NEXT vwv%
    NEXT l2r%
    bmp_vectors: 'R2 direction vectors for: leading pocket bevel-straight-trailing pocket bevel
    '             corner pockets have 45 degree bevels, side pockets have 60 degree bevels
    DATA 1,-1,0,-1,-1,-1: 'left wall
    DATA 1,1,1,0,1,-2: 'top left wall
    DATA 1,2,1,0,1,-1: 'top right wall
    DATA -1,1,0,1,1,1: 'right wall
    DATA -1,-1,-1,0,-1,2: 'bottom right wall
    DATA -1,-2,-1,0,-1,1: 'bottom left wall
END SUB 'Bump_Vectors

'²²²²²²²²Clear mousebutton input queue²²²²²²²²²²²²²²²²²²²²²²²²²²
SUB ClearMB (var AS INTEGER)
    DO
        WHILE _MOUSEINPUT: WEND
    LOOP UNTIL NOT _MOUSEBUTTON(var)
END SUB 'ClearMB

'²²²²²²²²Ball, Bumper and pocket intersections²²²²²²²²²²²²²²²²²²
SUB ColCheck (var AS INTEGER)
    DIM reflec AS V2
    'check for ball in displacement radius
    disp = _HYPOT(bl(var).d.x, bl(var).d.y)
    FOR x = 0 TO 15 '
        IF x = var THEN _CONTINUE
        IF bl(x).sunk THEN _CONTINUE
        dist = PyT(bl(var).p, bl(x).p) '                calculate distance between var and x
        IF dist < bsiz2 THEN '                          are they closer than two radii, i.e. stuck together
            DIM AS V2 un
            P2V un, bl(x).p, bl(var).p
            R2_Norm un, un, bsiz2 - dist
            R2_Add bl(var).p, un, 1 '                   add it to the position
            'but what if a ball penetrates past the other balls center?
        END IF
        IF dist - bsiz2 < disp THEN '                   if ball x is within reach of magnitude
            disabc## = Ray_Trace##(bl(var).p, bl(var).d, bl(x).p, bsiz2)
            IF disabc## > 0 THEN '                          ray intersects ball x position
                B2BCollision bl(var), bl(x) 'USE THIS ALONE IN THE IF BLOCK FOR GOOD, BUT NOT MATHEMATICAL ACTION
            END IF '                                        end: disabc <= 0  aka ball missed
        END IF '                                            end: dist < disp test
    NEXT x

    ''KEEP THE FOLLOWING UNTIL THE VECTOR CODE WORKS
    ''wall bounces - now we need to work in pocket corners which we will tentatively treat like immobile balls flanking the holes
    ''LEFT/RIGHT
    'IF bl(var).p.x < bsiz + xt5 OR bl(var).p.x > xtable - bsiz - xt5 THEN
    '    IF ABS(bl(var).p.y - _SHR(ytable, 1)) > _SHR(ytable, 1) - xt5 - (bsiz2 / 1.415) THEN
    '        'ball sunk code here
    '        bl(var).sunk = -1
    '    ELSE
    '        bl(var).d.x = -bl(var).d.x
    '        IF bl(var).p.x < bsiz + xt5 THEN '                            if beyond left edge
    '            bl(var).p.x = bl(var).p.x + (2 * (bsiz + xt5 - bl(var).p.x))
    '        END IF
    '        IF bl(var).p.x > xtable - bsiz - xt5 THEN '                   if beyond right edge
    '            bl(var).p.x = bl(var).p.x - (2 * (bl(var).p.x - (xtable - bsiz - xt5)))
    '        END IF
    '    END IF
    'END IF
    ''TOP/BOTTOM
    'IF bl(var).p.y < bsiz + xt5 OR bl(var).p.y > ytable - bsiz - xt5 THEN
    '    IF ABS(bl(var).p.x - _SHR(xtable, 1)) > _SHR(xtable, 1) - xt5 - (bsiz2 / 1.415) THEN
    '        'ball sunk code here
    '        bl(var).sunk = -1
    '    ELSE
    '        bl(var).d.y = -bl(var).d.y
    '        IF bl(var).p.y < bsiz + xt5 THEN '                            if beyond top edge
    '            bl(var).p.y = bl(var).p.y + (2 * (bsiz + xt5 - bl(var).p.y))
    '        END IF
    '        IF bl(var).p.y > ytable - bsiz - xt5 THEN '                   if beyond bottom edge
    '            bl(var).p.y = bl(var).p.y - (2 * (bl(var).p.y - (ytable - bsiz - xt5)))
    '        END IF
    '    END IF
    'END IF

    'Vector code
    FOR x% = 0 TO 17
        IF NewlineSegCirc(bmp(x%), bl(var)) = 0 THEN _CONTINUE
        R2_Norm bl(var).n, bl(var).d, 1 '                       get displacement unit vector
        bk% = 0
        DO
            R2_Add bl(var).p, bl(var).n, -1 '                   backup by unit vectors, updating ball position
            bk% = bk% + 1
        LOOP UNTIL NewlineSegCirc(bmp(x%), bl(var)) = 0
        Vec_Mirror reflec, bmp(x%).n, bl(var).d '               get bisecter
        R2_Norm reflec, reflec, -bk% '                          invert & recover backed up unit vectors
        R2_Add bl(var).p, reflec, 1 '                           and add them to ball position
        m! = Mag(bl(var).d) '                                   preserve displacement magnitude
        R2_Norm bl(var).d, reflec, m! '                         set ball displacement to new angle
        'R2_Norm bl(var).d, bl(var).d, m! '                      lose energy in wall bounce (if desired)
        EXIT FOR
    NEXT x%

    'CHECK FOR POCKET INTERSECTIONS
    FOR x% = 0 TO 5
        IF PyT(bl(var).p, hl(x%).p) < hl(x%).r THEN
            bl(var).sunk = -1
        END IF
    NEXT x%
END SUB 'ColCheck

'²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²
SUB Dialog_Box (heading AS STRING, xsiz AS INTEGER, ysiz AS INTEGER, ypos AS INTEGER, bcol AS _UNSIGNED LONG, tcol AS _UNSIGNED LONG)
    'superimpose an image centered input box for various input routines
    cr& = _DEST '                                               save calling destination
    dbox& = _NEWIMAGE(xsiz, ysiz, 32) '                         define box
    _DEST dbox&
    COLOR tcol, &HFF282828 '                                    set text color with grey background
    CLS
    FOR x% = 0 TO 5 '                                           draw bounding box 6 pixels thick
        b~& = -Black * (x% < 2) - bcol * (x% >= 2) '             color=outer two black, balance bcol
        LINE (0 + x%, 0 + x%)-(xsiz - 1 - x%, ysiz - 1 - x%), b~&, B 'draw color border
    NEXT x%
    _PRINTSTRING (_SHR(xsiz, 1) - _SHL(LEN(heading), 2), 31), heading 'print heading two rows below top
    _DEST cr& '                                                 reset to calling destination
    _PUTIMAGE (_SHR(_WIDTH, 1) - _SHR(xsiz, 1), ypos), dbox& '  display box centered over calling destination image
    _FREEIMAGE dbox& '                                          clean up
END SUB 'Dialog_Box

'²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²
SUB Draw_Vecs
    FOR x% = 0 TO 18
        LINE (bmp(x%).s.x, bmp(x%).s.y)-(bmp(x%).e.x, bmp(x%).e.y), &HFFFF0000
    NEXT x%
END SUB 'Draw_Vecs

'²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²
SUB FCirc (CX AS INTEGER, CY AS INTEGER, RR AS INTEGER, C AS _UNSIGNED LONG, C2 AS _UNSIGNED LONG)
    DIM R AS INTEGER, RError AS INTEGER '                       SMcNeill's circle fill
    DIM X AS INTEGER, Y AS INTEGER
    R = ABS(RR)
    RError = -R
    X = R
    Y = 0
    IF R = 0 THEN PSET (CX, CY), C: EXIT SUB
    LINE (CX - X, CY)-(CX + X, CY), C, BF
    WHILE X > Y
        RError = RError + Y * 2 + 1
        IF RError >= 0 THEN
            IF X <> Y + 1 THEN
                LINE (CX - Y, CY - X)-(CX + Y, CY - X), C2, BF 'these two need white here for 9-15 balls
                LINE (CX - Y, CY + X)-(CX + Y, CY + X), C2, BF
            END IF
            X = X - 1
            RError = RError - X * 2
        END IF
        Y = Y + 1
        LINE (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
        LINE (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
    WEND
END SUB 'FCirc

'²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²
FUNCTION Key_In% (mode AS INTEGER, xpos AS INTEGER, ypos AS INTEGER, prompt AS STRING, validchars AS STRING)
    IF mode AND 32 THEN
        _PRINTSTRING (xpos, ypos), prompt
    ELSE
        LOCATE ypos, xpos
        PRINT prompt;
    END IF
    DO
        inChar$ = UCASE$(INKEY$)
        charPos% = INSTR(validchars, inChar$) '                examine the input.
        okchar% = LEN(inChar$) = 1 AND charPos% <> 0
        _LIMIT 30
    LOOP UNTIL okchar% '                                        Stop looping when a valid character is received.
    Key_In% = charPos%
END FUNCTION 'Key_In

'²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²
FUNCTION Limit% (lim AS INTEGER, var AS INTEGER)
    Limit% = lim - ((var - lim) * (var < lim + 1))
END FUNCTION 'Limit%

'²²²²²²²²Compute magnitude of vector v²²²²²²²²²²²²²²²²²²²²²²²²²²
FUNCTION Mag (v AS V2)
    Mag = _HYPOT(v.x, v.y)
END FUNCTION 'Mag

'²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²
SUB MakeBalls
    'create billiard ball hardware images
    'ball colors 1 yellow 2 blue 3 red 4 purple 5 orange 6 green 7 maroon 8 black
    '9 yellow/s 10 blue/s 11 red/s 12 purple/s 13 orange/s 14 green/s 15 maroon/s
    FOR x% = 0 TO 15
        tmp& = _NEWIMAGE(bsiz * 2 + 4, bsiz * 2 + 4, 32)
        _DEST tmp&
        wd% = _SHR(_WIDTH(tmp&), 1)
        ht% = _SHR(_HEIGHT(tmp&), 1)
        IF x% = 0 THEN '                                        Cue ball
            FCirc wd%, ht%, bsiz, bl(x%).c, bl(x%).c
            CIRCLE (wd%, ht%), bsiz + 1, Black
        ELSE '                                                  Solid/stripe numbered balls
            IF x% <= 8 THEN
                FCirc wd%, ht%, bsiz, bl(x%).c, bl(x%).c '      solid
            ELSE
                FCirc wd%, ht%, bsiz, bl(x%).c, White '         stripe
            END IF
            FCirc wd%, ht%, bsiz - 5, White, White '            number circle
            CIRCLE (wd%, ht%), bsiz + 1, Black '                dark outling
            n$ = _TRIM$(STR$(x%))
            t& = _NEWIMAGE(16, 16, 32)
            _DEST t&
            COLOR Black
            _PRINTMODE _KEEPBACKGROUND
            IF LEN(n$) > 1 THEN a = 0 ELSE a = 4
            _PRINTSTRING (a, 0), n$, t& '                       stamp number on ball
            _DEST tmp&
            _PUTIMAGE (8, 8)-(_WIDTH(tmp&) - 8, _HEIGHT(tmp&) - 8), t&, tmp&
            _FREEIMAGE t&
        END IF
        bnum(x%) = _COPYIMAGE(tmp&, 33)
        _FREEIMAGE tmp&
    NEXT x%
END SUB 'MakeBalls

'²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²
SUB MakeTable
    tmp& = _COPYIMAGE(0)
    _DEST tmp&
    COLOR , &HFF007632 '                                        felt color
    CLS

    FCirc xtable * .5, xt5 / 2, bsiz2, Black, Black '                           top side pocket
    FCirc xtable * .5, ytable - xt5 / 2, bsiz2, Black, Black '                  bottom side pocket
    FCirc xt5 * .75, xt5 * .75, bsiz2 * 1.5, Black, Black '                     upper left corner pocket
    FCirc xt5 * .75, ytable - xt5 * .75, bsiz2 * 1.5, Black, Black '            lower left corner pocket
    FCirc xtable - xt5 * .75, xt5 * .75, bsiz2 * 1.5, Black, Black '            upper right corner pocket
    FCirc xtable - xt5 * .75, ytable - xt5 * .75, bsiz2 * 1.5, Black, Black '   lower right corner pocket

    FOR x% = 0 TO xt5 - bmpthk '                                outer border
        cl& = -Black * (x% < 3) - RawUmber * (x% > 2)
        IF INT(RND * 3) < 1 THEN cl& = &HFF6B572B
        LINE (x%, x%)-(xtable - x%, ytable - x%), cl&, B
    NEXT x%
    FCirc xtable * .75, ytable * .5, 5, Gray, Gray '            cue spot
    FCirc xtable * .75, ytable * .5, 2, White, White
    FCirc xtable * .25, ytable * .5, 5, Gray, Gray '            rack spot
    FCirc xtable * .25, ytable * .5, 2, White, White
    'side pocket width = bsiz * 2.28,   corner pocket width = bsiz2 * 2 throat width
    FOR d% = 0 TO 15 '                                          iterate for thickness and bevel
        'draw left then right top bumpers
        LINE (xt5 + (_SHL(bsiz2, 1) / 1.415) - d%, xt5 - d%)-(_SHR(xtable, 1) - bsiz2 * 1.14 + (d% / 2), xt5 - d%), &HFF005025
        LINE (_SHR(xtable, 1) + bsiz2 * 1.14 - (d% / 2), xt5 - d%)-(xtable - xt5 - (_SHL(bsiz2, 1) / 1.415) + d%, xt5 - d%), &HFF005025
        'draw left then right bottom bumpers
        LINE (xt5 + (_SHL(bsiz2, 1) / 1.415) - d%, ytable - xt5 + d%)-(_SHR(xtable, 1) - bsiz2 * 1.14 + (d% / 2), ytable - xt5 + d%), &HFF005025
        LINE (_SHR(xtable, 1) + bsiz2 * 1.14 - (d% / 2), ytable - xt5 + d%)-(xtable - xt5 - (_SHL(bsiz2, 1) / 1.415) + d%, ytable - xt5 + d%), &HFF005025
        'draw left then right side bumpers
        LINE (xt5 - d%, xt5 + (_SHL(bsiz2, 1) / 1.415) - d%)-(xt5 - d%, ytable - xt5 - (_SHL(bsiz2, 1) / 1.415) + d%), &HFF005025
        LINE (xtable - xt5 + d%, xt5 + (_SHL(bsiz2, 1) / 1.415) - d%)-(xtable - xt5 + d%, ytable - xt5 - (_SHL(bsiz2, 1) / 1.415) + d%), &HFF005025
    NEXT d%
    tbl = _COPYIMAGE(tmp&, 33) '                                Move to hardware image
    _FREEIMAGE tmp&
END SUB 'MakeTable

'²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²
FUNCTION MBS% 'Mouse Button Status  Author: Steve McNeill
    STATIC StartTimer AS _FLOAT
    STATIC ButtonDown AS INTEGER
    CONST ClickLimit## = 0.2 'Less than 1/4th of a second to down, up a key to count as a CLICK.
    '                          Down longer counts as a HOLD event.
    SHARED Mouse_StartX, Mouse_StartY, Mouse_EndX, Mouse_EndY
    WHILE _MOUSEINPUT 'Remark out this block, if mouse main input/clear is going to be handled manually in main program.
        SELECT CASE SGN(_MOUSEWHEEL)
            CASE 1: tempMBS = tempMBS OR 512
            CASE -1: tempMBS = tempMBS OR 1024
        END SELECT
    WEND
    IF _MOUSEBUTTON(1) THEN tempMBS = tempMBS OR 1
    IF _MOUSEBUTTON(2) THEN tempMBS = tempMBS OR 2
    IF _MOUSEBUTTON(3) THEN tempMBS = tempMBS OR 4
    IF StartTimer = 0 THEN
        IF _MOUSEBUTTON(1) THEN 'If a button is pressed, start the timer to see what it does (click or hold)
            ButtonDown = 1: StartTimer = TIMER(0.01)
            Mouse_StartX = _MOUSEX: Mouse_StartY = _MOUSEY
        ELSEIF _MOUSEBUTTON(2) THEN
            ButtonDown = 2: StartTimer = TIMER(0.01)
            Mouse_StartX = _MOUSEX: Mouse_StartY = _MOUSEY
        ELSEIF _MOUSEBUTTON(3) THEN
            ButtonDown = 3: StartTimer = TIMER(0.01)
            Mouse_StartX = _MOUSEX: Mouse_StartY = _MOUSEY
        END IF
    ELSE
        BD = ButtonDown MOD 3
        IF BD = 0 THEN BD = 3
        IF TIMER(0.01) - StartTimer <= ClickLimit THEN 'Button was down, then up, within time limit.  It's a click
            IF _MOUSEBUTTON(BD) = 0 THEN tempMBS = 4 * 2 ^ ButtonDown: ButtonDown = 0: StartTimer = 0
        ELSE
            IF _MOUSEBUTTON(BD) = 0 THEN 'hold event has now ended
                tempMBS = 0: ButtonDown = 0: StartTimer = 0
                Mouse_EndX = _MOUSEX: Mouse_EndY = _MOUSEY
            ELSE 'We've now started the hold event
                tempMBS = tempMBS OR 32 * 2 ^ ButtonDown
            END IF
        END IF
    END IF
    MBS% = tempMBS
END FUNCTION 'MBS%

'²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²
FUNCTION MinOf% (value AS INTEGER, minimum AS INTEGER)
    MinOf% = -value * (value >= minimum) - minimum * (value < minimum)
END FUNCTION

'²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²
FUNCTION NewlineSegCirc (w AS Bump, b AS ball)
    'shorthand version of Bplus' lineSegIntersectCircle
    'utilizing vector math SUBs already implemented
    DIM AS V2 d, p
    DIM AS INTEGER rtn, i
    R2_Norm d, w.v, 1 '                                         d is unit vector of wall
    FOR i = 0 TO w.l '
        p = w.s: R2_Add p, d, i '                               add i multiples to wall start position to get p
        'if p within ball radius then intersect true and leave loop
        IF _HYPOT(p.x - b.p.x, p.y - b.p.y) <= bsiz THEN rtn = NOT rtn: EXIT FOR
    NEXT
    NewlineSegCirc = rtn
END FUNCTION 'NewlineSegCirc

'²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²
SUB Ortho_Norm (orth AS V2, vec AS V2)
    orth.x = -vec.y: orth.y = vec.x '                           compute orthogonal
    R2_Norm orth, orth, 1 '                                     and convert it to a unit vector
END SUB 'Ortho_Norm

'²²²²²²²²Convert points st & nd to a vector v²²²²²²²²²²²²²²²²²²²
SUB P2V (v AS V2, st AS V2, nd AS V2)
    v.x = nd.x - st.x
    v.y = nd.y - st.y
END SUB 'P2V

'²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²
SUB Pockets
    FOR x% = 0 TO 5
        SELECT CASE x%
            CASE 0: hl(x%).p.x = xt5 * .75: hl(x%).p.y = ytable - xt5 * .75: hl(x%).r = bsiz2 * 1.5
            CASE 1: hl(x%).p.x = xt5 * .75: hl(x%).p.y = xt5 * .75: hl(x%).r = bsiz2 * 1.5
            CASE 2: hl(x%).p.x = xtable * .5: hl(x%).p.y = xt5 / 2: hl(x%).r = bsiz2
            CASE 3: hl(x%).p.x = xtable - xt5 * .75: hl(x%).p.y = xt5 * .75: hl(x%).r = bsiz2 * 1.5
            CASE 4: hl(x%).p.x = xtable - xt5 * .75: hl(x%).p.y = ytable - xt5 * .75: hl(x%).r = bsiz2 * 1.5
            CASE 5: hl(x%).p.x = xtable * .5: hl(x%).p.y = ytable - xt5 / 2: hl(x%).r = bsiz2
        END SELECT
    NEXT x%
END SUB 'Pockets

'²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²
FUNCTION PyT (var1 AS V2, var2 AS V2)
    PyT = _HYPOT(ABS(var1.x - var2.x), ABS(var1.y - var2.y)) '  distances and magnitudes
END FUNCTION 'PyT

'²²²²²²²²Normalize v and regrow to scalar, return in re²²²²²²²²²
SUB R2_Norm (re AS V2, v AS V2, scalar AS SINGLE)
    x! = v.x: y! = v.y '                                        preserve vector v from changes (if desired)
    m! = _HYPOT(x!, y!) '                                       compute magnitude of v
    IF m! = 0 THEN '                                            trap division by zero
        re.x = 0: re.y = 0 '                                    by returning a zero vector
    ELSE '                                                      if magnitude not zero
        re.x = (x! / m!) * scalar '                             shrink to unit vector and rescale x component
        re.y = (y! / m!) * scalar '                               "     "       "       "       " y component
    END IF
END SUB 'R2_Norm

'²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²
SUB RackEmUp
    yoff = bsiz2 + 4
    xoff = SQR((yoff / 2) * (yoff / 2) + yoff * yoff) - 4
    RESTORE start
    FOR rank = 1 TO 5
        FOR b = 1 TO rank
            READ k
            bl(k).sunk = 0
            bl(k).p.x = (.25 * xtable) - (xoff * (rank - 1))
            bl(k).p.y = (.5 * ytable) - ((rank - 1) * (.5 * yoff)) + ((b - 1) * yoff)
    NEXT b, rank
END SUB 'RackEmUp

'²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²
FUNCTION Ray_Trace## (var1 AS V2, var2 AS V2, var3 AS V2, var4 AS _INTEGER64)
    'var1= ball initial position, var2= ball displacement, var3= target ball position, var4= strike radius
    'typical syntax: result = Ray_Trace##(bl(var).p, bl(var).d, bl(x).p, bsiz2)
    dx## = var2.x: dy## = var2.y '                              displacement of ball
    A## = (dx## * dx##) + (dy## * dy##) '                       displacement magnitude squared
    B## = 2 * dx## * (var1.x - var3.x) + 2 * dy## * (var1.y - var3.y)
    C## = (var3.x * var3.x) + (var3.y * var3.y) + (var1.x * var1.x) + (var1.y * var1.y) + -2 * (var3.x * var1.x + var3.y * var1.y) - (var4 * var4)
    Ray_Trace## = (B## * B##) - 4 * A## * C## ' if disabc## < 0 then no intersection =0 tangent >0 intersects two points
END FUNCTION 'Ray_Trace##

'²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²
SUB R2_Add (var AS V2, var2 AS V2, var3 AS INTEGER)
    var.x = var.x + (var2.x * var3) '                           add (or subtract) two vectors defined by unitpoint
    var.y = var.y + (var2.y * var3) '                           var= base vector, var2= vector to add
END SUB 'R2_Add

'²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²
FUNCTION R2_Dot (var AS V2, var2 AS V2)
    R2_Dot = var.x * var2.x + var.y * var2.y '                  get dot product of var & var2
END FUNCTION 'R2_Dot

'²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²
SUB R2_Mult (vec AS V2, multiplier AS SINGLE)
    vec.x = vec.x * multiplier '                                multiply vector by scalar value
    vec.y = vec.y * multiplier
END SUB 'R2_Mult

'²²²²²²²²Returns 0 when all balls have stopped²²²²²²²²²²²²²²²²²²
FUNCTION StillMoving
    s% = 0
    FOR x% = 0 TO 15
        IF bl(x%).d.x <> 0 THEN s% = -1
        IF bl(x%).d.y <> 0 THEN s% = -1
    NEXT x%
    StillMoving = s%
END FUNCTION 'StillMoving

'²²²²²²²²Mirror a vector {in} around a unit bisecter²²²²²²²²²²²²
SUB Vec_Mirror (re AS V2, bi AS V2, in AS V2)
    DIM t AS V2
    IF Mag(bi) <> 1 THEN '                                      if bi is not a unit vector
        R2_Norm t, bi, 1 '                                      normalize to t
    ELSE '                                                      if bi is a unit vector
        t = bi '                                                save it to t
    END IF
    R2_Norm re, t, R2_Dot(in, t) * 2
    R2_Add re, in, -1
END SUB 'Vec_Mirror



RE: Pool - bplus - 11-02-2022

Very nice ball action and nice aiming pool cue features, works intuitively. I did shoot the 2 ball onto the edge of table where it stayed pretty tricky but really nice ball action otherwise! (Pete, get your mind out of the gutter.)

This game is coming along nicely!

Is there a reason the balls aren't touching on the rack?

Oh we need a screenshot, I didn't notice the balls on the rail until I took the snip, I was so focused on next shot ;-))

Wait is that where you are putting the pocketed balls, along the rail? I bet!
   

Black edges around the balls look more natural, do you guys need numbers on balls? ;-))


RE: Pool - OldMoses - 11-02-2022

Thanks, I think the reason the balls don't touch is because the math on the racking sub is a bit off, but I haven't played with it much.

The weird stuff of balls going through balls still occurs on a break, which can be seen by slowing the loop. At speed it's visually convincing. Blush

Yes, sunk balls are displayed along the lower rail. I still have to retrieve balls that blow off the table. Since that sometimes happens in real pool tables, I decided to leave it and opt for a re-spotting routine. As in real pool there is a certain degree of finesse required.


RE: Pool - james2464 - 11-02-2022

This is really great, I enjoyed playing it and didn't have any problems. Other than I'm not great at billiards.


RE: Pool - bplus - 11-02-2022

I've been thinking of a makeover for my game, I like some features OldMoses did and I have to reduce my screen size because I moved my tool bar and I can no longer see the power bar nor the ball numbers pocketed without moving it to side to play. Plus I want to maximize table for biggest balls possible (black edges maybe brighter green table for contrast) without distorting ratio to regulation table ( 4.5 X 9 if I recall).

I've been thinking how we can make some kind of game out of this.
How about how many turns it takes you to run 100 balls = 6.66 racks? It'd be like Straight Poll only you don't have to call your shots.
Like golf, the lower the score the better. Best games are lowest number of turns saved to file. Top 10 maybe?


RE: Pool - james2464 - 11-02-2022

I have a question about this. How much of a programming brain teaser would it be to make the balls roll? I'm guessing it would be animated sprites and not circles but I have no idea, really.