Posted by: Pete - 04-25-2022, 11:30 PM - Forum: TheBOB
- No Replies
Snowfall.bas by Bob Seguin
Description: Screen saver winter scene utility with lighting effects.
Download: Download the zip file below. Unzip to either your QB64 folder, or for better organization, to a folder you create like "TheBOB-Snowfall".
Install: Compile Snowfall.bas with QB64 v1.3 or above, and make sure the compiler output is set to create the .exe file in the same folder. See the option in the QB64 IDE RUN menu and check the RUN option: "Output EXE to Source Folder".
f = _LoadFont("arial.ttf", 30): _Font f
_PrintMode _KeepBackground
balls = 15: size = 40: speed = 3
ReDim BallX(balls), BallY(balls), BallDx(balls), BallDy(balls), BallSize(balls), BallShow(balls), BallC(balls) As _Unsigned Long
w = _Width: h = _Height: w2 = _Width / 2: h2 = _Height / 2
restart:
'Generate random ball data
For B = 1 To balls
BallSize(B) = 40 + (Rnd * 30)
BallX(B) = BallSize(B) + Rnd * (w - 2 * BallSize(B)): BallY(B) = BallSize(B) + Rnd * (h - 2 * BallSize(B))
a = Rnd * _Pi(2): Ballspeed = 2 + B
BallDx(B) = Ballspeed * Cos(a): BallDy(B) = Ballspeed * Sin(a)
BallShow(B) = 1: BallC(B) = _RGB32(Rnd * 255, Rnd * 255, Rnd * 255)
Next
curball = 1
gametime = Timer
timelimit = 30
Do
Cls
'compute ball movement
For t = 1 To balls
BallX(t) = BallX(t) + BallDx(t) 'move ball then make sure in bounds
BallY(t) = BallY(t) + BallDy(t)
If BallX(t) > w - BallSize(t) Then BallDx(t) = -BallDx(t): BallX(t) = w - BallSize(t)
If BallX(t) < BallSize(t) Then BallDx(t) = -BallDx(t): BallX(t) = BallSize(t)
If BallY(t) > h - BallSize(t) Then BallDy(t) = -BallDy(t): BallY(t) = h - BallSize(t)
If BallY(t) < BallSize(t) Then BallDy(t) = -BallDy(t): BallY(t) = BallSize(t)
Next
'draw background
t = Timer
For x = 0 To w Step 4
For y = 0 To h Step 4
r = Sin(1.1 * t) * h2 - y + h2
'PSET (x, y), _RGB(r, r - y, -r)
Line (x, y)-Step(3, 3), _RGB(r, r - y, -r), BF
Next
t = t + .01
GoSub GetMouseClick
Next
If gameover = 1 Then
Play "o2l16cegagfefgabgc3l4"
Sleep 3
GoTo restart
End If
'draw balls
For i = 1 To balls
If BallShow(i) = 1 Then
drawBall BallX(i), BallY(i), BallSize(i), BallC(i)
_PrintString (BallX(i) - 15, BallY(i) - 15), Right$("0" + _Trim$(Str$(i)), 2)
End If
Next
'If click on one ball (no overlayed oned) remove it
If found = 1 Then
If firstball = curball Then
'erase ball
drawBall BallX(firstball), BallY(firstball), BallSize(firstball), BallC(firstball)
BallShow(firstball) = 0
Play "mbl32o2ceg"
_Display: _Delay .05
curball = curball + 1
found = 0
Else
found = found + 1
lastfound = firstball
End If
End If
''If click over several balls, remove top one
'IF found > 1 THEN
' 'BallShow(lastfound) = 0
' drawball BallX(lastfound), BallY(lastfound), BallSize(lastfound), 255, 200, 100
' _PRINTSTRING (BallX(lastfound) - 15, BallY(lastfound) - 15), STR$(lastfound)
' _DISPLAY: PLAY "mbl16o2fbfbl8f"
' found = 0
' _DELAY .5
' GOTO restart
'END IF
'check if all clicked
anyleft = 0
For c = 1 To balls
If BallShow(c) = 1 Then anyleft = anyleft + 1
Next
If anyleft = 0 Then
gameover = 1
End If
If Timer - gametime > timelimit Then
Play "mbo1l4dl8ddl4dl8feeddc#l2d"
Sleep 3
GoTo restart
End If
Loop
End
'==============
GetMouseClick:
'==============
mi = _MouseInput
If _MouseButton(1) = 0 Then done = 0
If _MouseButton(1) And done = 0 Then
mx = _MouseX: my = _MouseY
found = 0
For m = 1 To balls
If BallShow(m) = 1 Then
If Sqr((mx - BallX(m)) ^ 2 + (my - BallY(m)) ^ 2) < BallSize(m) Then
If found = 0 Then firstball = m
found = found + 1
If found > 1 Then
lastfound = m
End If
End If
End If
Next
done = 1
End If
Return
Sub drawBall (x, y, r, c As _Unsigned Long)
Dim rred As Long, grn As Long, blu As Long, rr As Long, f
rred = _Red32(c): grn = _Green32(c): blu = _Blue32(c)
For rr = r To 0 Step -1
f = 1 - rr / r
fcirc x, y, rr, _RGB32(rred * f, grn * f, blu * f)
Next
End Sub
Sub fcirc (CX As Integer, CY As Integer, R As Integer, C As _Unsigned Long)
Dim Radius As Integer, RadiusError As Integer
Dim X As Integer, Y As Integer
Radius = Abs(R): RadiusError = -Radius: X = Radius: Y = 0
If Radius = 0 Then PSet (CX, CY), C: Exit Sub
Line (CX - X, CY)-(CX + X, CY), C, 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), C, BF
Line (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
End If
X = X - 1
RadiusError = RadiusError - 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
Posted by: Pete - 04-25-2022, 11:07 PM - Forum: TheBOB
- No Replies
Solitaire-v3.0 by Bob Seguin
Description: The classic card game of Solitaire, but with one twist. The player has three decks of the remaining 24-cards to choose from, instead of the usual single deck. There is also a Game Options setting to select two different scoring systems.
Download: Download the zip file below. Unzip to either your QB64 folder, or for better organization, to a folder you create like "TheBOB-Solitaire".
Install: Compile Solitaire-v3.0.bas with QB64 v1.3 or above, and make sure the compiler output is set to create the .exe file in the same folder. See the option in the QB64 IDE RUN menu and check the RUN option: "Output EXE to Source Folder".
Smallish Games 100 - 300 LOC with at most a image or sound file.
Bowling
@johnno56 was very helpful with this way back when we were at SmallBASIC forum. I left a copy of that SmallBASIC code (the bas that starts with SB) for nostalgia. This one seems different than usual computer game.
Posted by: Pete - 04-25-2022, 10:00 PM - Forum: TheBOB
- No Replies
StarBusters2.bas Description: An unfinished remake of StarBusters.bas (See previous post). Space ship flies and shoots missiles but the meteors are not present. Included here for anyone who would like to continue the project.
Download: Download the zip file below. Unzip to either your QB64 folder, or for better organization, to a folder you create like "TheBOB-StarBusters2".
Install: Compile StarBusters.bas with QB64 v1.3 or above, and make sure the compiler output is set to create the .exe file in the same folder. See the option in the QB64 IDE RUN menu and check the RUN option: "Output EXE to Source Folder".
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.
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
Paint (BRad + 1, BRad + 1), _RGB32(r, g, b), _RGB32(200, 200, 200)
End If
_PutImage , 0, BI(i), (1, 1)-Step(BDia, BDia)
Next
End Sub
Sub CP (lineNumber, mess$)
Dim As Long ttw, tth
ttw = 8: tth = 16
Line (0, tth * lineNumber)-(xmax, tth * lineNumber + tth), backColr, BF
Color _RGB32(255, 255, 255), _RGB32(0, 94, 62)
_PrintString ((xmax - ttw * Len(mess$)) / 2, tth * lineNumber), mess$
'_Display
End Sub
'Steve McNeil's copied from his forum note: Radius is too common a name
Sub fcirc (CX As Long, CY As Long, R As Long)
Dim subRadius As Long, RadiusError As Long
Dim X As Long, Y As Long
subRadius = Abs(R)
RadiusError = -subRadius
X = subRadius
Y = 0
If subRadius = 0 Then PSet (CX, CY): Exit Sub
' Draw the middle span here so we don't draw it twice in the main loop,
' which would be a problem with blending turned on.
Line (CX - X, CY)-(CX + X, CY), , BF
While X > Y
RadiusError = RadiusError + Y * 2 + 1
If RadiusError >= 0 Then
If X <> Y + 1 Then
Line (CX - Y, CY - X)-(CX + Y, CY - X), , BF
Line (CX - Y, CY + X)-(CX + Y, CY + X), , BF
End If
X = X - 1
RadiusError = RadiusError - X * 2
End If
Y = Y + 1
Line (CX - X, CY - Y)-(CX + X, CY - Y), , BF
Line (CX - X, CY + Y)-(CX + X, CY + Y), , BF
Wend
End Sub
Sub PollMouse ' catch locations of mouse button 1 down and up
Dim As Long mb1
While _MouseInput: Wend
mx = _MouseX: my = _MouseY: mb1 = _MouseButton(1)
If mb1 And oldmb1 = 0 Then
mb1DownX = mx
mb1DownY = my
End If
If mb1 = 0 And oldmb1 Then
mb1UpX = mx
mb1UpY = my
End If
oldmb1 = mb1
End Sub
Function vect$ (x, y) ' convert x, y to string for passing vectors with Functions
vect$ = _Trim$(Str$(x)) + "," + _Trim$(Str$(y))
End Function
Function vectX# (v$)
vectX# = Val(LeftOf$(v$, ","))
End Function
Function vectY# (v$)
vectY# = Val(RightOf$(v$, ","))
End Function
Function vectLen# (v$)
Dim As Double x, y
x = Val(LeftOf$(v$, ","))
y = Val(RightOf$(v$, ","))
vectLen# = Sqr(x * x + y * y)
End Function
Function vectUnit$ (v$) ' fix possible 0 that might hang
Dim As Double x, y, vl
x = Val(LeftOf$(v$, ","))
y = Val(RightOf$(v$, ","))
vl = Sqr(x * x + y * y)
If vl <> 0 Then vectUnit$ = vect$(x / vl, y / vl) Else vectUnit$ = vect$(x, y)
End Function
Function vectAdd$ (v1$, v2$)
Dim As Double x1, y1, x2, y2
x1 = Val(LeftOf$(v1$, ","))
y1 = Val(RightOf$(v1$, ","))
x2 = Val(LeftOf$(v2$, ","))
y2 = Val(RightOf$(v2$, ","))
vectAdd$ = vect$(x1 + x2, y1 + y2)
End Function
Function vectSub$ (v1$, v2$)
Dim As Double x1, y1, x2, y2
x1 = Val(LeftOf$(v1$, ","))
y1 = Val(RightOf$(v1$, ","))
x2 = Val(LeftOf$(v2$, ","))
y2 = Val(RightOf$(v2$, ","))
vectSub$ = vect$(x1 - x2, y1 - y2)
End Function
Function vectDotProduct# (v1$, v2$)
Dim As Double x1, y1, x2, y2
x1 = Val(LeftOf$(v1$, ","))
y1 = Val(RightOf$(v1$, ","))
x2 = Val(LeftOf$(v2$, ","))
y2 = Val(RightOf$(v2$, ","))
vectDotProduct# = x1 * x2 + y1 * y2
End Function
Function vectScale$ (a, v$) 'a * vector v$
Dim As Double x, y
x = Val(LeftOf$(v$, ","))
y = Val(RightOf$(v$, ","))
vectScale$ = vect$(a * x, a * y)
End Function
Function vectTangent$ (v$, base$)
Dim n$
n$ = vectUnit$(base$)
vectTangent$ = vectScale$(vectDotProduct(n$, v$), n$)
End Function
Function vectNorm$ (v$, base$)
vectNorm$ = vectSub$(v$, vectTangent$(v$, base$))
End Function
' update these 2 in case of$ is not found! 2021-02-13
Function LeftOf$ (source$, of$)
If InStr(source$, of$) > 0 Then LeftOf$ = Mid$(source$, 1, InStr(source$, of$) - 1) Else LeftOf$ = source$
End Function
' update these 2 in case of$ is not found! 2021-02-13
Function RightOf$ (source$, of$)
If InStr(source$, of$) > 0 Then RightOf$ = Mid$(source$, InStr(source$, of$) + Len(of$)) Else RightOf$ = ""
End Function
For Dimster and again thanks to OldMoses for pointing to a paper upon which collision code here is based.
![[Image: Screenshot-571.png]](https://i.ibb.co/kHwTtTm/Screenshot-571.png)
![[Image: Screenshot-625.png]](https://i.ibb.co/M62bLRV/Screenshot-625.png)
![[Image: Screenshot-616.png]](https://i.ibb.co/5LJwZTn/Screenshot-616.png)
![[Image: Screenshot-611.png]](https://i.ibb.co/DR25HpY/Screenshot-611.png)
