BallDraw - simple drawing programing using colored balls

'============ 'BallDraw.bas '============ 'Coded by Dav, NOV/2025 'Simple ball drawing program, draws colored balls. 'SPACE clears screen, ESC quits. Randomize Timer Screen _NewImage(_DesktopHeight, Int(_DesktopHeight * .75), 32) canvas& = _NewImage(_DesktopHeight, Int(_DesktopHeight * .75), 32) _Title "BALLDRAW: Use Mouse to draw, SPACE clears, ESC ends" MaxBalls = 1000 BallCount = 0 gravity = .1 strength = 4 Dim Ballx(MaxBalls), Bally(MaxBalls) Dim BallXvel(MaxBalls), BallYvel(MaxBalls), BallRadius(MaxBalls) Dim BallRed(MaxBalls), BallBlue(MaxBalls), BallGreen(MaxBalls), BallAlpha(MaxBalls) '========= startover: '========= 'Draw pretty background on canvas image _Dest canvas& For y = 0 To _Height Step 3 For x = 0 To _Width Step 3 r = Int(128 + 127 * Sin(x / 15) + 127 * Cos(y / 15)) g = Int(128 + 127 * Sin(x / 25 * 1.5) + 127 * Cos(y / 25 * 1.5)) b = Int(128 + 127 * Sin(x / 35 * 2) + 127 * Cos(y / 35 * 2)) Line (x, y)-Step(2, 2), _RGBA(r / 3, g / 3, b / 3, 100), BF Next Next 'back to main screen, do main loop _Dest 0 Do _PutImage (0, 0), canvas& 'put canvas image on main screen first While _MouseInput: Wend If _MouseButton(1) Then 'draw a ball on canvas image _Dest canvas& fc _MouseX, _MouseY, 8 + (Rnd * 7), _RGBA(Rnd * 255, Rnd * 255, Rnd * 255, 255), 1 _Dest 0 For i = 1 To strength If BallCount < MaxBalls Then BallCount = BallCount + 1 Ballx(BallCount) = _MouseX Bally(BallCount) = _MouseY BallXvel(BallCount) = Rnd * 5 - 2.5 BallYvel(BallCount) = Rnd * 5 - 2.5 BallRadius(BallCount) = 15 BallRed(BallCount) = Rnd * 255 BallGreen(BallCount) = Rnd * 255 BallBlue(BallCount) = Rnd * 255 BallAlpha(BallCount) = 255 End If Next End If 'draw balls For i = 1 To BallCount BallYvel(i) = BallYvel(i) + gravity Ballx(i) = Ballx(i) + BallXvel(i) Bally(i) = Bally(i) + BallYvel(i) If BallAlpha(i) > 0 Then fc Ballx(i), Bally(i), BallRadius(i), _RGBA(BallRed(i), BallGreen(i), BallBlue(i), BallAlpha(i)), 0 BallRadius(i) = BallRadius(i) * .96 'radius shrink rate BallAlpha(i) = BallAlpha(i) - 2 End If Next 'clean out balls fully faded out or too small For i = BallCount To 1 Step -1 If BallAlpha(i) <= 0 Or BallRadius(i) < 1 Then BallCount = BallCount - 1 For j = i To BallCount Ballx(j) = Ballx(j + 1) Bally(j) = Bally(j + 1) BallXvel(j) = BallXvel(j + 1) BallYvel(j) = BallYvel(j + 1) BallRadius(j) = BallRadius(j + 1) BallRed(j) = BallRed(j + 1) BallGreen(j) = BallGreen(j + 1) BallBlue(j) = BallBlue(j + 1) BallAlpha(j) = BallAlpha(j + 1) Next End If Next k$ = InKey$ If k$ = " " Then _Dest canvas&: Cls: _Dest 0: Cls GoTo startover End If If k$ = Chr$(27) Then Exit Do _Display _Limit 30 Loop Sub fc (cx As Integer, cy As Integer, radius As Integer, 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 = Abs(Sqr(r2 - y * y)) 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)

_Title "Paint Balls, press h for help"

'QB64 version 2017 1106/82 (the day before they switched to version 1.2)



'2018-07-02 translated to QB64 from

'paint balls v1.bas SmallBASIC 2015-05-28 MGA/B+



Const xmax = 1200

Const ymax = 700

Dim Shared pi

pi = _Pi

Screen _NewImage(xmax, ymax, 32)

_ScreenMove 100, 20

Dim Shared cx$

Randomize Timer



cx$ = "r"

help

While 1

    Do While _MouseInput

        mx = _MouseX

        my = _MouseY

        mb = _MouseButton(1)

    Loop

    If mb Then ball mx, my

    k$ = InKey$

    If Len(k$) Then

        If InStr("rbgyvwcok", k$) > 0 Then cx$ = k$

        If k$ = "h" Then help

        If k$ = "q" Then End

    End If

    _Limit 60

Wend



Sub help ()

    s$ = Space$(5): s3$ = Space$(3)

    Cls

    Print: Print s$ + "PAINT BALLS - 9 COLORS KEYS:": Print

    Print s$ + "The 2 hard ones to remember first:"

    Print s3$ + "c = cyan (gray)"

    Print s3$ + "k = blacK (dark gray)"

    Print: Print s$ + "The 7 easy ones (for English speaking people anyway):"

    Print s3$ + "r = red,    g = green,  b = blue"

    Print s3$ + "y = yellow, o = orange, w = white, v =violet"

    Print: Print s$ + "PAINT BALLS - OTHER KEYS MENU:"

    Print s3$ + "h = help (this screen), it also clears the drawing screen to black"

    Print s3$ + "q = quit"

    Print: Print s3$ + "Current Color set at "; cx$

    Print: Input "   OK, ready to paint? press enter...", d$

    Cls

End Sub



Sub ball (x, y)

    For r = 32 To 0 Step -1

        Select Case cx$

            Case "r": Color _RGB32(255 - 6 * r, 0, 0)

            Case "b": Color _RGB32(0, 0, 255 - 6 * r)

            Case "g": Color _RGB32(0, 220 - 6 * r, 0)

            Case "o": Color _RGB32(255 - 3 * r, 180 - 4 * r, 0)

            Case "y": Color _RGB32(255 - 4 * r, 255 - 4 * r, 0)

            Case "v": Color _RGB32(255 - 7 * r, 0, 255 - 7 * r)

            Case "w": Color _RGB32(255 - 4 * r, 255 - 4 * r, 255 - 4 * r)

            Case "c": Color _RGB32(0, 196 - 3 * r, 196 - 3 * r)

            Case "k": Color _RGB32(128 - 4 * r, 128 - 4 * r, 128 - 4 * r)

        End Select

        fcirc x, y, r

    Next

End Sub





Sub wait4Press ()

    Do

        k = _KeyHit

        While _MouseInput: Wend

        _Limit 30

    Loop Until k <> 0 Or _MouseButton(1)

End Sub



Sub changePlasma ()

    cN = cN + 1

    Color _RGB(127 + 127 * Sin(pR * cN), 127 + 127 * Sin(pG * cN), 127 + 127 * Sin(pB * cN))

End Sub



Sub resetPlasma ()

    pR = Rnd ^ 2: pG = Rnd ^ 2: pB = Rnd ^ 2

End Sub



Sub midInk (r1%, g1%, b1%, r2%, g2%, b2%, fr##)

    Color _RGB(r1% + (r2% - r1%) * fr##, g1% + (g2% - g1%) * fr##, b1% + (b2% - b1%) * fr##)

End Sub



Function rand% (lo%, hi%)

    rand% = Int(Rnd * (hi% - lo% + 1)) + lo%

End Function



Function rdir% ()

    If Rnd < .5 Then rdir% = -1 Else rdir% = 1

End Function



Function dist# (x1%, y1%, x2%, y2%)

    dist# = ((x1% - x2%) ^ 2 + (y1% - y2%) ^ 2) ^ .5

End Function



Function rclr&& ()

    rclr&& = _RGB(rand(64, 255), rand(64, 255), rand(64, 255))

End Function



'Steve McNeil's  copied from his forum   note: Radius is too common a name

Sub fcirc (CX As Long, CY As Long, R As Long)

    Dim subRadius As Long, RadiusError As Long

    Dim X As Long, Y As Long



    subRadius = Abs(R)

    RadiusError = -subRadius

    X = subRadius

    Y = 0



    If subRadius = 0 Then PSet (CX, CY): Exit Sub



    ' Draw the middle span here so we don't draw it twice in the main loop,

    ' which would be a problem with blending turned on.

    Line (CX - X, CY)-(CX + X, CY), , 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), , BF

                Line (CX - Y, CY + X)-(CX + Y, CY + X), , BF

            End If

            X = X - 1

            RadiusError = RadiusError - X * 2

        End If

        Y = Y + 1

        Line (CX - X, CY - Y)-(CX + X, CY - Y), , BF

        Line (CX - X, CY + Y)-(CX + X, CY + Y), , BF

    Wend

End Sub