BallDraw - simple drawing programing using colored balls

[Dav]

Had some time to play with QB64PE today.  Just for fun I put together a few routines previously made and this drawing thing is the result.  Used the dust/particle system I made in the ballshoot game (changed it to use balls here), and a simple plasma pattern for the canvas image, and used the 'fc' filled circle SUB to draw the balls fast.

Use the mouse right button to draw lines of balls on the screen.  SPACE clears screen, ESC quits.

It a simple program, just having a little QB64PE creative coding fun (been a long while....).  I always seem to start with balls when I get back into coding for some reason.

- Dav

Code: (Select All)

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

'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

[bplus]

Ah I have one covered in dust from 2017!

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

For Veterans Day!

[Dav]

Ah, cool, bplus!  I’ll play with that when I get back home. I’m off to play for a veterans day dinner this very moment.

Happy Veterans day!

- Dav