Pool

[OldMoses]

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