Proggies

[PhilOfPerth]

bplus Plinko

Code: (Select All)

Option _Explicit

_Title "bplus Plinko" ' b+ 2024-11-08

' from

' Bonkers Symphony no 37.bas for QB64 fork (B+=MGA) trans 2017-09-15

' from: Bonkers Symphony Number 37.bas  SmallBASIC 0.12.8 [B+=MGA] 2017-04-21

' looking at vince version I see I am almost there with this one!



Const XMax = 800

Const YMax = 720

Dim Shared BX, BY, BA, BCnt

Randomize Timer

Screen _NewImage(XMax, YMax, 32): _ScreenMove 250, 0

_PrintMode _KeepBackground

Dim gravity, br, speed, pR, maxRow, np, pxo, pyo, row, col

Dim pidx, i, r, j, dx, dy, slotSpace, slot, score

Dim slots(11), s$

gravity = 2.0

slotSpace = XMax / 12

br = 27: speed = 4 'balls

pR = 5: maxRow = 11: np = maxRow * (maxRow + 1) * .5 '  pins

pxo = XMax / (maxRow + 1) 'pin space along x

pyo = YMax / (maxRow + 1) 'pin spacing along y

Dim px(np), py(np)

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

    Next

Next

NewBall

While 1

    Line (0, 0)-(_Width, _Height - 48), &HFF333366, BF

    Line (0, _Height - 48)-(_Width, _Height), &HFF008833, BF

    For i = 1 To np 'draw pins

        For r = pR To 1 Step -1

            FC3 px(i), py(i), r, _RGB32(r / pR * 255)

        Next

    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 * 1000, .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: NewBall

    End If

    For r = br To 1 Step -1

        FC3 BX, BY, r, _RGB32(255 - (r / br) * 160, 0, 0)

    Next

    score = 0

    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

        _PrintString (i * slotSpace + .5 * slotSpace - 16, _Height - 40), Str$(slots(i))

        _PrintString (i * slotSpace + .5 * slotSpace - 16, _Height - 20), s$

    Next

    _PrintString (30, 30), "Balls:" + Str$(BCnt) + "    Score: $" + _Trim$(Str$(score))

    _Display: _Limit 30

Wend



Sub NewBall

    BX = XMax / 2 + 10 * Rnd - 5: BY = 0 - Rnd * 20: BCnt = BCnt + 1

    BA = _Pi(.5) + _Pi(2 / 90) * Rnd - _Pi(.9999 / 90)

End Sub



Sub FC3 (cx As Long, cy As Long, r As Long, clr~&)

    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

Another fascinating base for a game! Can't wait to see what you do with this one!
Edit: Sorry, Vince, missed your post earlier about this game.