Click Away Balls

[bplus]

We don't need no font to draw larger numbers! Just a nice little Sub:

Code: (Select All)

_Title "Click Away Balls" ' 2022-05-13 needs arial.ttf font
' new: speed increases, added timer by Dav, DEC/2020
' 2022-05-13 fix so that lowest balls are drawn, overhaul code b+

' ===========================================================================================================

'       Click on balls in order, starting at 1 until all gone, before the timer runs out.

'        Hints: the lower the ball # the slower it moves, click into place ball is moving

' ===========================================================================================================

Randomize Timer
Screen _NewImage(800, 600, 32)
_Delay .25
_ScreenMove _Middle
_PrintMode _KeepBackground

balls = 15: size = 40: speed = 3
Dim BallX(balls), BallY(balls), BallDx(balls), BallDy(balls), BallSize(balls), BallShow(balls), BallC(balls) As _Unsigned Long
w = _Width: h = _Height: w2 = _Width / 2: h2 = _Height / 2

restart:

'Generate random ball data
For B = balls To 1 Step -1
    BallSize(B) = 40 + (Rnd * 30)
    BallX(B) = BallSize(B) + Rnd * (w - 2 * BallSize(B))
    BallY(B) = BallSize(B) + Rnd * (h - 2 * BallSize(B))
    a = Rnd * _Pi(2): Ballspeed = 2 + B
    BallDx(B) = Ballspeed * Cos(a)
    BallDy(B) = Ballspeed * Sin(a)
    BallShow(B) = 1
    BallC(B) = _RGB32(100 + Rnd * 150, 100 + Rnd * 150, 100 + Rnd * 150)
Next

' initialize
curBall = 1: gametime = Timer: timelimit = 35
Do
    Cls
    'compute ball movement
    For t = balls To 1 Step -1
        BallX(t) = BallX(t) + BallDx(t) 'move ball then make sure in bounds
        BallY(t) = BallY(t) + BallDy(t)
        If BallX(t) > w - BallSize(t) Then BallDx(t) = -BallDx(t): BallX(t) = w - BallSize(t)
        If BallX(t) < BallSize(t) Then BallDx(t) = -BallDx(t): BallX(t) = BallSize(t)
        If BallY(t) > h - BallSize(t) Then BallDy(t) = -BallDy(t): BallY(t) = h - BallSize(t)
        If BallY(t) < BallSize(t) Then BallDy(t) = -BallDy(t): BallY(t) = BallSize(t)
    Next

    ' curBall clicked
    While _MouseInput: Wend
    mb = _MouseButton(1): mx = _MouseX: my = _MouseY
    If mb Then
        If Sqr((mx - BallX(curBall)) ^ 2 + (my - BallY(curBall)) ^ 2) < BallSize(curBall) Then
            BallShow(curBall) = 0
            Play "mbl32o2ceg"
            curBall = curBall + 1
        End If
    End If

    'draw all stuff
    For x = 0 To w Step 4
        For y = 0 To h Step 4
            r = Sin(1.1 * t) * h2 - y + h2
            Line (x, y)-Step(3, 3), _RGB(r, r - y, -r), BF
        Next
    Next
    For i = balls To 1 Step -1
        If BallShow(i) = 1 Then
            drawBall BallX(i), BallY(i), BallSize(i), BallC(i)
            Text BallX(i) - 15, BallY(i) - 15, 30, &HFFFFFFFF, Right$("0" + _Trim$(Str$(i)), 2)
            '_PrintString (BallX(i) - 15, BallY(i) - 15), Right$("0" + _Trim$(Str$(i)), 2)
        End If
    Next
    Locate 1, 1: Print "Click ball.."; curBall;
    Locate 2, 1: Print timelimit - Int(Timer - gametime);
    _Display
    _Limit 30

    ' game over ?
    If curBall > 15 Then ' success
        Play "o2l16cegagfefgabgc3l4"
        _Delay 2
        GoTo restart
    ElseIf Timer - gametime > timelimit Then ' fail
        Play "mbo1l4dl8ddl4dl8feeddc#l2d"
        _Delay 2
        GoTo restart
    End If
Loop

Sub drawBall (x, y, r, c As _Unsigned Long)
    Dim rred As Long, grn As Long, blu As Long, rr As Long, f
    rred = _Red32(c): grn = _Green32(c): blu = _Blue32(c)
    For rr = r To 0 Step -1
        f = 1 - rr / r
        fcirc x, y, rr, _RGB32(rred * f, grn * f, blu * f)
    Next
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 Text (x, y, textHeight, K As _Unsigned Long, txt$)
    Dim fg As _Unsigned Long, cur&, I&, multi, xlen
    fg = _DefaultColor
    cur& = _Dest
    I& = _NewImage(8 * Len(txt$), 16, 32)
    _Dest I&
    Color K, _RGBA32(0, 0, 0, 0)
    _PrintString (0, 0), txt$
    multi = textHeight / 16
    xlen = Len(txt$) * 8 * multi
    _PutImage (x, y)-Step(xlen, textHeight), I&, cur&
    Color fg
    _FreeImage I&
End Sub