Thread Rating:
  • 0 Vote(s) - 0 Average
  • 1
  • 2
  • 3
  • 4
  • 5
Bumper ball game (like plinko).
#1
This is more of a prototype for a bigger game, but it works enough to play and try out.  It's like a plinko game, you position the ball, let it drop and try to make it stop on the winning area.

Use arrow keys to move the ball left/right.  When ready to drop the ball press ENTER.  The ball will bounce off the bumpers.  The goal is to make the ball stop on the green winners pad at the bottom.

Right now the bumpers are positioned random, not always good, but it would be easy to design a screen, make shapes (lines with slopes) out of the bumpers too.

- Dav

   

Code: (Select All)
'==============
'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

Find my programs here in Dav's QB64 Corner
Reply
#2
Ah! that reminds me of this:
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

@Dav you (or @Petr), musician and sound guy, could maybe turn the unholy sound from Bonker's Symphony Number 37 and make it sound sweet like Silent Night???

   
Good thing I can't/don't play a recording of the sound Tongue

Possibly each line of lights = notes of a Chord?
b = b + ...
Reply
#3
Hey that's pretty.  I'll play with it a while.  I did an quick experiment, had each ding play part of a silentnight song, but it was too jerky that way.  Also try having it just play the song in the backgroud, but then the SOUND dings didn't sound.  Maybe a doing it by row is a better idea.  It would be neat to assign every ornament a note, and have them ring out a song that way, like a handbell choir.  Our perhaps I can whip up a soundfile to use for it, SNDPLAY can bell many sounds at the same time.  I'll chew on this one.  Maybe have it by Christmas? Big Grin 

- Dav

Find my programs here in Dav's QB64 Corner
Reply
#4
Christmas cool! I'll work on the snow Smile
b = b + ...
Reply




Users browsing this thread: 1 Guest(s)