BallDraw - simple drawing programing using colored balls

[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!