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.
Posted by: Pete - 04-25-2022, 07:03 PM - Forum: TheBOB
- No Replies
Winbit.bas by Bob Seguin
Description: A bitmap loader made for QBasic and modified to display 1, 4, 8, and 24bit .bmp files in QB64 SCREEN 12 or SCREEN 13. A 24-bit .bmp file "example.bmp" is included in the zip file. Type in "example" at the prompt for a quick demo.
Download: Download the zip file below. Unzip to either your QB64 folder, or for better organization, to a folder you create like "TheBOB-Winbit".
Install: Compile Winbit.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".
I've recently been playing around with various programs which communicate with each other via TCP/IP, I've decided that I needed some sort of simple protocol to make certain that the data I send and receive from computer to computer is correct and not corrupted. Here's the routine I've basically set up so far:
Code: (Select All)
DIM SHARED Host AS LONG
SCREEN _NEWIMAGE(800, 600, 32)
COLOR &HFFFFFFFF, &HFF000000
Host = _OPENHOST("TCP/IP:7990") ' this will be the host code
DO
Player = GetClient 'Not
IF Player THEN
PRINT "New Player connected"
'Do stuff
UserData$ = In$(Player)
'do stuff with the data the user sent
'and close the connection
CLOSE Player
Player = 0
END IF
_LIMIT 30
LOOP
FUNCTION GetClient
GetClient = _OPENCONNECTION(Host) ' receive any new connection
END FUNCTION
FUNCTION In$ (who)
DIM b AS _UNSIGNED _BYTE
'CHR$(2) = Start of Text
'CHR$(3) = End of Text
'CHR$(4) = End of Transmission (It's what we use to tell the client, "We give up! Closing connection!"
'CHR$(6) = Acknowledge
'CHR$(15) = Not Acknowledge
GET #who, , b 'just check for a single byte from each connection
IF b <> 2 THEN
'If we get something which isn't a CHR$(2) to start communication, send back a failure notice.
SendError who
EXIT FUNCTION 'Exit so we can move on to the next connection to check for that leading chr$(2)
END IF
'Only if that initial byte is CHR$(2), do we acknowledge receipt and await further messages.
SendConfirmation who 'we send ACKnowledgement back to tell the client we're ready for them to talk to us.
DO
count = count + 1
timeout## = ExtendedTimer + 5
DO
_LIMIT 100 'no need to check for incoming information more than 100 times a second!
GET #who, , a$
IF a$ <> "" THEN tempIn$ = tempIn$ + a$ 'tempIn$ should never be more than 105 bytes
ETX = INSTR(a$, CHR$(3)) ' chr$(3) is our ETX character (End of TeXt)
IF ETX THEN EXIT DO
IF ExtendedTimer > timeout## THEN 'If it takes over 5 seconds to send 100 bytes (or less) of info
SendError who ' something is wrong. Terminate the attempt, but be nice, and let
EXIT FUNCTION ' the other client know something went wrong, so they can try again,
END IF ' if they want to.
LOOP UNTIL LEN(tempIn$) > 105 'If we have over 105 bytes with our string, we didn't send the data properly.
IF LEN(tempIn$) > 105 THEN
SendError who 'send the client an error message
EXIT FUNCTION
END IF
tempIn$ = _TRIM$(LEFT$(tempIn$, ETX - 1)) 'strip off the ETX character and check to make certain data is valid.
c$ = RIGHT$(tempIn$, 4) 'these 4 bytes are the checksum
CheckSum = CVL(c$) 'Check to make certain the data apprears valid.
FOR i = 1 TO LEN(l$): Check = Check + ASC(l$, i): NEXT
IF CheckSum <> Check THEN ' Our data is not what we expected. Part may be lost, or corrupted.
SendError who
EXIT FUNCTION
ELSE
SendConfirmation who
EXIT DO
END IF
LOOP UNTIL count = 5
'If we get bad data 5 times in a row, something is wrong. We're just going to close the connection.
IF count = 5 THEN
SendError who
EXIT FUNCTION
END IF
'and if we're down this far, our data has been recieved, verified, and is now good to use.
In$ = LEFT$(tempIn$, 4) 'left part of the string is the data the user is sending us
END FUNCTION
SUB SendError (who)
DIM b AS _UNSIGNED _BYTE
b = 4
PUT #who, , b
END SUB
SUB SendConfirmation (who)
DIM b AS _UNSIGNED _BYTE
b = 6
PUT #who, , b
END SUB
FUNCTION ExtendedTimer##
DIM m AS INTEGER, d AS INTEGER, y AS INTEGER
DIM s AS _FLOAT, day AS STRING
day = DATE$
m = VAL(LEFT$(day, 2))
d = VAL(MID$(day, 4, 2))
y = VAL(RIGHT$(day, 4)) - 1970
SELECT CASE m 'Add the number of days for each previous month passed
CASE 2: d = d + 31
CASE 3: d = d + 59
CASE 4: d = d + 90
CASE 5: d = d + 120
CASE 6: d = d + 151
CASE 7: d = d + 181
CASE 8: d = d + 212
CASE 9: d = d + 243
CASE 10: d = d + 273
CASE 11: d = d + 304
CASE 12: d = d + 334
END SELECT
IF (y MOD 4) = 2 AND m > 2 THEN d = d + 1 'add a day if this is leap year and we're past february
d = (d - 1) + 365 * y 'current month days passed + 365 days per each standard year
d = d + (y + 2) \ 4 'add in days for leap years passed
s = d * 24 * 60 * 60 'Seconds are days * 24 hours * 60 minutes * 60 seconds
ExtendedTimer## = (s + TIMER)
END FUNCTION
Now this isn't going to work to send binary files, as I'm using some of the ASCII characters as reserved command codes, but since this isn't meant to be a file transfer protocol, I don't think it should be a problem. My command codes are as follows: 'CHR$(2) = Start of Text
'CHR$(3) = End of Text
'CHR$(4) = End of Transmission (It's what we use to tell the client, "We give up! Closing connection!"
'CHR$(6) = Acknowledge
'CHR$(15) = Not Acknowledge
The idea the behind the process is this one:
First, we simply wait for a CHR$(2) character to come in, as a request from a client saying they want to send us data. If we get anything else before that, we send them an error message. All messages start with chr$(2), and when we get it, we send a confirmation back to the client so they know we're all set to receive their data (CHR$(6)).
At this point, they send us the data, which is limited to being 105 bytes or less. This 105 byte structure consists of up to 100 bytes of data, 4 bytes for a checksum of the data sent, and then the termination code. (CHR$(3))
Once we verify that everything is correct, we either send back a success, or failure signal, to the client. If we fail, they can try to resend the data, otherwise all is golden.
I tried to comment the process here so that it'd be easily understood by anyone who looks it over, but if anyone has any questions, just ask them. If there appears to be something wrong with my logic, feel free to tell me about that as well. I haven't actually tested this in a working program yet (my test game is still in development and hasn't gotten to the point where it's trying to talk back and forth to other games yet), but I don't see anything that looks wrong with it. Unless I just made a common typo, or other silly mistake, it should work as intended here...
Take a look at it. See if it looks like a process that will hold up to general usage to send plain text back and forth between computers. And, if you see something that I goofed on, or overlooked, kindly point it out to me. If all works as intended, this will end up going into a transfer library later for me, so I can just plug it into any project and use it to send and receive data between devices.
If you guys are like me, and code everything into library snippets to reuse it over and over, you probably end up finding that some of your essential code ends up going into multiple libraries and then tossing errors when you make use of those libraries together.
Here's a solution which works in this case:
Code: (Select All)
$IF EXT = UNDEFINED THEN
$LET EXT = TRUE
FUNCTION ExtendedTimer##
DIM m AS INTEGER, d AS INTEGER, y AS INTEGER
DIM s AS _FLOAT, day AS STRING
day = DATE$
m = VAL(LEFT$(day, 2))
d = VAL(MID$(day, 4, 2))
y = VAL(RIGHT$(day, 4)) - 1970
SELECT CASE m 'Add the number of days for each previous month passed
CASE 2: d = d + 31
CASE 3: d = d + 59
CASE 4: d = d + 90
CASE 5: d = d + 120
CASE 6: d = d + 151
CASE 7: d = d + 181
CASE 8: d = d + 212
CASE 9: d = d + 243
CASE 10: d = d + 273
CASE 11: d = d + 304
CASE 12: d = d + 334
END SELECT
IF (y MOD 4) = 2 AND m > 2 THEN d = d + 1 'add a day if this is leap year and we're past february
d = (d - 1) + 365 * y 'current month days passed + 365 days per each standard year
d = d + (y + 2) \ 4 'add in days for leap years passed
s = d * 24 * 60 * 60 'Seconds are days * 24 hours * 60 minutes * 60 seconds
ExtendedTimer## = (s + TIMER)
END FUNCTION
$END IF
ExtendedTimer is something which I use in a lot of code, and as such, it gets included into a lot of libraries. By coding it like this, QB64 only includes it in my programs once -- no matter how many libraries it's contained within -- and doesn't toss me "Name already in use" errors and whatnot."
It's a simple enough little habit to get into using with our library code, and it'll prevent the issues with duplicate copies being in multiple libraries.
![[Image: Screenshot-616.png]](https://i.ibb.co/5LJwZTn/Screenshot-616.png)
![[Image: Screenshot-611.png]](https://i.ibb.co/DR25HpY/Screenshot-611.png)
![[Image: Screenshot-610.png]](https://i.ibb.co/FqkSCbJ/Screenshot-610.png)
