Combining old Bonker's Symphony #37 and Bplus Plinko, I came up with this to start the season early:
Code: (Select All)
Option _Explicit
_Title "bplus Plinko Christmas Theme" ' b+ 2024-11-09 messing around with speed and gravity
' from bplus Plinko to Christmas version
Const XMax = 800
Const YMax = 720
Dim Shared BX, BY, BA, BCnt
Dim gravity, br, speed, pR, maxRow, np, pxo, pyo, row, col
Dim pidx, i, r, j, dx, dy, slotSpace, slot, score, backg
Dim slots(11), s$, f32 As Long, f16 As Long
Screen _NewImage(XMax, YMax, 32): _ScreenMove 250, 0
Randomize Timer: _PrintMode _KeepBackground
f32 = _LoadFont("arial.ttf", 32)
f16 = _LoadFont("arial.ttf", 20)
gravity = 2.0: slotSpace = XMax / 12
br = 24: speed = 3.75 'balls ' speed orig 4.0 4.0 keeps payout for 1000 balls low 300$
pR = 9: maxRow = 11: np = maxRow * (maxRow + 1) * .5 - 3 ' pins
pxo = XMax / (maxRow + 1) 'pin space along x
pyo = YMax / (maxRow + 1) 'pin spacing along y
Dim px(np), py(np), pc(np) As _Unsigned Long
For row = 3 To maxRow
For col = 1 To row
pidx = pidx + 1
px(pidx) = pxo * col + (maxRow - row) * .5 * pxo
py(pidx) = pyo * row
pc(pidx) = _RGB32(Rnd * 100 + 155, (pidx Mod 2) * (Rnd * 155 + 100), 0)
Next
Next
backg = BackImageHandle&: _PutImage , backg, 0: NewBall
While 1
' clear top score line
_PutImage (0, 0)-(_Width, 60), backg, 0, (0, 0)-(_Width, 60)
' clear bottom text area
_PutImage (0, _Height - 45)-(_Width, _Height), backg, 0, (0, _Height - 45)-(_Width, _Height)
For i = 1 To np ' draw pins
FC3 px(i), py(i), pR, pc(i)
FC3 px(i), py(i), 6, &H88999999
FC3 px(i), py(i), 2, &H88FFFFFF
Next
For j = 1 To np ' calc collsions
If Sqr((BX - px(j)) ^ 2 + (BY - py(j)) ^ 2) < br + pR Then
BA = _Atan2(BY - py(j), BX - px(j))
FC3 px(j), py(j), pR, &HFF000000
Sound 120 + (YMax - py(j)) / YMax * 2000, .25
Exit For
End If
Next
dx = Cos(BA) * speed: dy = Sin(BA) * speed + gravity ' update ball
BA = _Atan2(dy, dx)
BX = BX + Cos(BA) * speed: BY = BY + Sin(BA) * speed ' + 2 * Rnd - 1
If BX < br Or BX > XMax + br Or BY > YMax + br Then
slot = Int(BX / slotSpace): slots(slot) = slots(slot) + 1
BCnt = BCnt + 1: NewBall ' Now the time is right to count a ball
End If
For r = br To 1 Step -1
FC3 BX, BY, r, _RGB32(0, 255 - (r / br) * 220, 0)
Next
score = 0: Color &HFF990000 ' recalc and display slot counts and score
For i = 0 To 11
Select Case i
Case 0: s$ = " "
Case 11: s$ = " "
Case 1: score = score + slots(1) * 100: s$ = "x100$"
Case 10: score = score + slots(10) * 100: s$ = "x100$"
Case 2: score = score + slots(2) * 10: s$ = "x10$"
Case 9: score = score + slots(9) * 10: s$ = "x10$"
Case 3: score = score + slots(3) * 2: s$ = "x2$"
Case 8: score = score + slots(8) * 2: s$ = "x2$"
Case 4: score = score + slots(4) * 0: s$ = "x0$"
Case 7: score = score + slots(7) * 0: s$ = "x0$"
Case 5: score = score + slots(5) * -1: s$ = "x-1$"
Case 6: score = score + slots(6) * -1: s$ = "x-1$"
End Select
centerText i * slotSpace, (i + 1) * slotSpace, _Height - 30, _Trim$(Str$(slots(i)))
centerText i * slotSpace, (i + 1) * slotSpace, _Height - 10, s$
Next
Color &HFFFFFFFF: s$ = "Balls:" + Str$(BCnt) + " Score: $" + _Trim$(Str$(score))
_Font f32: centerText 0, _Width, 35, s$: _Font f16: _Display: _Limit 30
Wend
Sub NewBall ' get ready to drop
BX = XMax / 2 + 10 * Rnd - 5: BY = 150 - Rnd * 20
BA = _Pi(.5) + _Pi(2 / 90) * Rnd - _Pi(.9999 / 90)
End Sub
Sub FC3 (cx As Long, cy As Long, r As Long, clr~&) ' new fill circle
Dim As Long r2, x, y ' for Option _Explicit
If r < 1 Then Exit Sub
Line (cx - r, cy)-(cx + r, cy), clr~&, BF
r2 = r * r
Do
y = y + 1: x = Sqr(r2 - y * y)
Line (cx - x, cy + y)-(cx + x, cy + y), clr~&, BF
Line (cx - x, cy - y)-(cx + x, cy - y), clr~&, BF
Loop Until y = r
End Sub
Sub centerText (x1, x2, midy, s$) ' fit a string between two goal posts x1, and x2
_PrintString ((x1 + x2) / 2 - _PrintWidth(s$) / 2, midy - _FontHeight(_Font) / 2), s$
End Sub
Function BackImageHandle& ' make background image and return it's handle
Dim As Long horizon, nStars, i, back, land, cc
horizon = YMax - 45: nStars = 150 ' making the stars
Dim xstar(nStars), ystar(nStars), rstar(nStars)
For i = 1 To nStars
xstar(i) = Rnd * (XMax): ystar(i) = Rnd * horizon
If i < .80 * nStars Then
rstar(i) = 1
ElseIf i < .97 * nStars Then
rstar(i) = 2
Else
rstar(i) = 3
End If
Next
back = _NewImage(_Width, _Height, 32): _Dest back
For i = 0 To horizon ' the nite sky
Line (0, i)-(XMax, i), _RGB32(i / horizon * 70, i / horizon * 22, 60 * (i) / horizon)
Next
land = YMax - horizon ' the winter snow on ground
For i = horizon To YMax
cc = 128 + (i - horizon) / land * 127
Line (0, i)-(XMax, i), _RGB32(cc, cc, cc)
Next
For i = 1 To nStars ' paint the sky with stars
FC3 xstar(i), ystar(i), rstar(i), &HFFEEEEFF
Next
BackImageHandle& = back: _Dest 0
End Function
b = b + ...
