11-02-2022, 05:29 PM
James' angled wall bouncing problem got me to come back and look at this program with new eyes. Otherwise, it might have not gone any further. Bplus' lineSegIntersectCircle function is fast and works well for this vector approach, so thanks for that one.
I added an object ball retrieval for off table scratches in the beginning of the main loop as soon as motion stops.
Rolling balls would certainly be above my pay grade. Perhaps someone else might tackle it. I'm leary of computationally expensive graphics that might effect the action.
I added an object ball retrieval for off table scratches in the beginning of the main loop as soon as motion stops.
Rolling balls would certainly be above my pay grade. Perhaps someone else might tackle it. I'm leary of computationally expensive graphics that might effect the action.
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, foot, spot
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
foot.x = xtable / 4: foot.y = ytable / 2
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
_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
spot = foot
IF ABS(xtable / 2 - bl(x%).p.x) > xtable / 2 OR ABS(ytable / 2 - bl(x%).p.y) > ytable / 2 THEN
IF x% = 0 THEN
scratch = -1
ELSE ' spot object ball code
DO
ft_avl% = -1 ' innocent until proven guilty
FOR oc% = 1 TO 15
IF oc% = x% THEN _CONTINUE
IF PyT(spot, bl(oc%).p) < bsiz THEN ' if oc% in the way
ft_avl% = 0
spot.x = spot.x - bsiz2 ' move back from foot
END IF
NEXT oc%
LOOP UNTIL ft_avl%
IF NOT StillMoving THEN bl(x%).p = spot
END IF
bl(x%).d = origin
END IF
IF bl(x%).sunk THEN
bl(x%).d = origin ' stop ball motion
IF x% = 0 THEN ' scratched the cueball
scratch = -1
bl(0).sunk = 0 ' re-spot the cueball
ELSE
_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%
'MOUSE OPS
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 NOT StillMoving 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
'AIMING AIDS
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 AS V2 reflec, un
'CHECK FOR BALL INTERSECTIONS
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
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? do a dot product
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
'CHECK FOR BUMPER INTERSECTIONS
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
'²²²²²²²²Show an input dialog box²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²
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
'²²²²²²²²show bumper vectors for development²²²²²²²²²²²²²²²²²²²²
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
'²²²²²²²²Get key input of valid characters²²²²²²²²²²²²²²²²²²²²²²
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 single 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
DO: LOOP: DO: LOOP
sha_na_na_na_na_na_na_na_na_na:
sha_na_na_na_na_na_na_na_na_na: