bplus Plinko Christmas Theme

[bplus]

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

   

[Pete]

Well that's ingenious. +2

Pete