(11-09-2024, 01:21 AM)bplus Wrote:

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

(11-09-2024, 03:53 PM)bplus Wrote: RE: vince comments on bounce
Yes the bounce is not completely satifactory, specially seen at the top pin and some first bounces are off. I am droppingf balls with slight angle which should reduce decisions at pin tops. Honestly I was happy to tweak it enough for the extreme slots to have some change of a ball passing through.

@PhilOfPerth game? this strikes me more as one of those screen savers that's hard to stop watching. Something about watching that ball make it's way down the board, you never can tell where it's going to end up.

This was a Christmas app at one point in time:

Code: (Select All)

Option _Explicit
_Title "Bonkers Synphony #37 (2019 Xmas Update)         press spacebar for different view"
'2019-11-24 complete overhall for Xmas 2019 B+ from
' Bonkers Symphony no 37.bas for QB64 fork (B+=MGA) trans 2017-09-15 from
' from: Bonkers Symphony Number 37.bas  SmallBASIC 0.12.8 [B+=MGA] 2017-04-21

Const xmax = 1000, ymax = 740
Const nB = 12, gravity = 4, speed = 12
Const maxLRow = 9 'lights
Type ballType
    x As Single
    y As Single
    r As Single
    a As Single
    c As Integer
    rr As Integer
    gg As Integer
    bb As Integer
End Type
Dim Shared nL
ReDim Shared L(0) As ballType, B(0) As ballType

Randomize Timer
Screen _NewImage(xmax, ymax, 32)
_ScreenMove 300, 0
Dim lc, nx, i, j, clrMode, dx, dy 'screen and "tree"

ReDim B(1 To nB) As ballType
For i = 1 To nB
    newBall i
Next
initLights
drawLandscape
clrMode = 0: nx = 1
While _KeyDown(27) = 0
    lc = (lc + 1) Mod 24000
    If _KeyHit = 32 Then
        clrMode = 1 - clrMode
        Cls
        For i = 1 To nB
            newBall i
        Next
        initLights
        drawLandscape
        nx = 0
    End If
    If clrMode Then Line (0, 0)-(xmax, ymax), _RGBA32(0, 0, 0, 5), BF

    'draw lights
    For i = 1 To nL
        drawOrb L(i).x, L(i).y, L(i).r, L(i).rr, L(i).gg, L(i).bb, 0
    Next
    If lc Mod 100 = 0 Then nx = nx + 1
    If nx > nB Then nx = nB

    'calc collsions
    For i = 1 To nx
        For j = 1 To nL
            If Sqr((B(i).x - L(j).x) ^ 2 + (B(i).y - L(j).y) ^ 2) < B(i).r + L(j).r Then
                B(i).a = _Atan2(B(i).y - L(j).y, B(i).x - L(j).x)
                L(j).c = L(j).c + 1
                If L(j).c > 5 Then L(j).a = 1 - L(j).a: L(j).c = 0
                snd L(j).y / ymax * maxLRow, L(j).x / xmax
                If L(j).a = 0 Then
                    drawOrb L(j).x, L(j).y, L(j).r, L(j).rr, L(j).gg, L(j).bb, 1
                    Exit For
                ElseIf L(j).a Then
                    drawOrb L(j).x, L(j).y, L(j).r, L(j).rr, L(j).gg, L(j).bb, 3
                    Exit For
                End If
            End If
        Next
        For j = i + 1 To nx
            If j <> i And B(j).c <> 1 Then
                If Sqr((B(i).x - B(j).x) ^ 2 + (B(i).y - B(j).y) ^ 2) < B(i).r + B(j).r Then
                    B(i).a = _Atan2(B(i).y - B(j).y, B(i).x - B(j).x)
                    B(j).a = _Atan2(B(j).y - B(i).y, B(j).x - B(i).x)
                    B(i).c = 1: B(j).c = 1
                    Exit For
                End If
            End If
        Next

        'update balls
        dx = Cos(B(i).a) * speed
        dy = Sin(B(i).a) * speed + gravity
        B(i).a = _Atan2(dy, dx)
        B(i).x = B(i).x + dx
        B(i).y = B(i).y + dy

        If B(i).x < 0 Or B(i).x > xmax Or B(i).y > ymax Then
            newBall i
        End If
        'IF B(i).a > _PI(2) THEN B(i).a = B(i).a - _PI(2)
        'IF B(i).a < 0 THEN B(i).a = B(i).a + _PI(2)

        drawOrb B(i).x, B(i).y, B(i).r, B(i).rr, B(i).gg, B(i).bb, 2
        B(i).c = 0
    Next
    _Display
    _Limit 20
Wend

Sub newBall (i)
    If Rnd < .5 Then B(i).x = irnd(xmax / 2 - 30, xmax / 2 - 5) Else B(i).x = irnd(xmax / 2 + 5, xmax / 2 + 30)
    B(i).y = irnd(-100, -10)
    B(i).r = irnd(3, 10)
    B(i).a = _Pi(.5) + _Pi(1 / 90) * rdir
    B(i).gg = irnd(60, 120)
    B(i).rr = irnd(0, .5 * B(i).gg)
    B(i).bb = irnd(0, .4 * B(i).gg)
End Sub

Sub initLights
    Dim i, lxo, lyo, row, col, y
    nL = maxLRow * (maxLRow + 1) * .5
    lxo = xmax / (maxLRow + 1)
    lyo = (ymax - 5 * (maxLRow + 1) * maxLRow / 2) / (maxLRow + 1) 'more space for lower rows
    ReDim L(1 To nL) As ballType
    i = 0: y = 0
    For row = 1 To maxLRow
        y = y + lyo + 5 * row 'more space for lower rows
        For col = 1 To row
            i = i + 1
            L(i).x = lxo * col + (maxLRow - row) * .5 * lxo + irnd(-3 * row, 3 * row)
            L(i).y = y + irnd(-15, 15)
            L(i).r = 6 + irnd(row, row + 6) 'bigger for lower rows
            L(i).rr = irnd(128, 255) 'red lights are great!
            L(i).gg = irnd(128, 255) * irnd(0, 1) 'get rid of two many mixes
            L(i).bb = irnd(128, 255) * irnd(0, 1)
        Next
    Next
End Sub

Sub drawOrb (x, y, r, red, green, blue, litMode) 'make sphere if lit or not
    Dim rr
    If litMode = 1 Then
        fcirc x, y, r, _RGB32(red, green, blue)
        For rr = 36 To 0 Step -2
            fcirc x, y, rr, _RGBA32(255, 255, 255, 1)
        Next
    ElseIf litMode = 0 Then
        For rr = r To 0 Step -1
            fcirc x, y, rr, _RGB32(red - rr * 7, green - rr * 7, blue - rr * 7)
        Next
    ElseIf litMode = 2 Then
        For rr = r To 0 Step -1
            fcirc x, y, rr, _RGB32(red * (1 - rr / r), green * (1 - rr / r), blue * (1 - rr / r))
        Next
    ElseIf litMode = 3 Then
        fcirc x, y, r, _RGB32(red, green, blue)
        For rr = 36 To 0 Step -2
            fcirc x, y, rr, _RGBA32(0, 0, 0, 2)
        Next
    End If
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

Sub snd (frq, dur)
    Sound 314.1592654 * (maxLRow - frq) + 220, dur + Rnd * .3
End Sub

Sub drawLandscape 'needs midInk, irnd
    Dim i As Integer, startH As Single, rr As Integer, gg As Integer, bb As Integer
    Dim mountain As Integer, Xright As Single, y As Single, upDown As Single, range As Single
    Dim lastx As Single, X As Integer
    'the sky
    For i = 0 To ymax
        midInk 0, 0, 25, 14, 0, 44, i / ymax
        Line (0, i)-(xmax, i)
    Next
    'the land
    startH = ymax - 400
    rr = 40: gg = 50: bb = 60
    For mountain = 1 To 6
        Xright = 0
        y = startH
        While Xright < xmax
            ' upDown = local up / down over range, change along Y
            ' range = how far up / down, along X
            upDown = (Rnd * .8 - .35) * (mountain * .5)
            range = Xright + irnd(15, 25) * 2.5 / mountain
            lastx = Xright - 1
            For X = Xright To range
                y = y + upDown
                Color _RGB(rr, gg, bb)
                Line (lastx, y)-(X, ymax), , BF 'just lines weren't filling right
                lastx = X
            Next
            Xright = range
        Wend
        rr = irnd(rr - 15, rr): gg = irnd(gg - 15, gg): bb = irnd(bb - 25, bb)
        If rr < 0 Then rr = 0
        If gg < 0 Then gg = 0
        If bb < 0 Then bb = 0
        startH = startH + irnd(5, 20)
    Next
End Sub

Sub midInk (r1%, g1%, b1%, r2%, g2%, b2%, fr##)
    Color _RGB32(r1% + (r2% - r1%) * fr##, g1% + (g2% - g1%) * fr##, b1% + (b2% - b1%) * fr##)
End Sub

Function irnd (n1, n2) 'return random in interval
    Dim l, h
    If n1 > n2 Then l = n2: h = n1 Else l = n1: h = n2
    irnd = Rnd * (h - l) + l
End Function

Function rdir ()
    If Rnd < .5 Then rdir = -1 Else rdir = 1
End Function

I saw vince version of Plinko and realized I was almost there with it!