Bumper ball game (like plinko).

'============== 'BUMPERBALL.BAS '============== 'Simple drop the ball on the pad game. 'Coded by Dav, SEP/2024 'Use left/right arrows to move the ball. 'Press the ENTER key to drop the ball. 'Try to make the ball stop on the pad. 'ESC key quits. Randomize Timer Screen _NewImage(1000, 800, 32) bumps = 25 'number of bumpers on the screen Dim bumpx(bumps), bumpy(bumps), bumpsize(bumps), ballclr~&(bumps) '=========== restartgame: '=========== 'make random bumper values For b = 1 To bumps bumpsize(b) = 15 'bumper size bumpx(b) = 30 + (Rnd * (_Width - 30)) 'x position 'bumpy(b) = 60 + (Rnd * (_Height - 190)) bumpy(b) = 60 + (b * 25) ballclr~&(b) = _RGBA(0, 0, 255, 255) Next 'init puck to drop pucksize = 30 'puck size puckclr~& = _RGBA(255, 64, 64, 255) 'puck color puckx = _Width / 2 'x position pucky = pucksize 'y position puckxv = 0 'x speed puckyv = 0 'y speed gravity = 0.5 'gravity value 'for timing bouncing stopping puckytimer = 0 'random location for a winning pad padx = Rnd * (_Width - 200) padx2 = padx + 200 pady = _Height - 3 pady2 = 3 '=== loop to move puck until Enter key pressed Do Cls , _RGB(45, 45, 45) 'controls key$ = InKey$ If key$ = Chr$(0) + Chr$(75) Then puckx = puckx - 8 ' Left Arrow If key$ = Chr$(0) + Chr$(77) Then puckx = puckx + 8 ' Right Arrow If key$ = Chr$(13) Then Exit Do 'enter drop puck If key$ = Chr$(27) Then End 'make sure puck stays on screen If puckx < pucksize Then puckx = pucksize If puckx > _Width - pucksize Then puckx = _Width - pucksize 'draw puck fc puckx, pucky, pucksize, puckclr~&, 1 'draw all the bumpers For b = 1 To bumps fc bumpx(b), bumpy(b), bumpsize(b), ballclr~&(b), 1 Next 'draw winning pad Line (padx, pady)-(padx2, pady + pady2), _RGBA(0, 255, 0, 255), BF _Limit 30 _Display Loop 'loop for dropping the puck Do Cls , _RGB(45, 45, 45) 'apply gravity puckyv = puckyv + gravity puckx = puckx + puckxv pucky = pucky + puckyv 'if hits bottom, bounce off If pucky > _Height - pucksize Then If puckyv > .3 Then Play "mbt200l32o1d" pucky = _Height - pucksize puckyv = -puckyv * 0.7 End If 'bounce puck off screen edges If puckx < pucksize Then Play "mbt200l32o1b" puckx = pucksize puckxv = -puckxv * 0.7 End If If puckx > _Width - pucksize Then Play "mbt200l32o1b" puckx = _Width - pucksize puckxv = -puckxv * 0.7 End If 'draw the puck fc puckx, pucky, pucksize, puckclr~&, 1 'draw all the bumpers For b = 1 To bumps fc bumpx(b), bumpy(b), bumpsize(b), ballclr~&(b), 1 'check for puck collisions with bumpers If ((puckx - bumpx(b)) ^ 2 + (pucky - bumpy(b)) ^ 2) < (pucksize + bumpsize(b)) ^ 2 Then fc bumpx(b), bumpy(b), bumpsize(b), _RGBA(255, 255, 0, 255), 1 Play "mbt200o5l32ef" x = (puckx - bumpx(b)): y = (pucky - bumpy(b)) dis = Sqr(x * x + y * y) If dis > 0 Then x = x / dis: y = y / dis End If vr = puckxv * x + puckyv * y puckxv = puckxv - 2 * vr * x puckyv = puckyv - 2 * vr * y over = (pucksize + bumpsize(b)) - Sqr((puckx - bumpx(b)) ^ 2 + (pucky - bumpy(b)) ^ 2) puckx = puckx + x * over pucky = pucky + y * over End If Next 'reduce x velocity so ball doesn't roll on bottom too long If pucky >= _Height - pucksize Then puckxv = puckxv * 0.88 'reduce x velocity End If 'I'm using a timer to see if ball has stopped moving much. 'check if puck is near bottom, and if puckyv hasn't changed since timer If Abs(pucky - (_Height - pucksize)) < 10 Then If Abs(puckyv - lastPuckyv) < .1 Then puckytimer = puckytimer + 0.033 Else puckytimer = 0 End If lastPuckyv = puckyv 'if it's been 2 seconds since puckyv was stable If puckytimer >= 2.0 Then 'if puck is on winning pad If puckx >= padx And puckx <= padx2 Then Line (0, 0)-(_Width, _Height), _RGBA(0, 255, 0, 25), BF Play "mbt120l16o2c,e e,g e,g,o3c" Else Line (0, 0)-(_Width, _Height), _RGBA(255, 0, 0, 25), BF Play "mbt120l16o2b,f e b,f" End If _Display Exit Do End If Else puckytimer = 0 'Reset timer otherwise lastPuckyv = puckyv End If ' Draw winning pad Line (padx, pady)-(padx2, pady + pady2), _RGBA(0, 255, 0, 255), BF _Limit 30 _Display If InKey$ = Chr$(27) Then End Loop _Delay 2 GoTo restartgame Sub fc (cx, cy, radius, clr~&, grad) If radius = 0 Then Exit Sub ' safety bail If grad = 1 Then red = _Red32(clr~&) grn = _Green32(clr~&) blu = _Blue32(clr~&) alpha = _Alpha32(clr~&) End If r2 = radius * radius For y = -radius To radius x = Int(Sqr(r2 - y * y)) ' If doing gradient If grad = 1 Then For i = -x To x dis = Sqr(i * i + y * y) / radius red2 = red * (1 - dis) + (red / 2) * dis grn2 = grn * (1 - dis) + (grn / 2) * dis blu2 = blu * (1 - dis) + (blu / 2) * dis clr2~& = _RGBA(red2, grn2, blu2, alpha) Line (cx + i, cy + y)-(cx + i, cy + y), clr2~&, BF Next Else Line (cx - x, cy + y)-(cx + x, cy + y), clr~&, BF End If Next End Sub

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