+- QB64 Phoenix Edition (https://staging.qb64phoenix.com)
+-- Forum: QB64 Rising (https://staging.qb64phoenix.com/forumdisplay.php?fid=1)
+--- Forum: Prolific Programmers (https://staging.qb64phoenix.com/forumdisplay.php?fid=26)
+---- Forum: bplus (https://staging.qb64phoenix.com/forumdisplay.php?fid=36)
+---- Thread: Pool (/showthread.php?tid=178)
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 FunctionFor 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_MirrorRE: 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.
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.