04-27-2022, 10:42 AM
I found that billiards work in progress. It wasn't working because I used Steve's MBS routine and hadn't updated it for 2.1. There's no table yet, but you can swat the balls around the table. It works best with a three button mouse. Right click re-racks, left click strikes the cue and the mousewheel sets the strike force. Clicking the mousewheel sets a maximum force, from which the wheel can fine tune.
Code: (Select All)
$COLOR:32
$CONSOLE
'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
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
s AS SINGLE ' speed
r AS _BYTE ' rack position
END TYPE
TYPE pylon ' pocket throat radii 2 per pocket
'poc as _byte ' 'pocket #
p AS V2 ' pylon position
vert AS V2 ' bumper vertex
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 psiz AS INTEGER ' pocket radius
DIM SHARED bl(15) AS ball ' ball data
DIM SHARED pl(12) AS pylon ' pocket throat bumpers
DIM SHARED bnum(15) AS LONG ' ball image handles
DIM SHARED tbl AS LONG ' table image handle
DIM SHARED origin AS V2 ' zero vector
origin.x = 0: origin.y = 0
'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
_ECHO STR$(bsiz)
bsiz2 = bsiz * 2
xt5 = xtable * .05
RANDOMIZE TIMER
RESTORE hue
FOR x = 0 TO 15
READ bl(x).c
NEXT x
MakeTable
MakeBalls
RackEmUp
bl(0).p.y = INT(ytable * .5) ' position the cue
bl(0).p.x = INT(xtable * .75)
a& = _NEWIMAGE(xtable, ytable, 32)
_DEST a&: SCREEN a&
DO: LOOP UNTIL _SCREENEXISTS
_SCREENMOVE 5, 5
COLOR , &HFF007632
CLS
DO
CLS
_PUTIMAGE , tbl, a&
FOR x = 0 TO 15
IF bl(x).sunk THEN
IF x = 0 THEN
'scratch
bl(0).p.y = INT(ytable * .5) ' position the cue
bl(0).p.x = INT(xtable * .75)
ELSE
_CONTINUE
END IF
END IF
VecAdd bl(x).p, bl(x).d, 1
VecMult bl(x).d, .99
IF PyT(origin, bl(x).d) < .05 THEN bl(x).d = origin
ColCheck x
_PUTIMAGE (INT(bl(x).p.x) - CINT(_WIDTH(bnum(x)) / 2), INT(bl(x).p.y) - CINT(_HEIGHT(bnum(x)) / 2)), bnum(x), a&
NEXT x
ms = MBS%
IF ms AND 1 THEN
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
VecNorm bl(0).d ' shrink it
VecMult bl(0).d, su ' grow it
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
IF ms AND 2 THEN ' if mouse right button reset the rack
BallStop ' all displacements to = origin
bl(0).p.y = INT(ytable * .5)
bl(0).p.x = INT(xtable * .75)
RackEmUp
END IF
IF ms AND 4 THEN ' if mouse center button, set full strike
IF su = 35 THEN su = 0
IF su = 0 THEN su = 35
END IF
IF ms AND 512 THEN ' roll mousewheel back, accelerate away from mouse cursor
su = Limit%(35, 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 > -35) ' helpful in aiming from table edge
END IF
'LINE (_MOUSEX, _MOUSEY)-(CINT(bl(0).p.x), CINT(bl(0).p.y))
''slope of target line
'pathx = CINT(bl(0).p.x) - _MOUSEX: pathy = CINT(bl(0).p.y) - _MOUSEY
'LINE (bl(0).p.x, bl(0).p.y)-(pathx * 1000, pathy * 1000), Blue
IF (bl(0).d.x = 0) AND (bl(0).d.y = 0) THEN
LINE (_MOUSEX, _MOUSEY)-(CINT(bl(0).p.x), CINT(bl(0).p.y))
'slope of target line
pathx = CINT(bl(0).p.x) - _MOUSEX: pathy = CINT(bl(0).p.y) - _MOUSEY
LINE (bl(0).p.x, bl(0).p.y)-(pathx * 1000, pathy * 1000), Blue
_PRINTSTRING (bl(0).p.x - 8, bl(0).p.y - 8), STR$(su)
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
SUB B2BCollision (ball1 AS ball, ball2 AS ball)
DIM AS V2 un, ut, ncomp1, ncomp2, tcomp1, tcomp2
un = ball2.p: VecAdd un, ball1.p, -1: VecNorm un ' establish unit normal
ut.x = -un.y: ut.y = un.x ' establish unit tangent
bnci1 = VecDot(un, ball1.d) ' ball 1 normal component of input velocity
bnci2 = VecDot(un, ball2.d) ' ball 2 normal component of input velocity
btci1 = VecDot(ut, ball1.d) ' ball 1 tangent component of input velocity
btci2 = VecDot(ut, ball2.d) ' ball 2 tangent component of input velocity
bncx1 = bnci2 ' compute normal component of ball 1 exit velocity
bncx2 = bnci1 ' compute normal component of ball 2 exit velocity
ncomp1 = un: VecMult ncomp1, bncx1 ' unit normal exit vector x normal component of exit vector ball1
tcomp1 = ut: VecMult tcomp1, btci1 ' unit tangent exit vector x tangent component of exit vector
ncomp2 = un: VecMult ncomp2, bncx2 ' same for ball2, unit normal...
tcomp2 = ut: VecMult tcomp2, btci2 ' same for ball2, unit tangent...
ball1.d = ncomp1: VecAdd ball1.d, tcomp1, 1 ' add normal and tangent exit vectors
ball2.d = ncomp2: VecAdd ball2.d, tcomp2, 1 ' add normal and tangent exit vectors
VecMult ball1.d, .95 ' lets take 5% of energy in entropic factors
VecMult ball2.d, .95
END SUB 'B2BCollision
SUB BallStop
FOR x = 0 TO 15
bl(x).d = origin
NEXT x
END SUB 'BallStop
SUB ColCheck (var AS INTEGER)
'check for ball in displacement radius
disp = SQR(bl(var).d.x * bl(var).d.x + bl(var).d.y * bl(var).d.y) 'vector magnitude for this iteration
FOR x = 0 TO 15 '
IF x = var 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
un = bl(var).p: VecAdd un, bl(x).p, -1 ' get a normal vector between them
VecNorm un ' shrink it to a unit vector
VecMult un, (bsiz2 - dist) ' grow it by the amount they intersect
VecAdd 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
dx = bl(var).p.x - bl(x).p.x
dy = bl(var).p.y - bl(x).p.y
A## = (bl(var).d.x * bl(var).d.x) + (bl(var).d.y * bl(var).d.y) 'displacement range
B## = 2 * bl(var).d.x * dx + 2 * bl(var).d.y * dy
C## = (bl(x).p.x * bl(x).p.x) + (bl(x).p.y * bl(x).p.y) + (bl(var).p.x * bl(var).p.x)_
+ (bl(var).p.y * bl(var).p.y) + -2 * (bl(x).p.x * bl(var).p.x + bl(x).p.y * bl(var).p.y) - (bsiz2 * bsiz2)
disabc## = (B## * B##) - 4 * A## * C##
'disabc## = Ray_Trace##(bl(var).p, bl(var).d, bl(x).p, bsiz2)
IF disabc## > 0 THEN ' ray intersects ball x position
'''still need an impact point, or balls deflect while their still out a ways
'DIM AS ball vball, xball
'DIM AS V2 neari
'vball = bl(var) ' use temporary balls for B2BCollision call
'xball = bl(x)
'''// near intersect quadratic returns percentage of displacement to contact point
't## = (-B## - ((B## * B##) - 4 * A## * C##) ^ .5) / (2 * A##)
'''// contact point- because bsiz2 is twice radius we have ball var coordinate as impact point, not
'''// the actual surface point of impact- we may deflect the var from this point
'neari.x = bl(var).p.x + t## * bl(var).d.x: neari.y = bl(var).p.y + t## * bl(var).d.y
'''// now that we have a contact point, we can proceed to deflect the displacements of var and x
'''// omitting this makes it crash readily, but we have to do something with remaining motion {1-t##} if
'''// we retain it. We also must use that portion to move ball x
'vball.p = neari
B2BCollision bl(var), bl(x) 'USE THIS ALONE IN THE IF BLOCK FOR GOOD, BUT NOT MATHEMATICAL ACTION
'B2BCollision vball, xball
'f## = 1 - t##
'vball.p.x = vball.p.x + f## + vball.d.x: vball.p.y = vball.p.y + f## + vball.d.y
'bl(var) = vball
'bl(x) = xball
END IF ' end: disabc <= 0 aka ball missed
END IF ' end: dist < disp test
NEXT x
'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
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
'TOP/BOTTOM
IF bl(var).p.y < bsiz + xt5 OR bl(var).p.y > ytable - bsiz - xt5 THEN
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 SUB 'ColCheck
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 Limit% (lim AS INTEGER, var AS INTEGER)
Limit% = lim - ((var - lim) * (var < lim + 1))
END FUNCTION 'Limit%
SUB MakeBalls
FOR x = 0 TO 15
'make ball images here
bnum(x) = _NEWIMAGE(bsiz * 2 + 4, bsiz * 2 + 4, 32)
_DEST bnum(x)
IF x = 0 THEN ' Cue ball
FCirc INT(_WIDTH(bnum(x)) / 2), INT(_HEIGHT(bnum(x)) / 2), bsiz, bl(x).c, bl(x).c
CIRCLE (_WIDTH(bnum(x)) / 2, _HEIGHT(bnum(x)) / 2), bsiz + 1, Black
ELSE
'Solids or stripes
IF x <= 8 THEN
FCirc INT(_WIDTH(bnum(x)) / 2), INT(_HEIGHT(bnum(x)) / 2), bsiz, bl(x).c, bl(x).c ' solid
ELSE
FCirc INT(_WIDTH(bnum(x)) / 2), INT(_HEIGHT(bnum(x)) / 2), bsiz, bl(x).c, White ' stripe
END IF
FCirc INT(_WIDTH(bnum(x)) / 2), INT(_HEIGHT(bnum(x)) / 2), bsiz - 5, White, White 'number circle
CIRCLE (_WIDTH(bnum(x)) / 2, _HEIGHT(bnum(x)) / 2), bsiz + 1, Black
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&
_DEST bnum(x)
_PUTIMAGE (8, 8)-(_WIDTH(bnum(x)) - 8, _HEIGHT(bnum(x)) - 8), t&, bnum(x)
_FREEIMAGE t&
END IF
NEXT x
END SUB 'MakeBalls
SUB MakeTable
tbl = _NEWIMAGE(xtable, ytable, 32)
_DEST tbl
COLOR , &HFF007632
CLS
FOR x = 0 TO 2
LINE (x, x)-(xtable - x, ytable - x), Black, B
NEXT x
FCirc xtable * .75, ytable * .5, 5, Gray, Gray
FCirc xtable * .75, ytable * .5, 2, White, White
LINE (xt5, xt5)-(xtable - xt5, ytable - xt5), &HFFFF0000, B , &HF0F0
END SUB 'MakeTable
FUNCTION map! (value!, minRange!, maxRange!, newMinRange!, newMaxRange!)
map! = ((value! - minRange!) / (maxRange! - minRange!)) * (newMaxRange! - newMinRange!) + newMinRange!
END FUNCTION 'map!
FUNCTION MBS% 'Mouse Button Status Author: Steve McNeill
STATIC StartTimer AS _FLOAT
STATIC ButtonDown AS INTEGER
STATIC ClickCount 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%
SUB PylonPosition
'UNDER CONSTRUCTION
'side pocket width = bsiz * 2.28
'corner pocket width = bsiz2 * 2 throat width
'FOR x = 1 TO 12
'NEXT x
END SUB 'PylonPosition
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
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).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 VecAdd (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 'VecAdd
FUNCTION VecDot (var AS V2, var2 AS V2)
VecDot = var.x * var2.x + var.y * var2.y ' get dot product of var & var2
END FUNCTION 'VecDot
SUB VecMult (vec AS V2, multiplier AS SINGLE)
vec.x = vec.x * multiplier ' multiply vector by scalar value
vec.y = vec.y * multiplier
END SUB 'VecMult
SUB VecNorm (var AS V2)
m = SQR(var.x * var.x + var.y * var.y) ' convert var to unit vector
var.x = var.x / m
var.y = var.y / m
END SUB 'VecNorm
DO: LOOP: DO: LOOP
sha_na_na_na_na_na_na_na_na_na:
sha_na_na_na_na_na_na_na_na_na: