Improved my small Gradient Ball drawing SUB

[James D Jarvis]

playing about with this last night, no claims of "improvement". A wee bit of interaction with key presses.

Code: (Select All)

'v bubbles
'$dynamic
Screen _NewImage(800, 600, 32)

Dim Shared Points: Points = 50
Dim Shared PointX(Points), PointY(Points), PointR(Points), PointG(Points), PointB(Points)
Randomize Timer

For p = 1 To Points
    PointX(p) = Rnd * _Width
    PointY(p) = Rnd * _Height
    PointR(p) = 50 + Rnd * 60
    PointG(p) = 60 + Rnd * 80
    PointB(p) = 70 + Rnd * 100
Next
wr = 4 'wiggle ratio
Do
    _Limit 50000 'experiment with the value that works for you and keeps your computer from metling
    For p = 1 To Points
        PointX(p) = PointX(p) + Rnd * wr - Rnd * wr
        PointY(p) = PointY(p) + Rnd * wr - Rnd * wr
        PointR(p) = PointR(p) + Rnd * 3 - Rnd * 3
        PointG(p) = PointG(p) + Rnd * 3 - Rnd * 3
        PointB(p) = PointB(p) + Rnd * 3 - Rnd * 3
    Next
    For y = 0 To _Height Step 4 'skipping points of calcualtion to speed things along
        For x = 0 To _Width Step 4
            min = Sqr((x - PointX(1)) ^ 2 + (y - PointY(1)) ^ 2)
            closest = 1
            For p = Points To 2 Step -1

                dis = Sqr((x - PointX(p)) ^ 2 + (y - PointY(p)) ^ 2)
                If dis < min Then
                    min = dis
                    closest = p
                End If
            Next
            'circlefill? Yes circle fill because it's quicker in getting that screen filled
            CircleFill x, y, 3, _RGB(PointR(closest) - min, PointG(closest) - min, PointB(closest) - min)

        Next
    Next
    kk$ = InKey$
    Select Case (kk$)
        Case "C", "c" 'change the pattern
            For p = 1 To Points
                PointX(p) = Rnd * _Width
                PointY(p) = Rnd * _Height
                PointR(p) = 50 + Rnd * 60
                PointG(p) = 60 + Rnd * 80
                PointB(p) = 70 + Rnd * 100
            Next
        Case "<", "," 'slower wiggle
            wr = wr - .5
            If wr < 0 Then wr = 0
        Case ">", "." 'quicker wiggle
            wr = wr + .5
        Case "R" 'more red
            For p = 1 To Points
                PointR(p) = PointR(p) + (1 + Rnd * 6)
            Next
        Case "r" 'less red
            For p = 1 To Points
                PointR(p) = PointR(p) - (1 + Rnd * 6)
            Next 'more green
        Case "G"
            For p = 1 To Points
                PointG(p) = PointG(p) + (1 + Rnd * 6)
            Next
        Case "g" 'less green
            For p = 1 To Points
                PointG(p) = PointG(p) - (1 + Rnd * 6)

            Next
        Case "B" 'more blue
            For p = 1 To Points
                PointB(p) = PointB(p) + (1 + Rnd * 6)
            Next
        Case "b" 'less blue
            For p = 1 To Points
                PointB(p) = PointB(p) - (1 + Rnd * 6)
            Next
        Case "M" 'more points
            Points = Points + 1
            ReDim _Preserve PointX(Points), PointY(Points), PointR(Points), PointG(Points), PointB(Points)
            PointX(Points) = Rnd * _Width
            PointY(Points) = Rnd * _Height
            PointR(Points) = 50 + Rnd * 60
            PointG(Points) = 60 + Rnd * 80
            PointB(Points) = 70 + Rnd * 100
        Case "m" 'less points
            If Points > 20 Then
                Points = Points - 1
                ReDim _Preserve PointX(Points), PointY(Points), PointR(Points), PointG(Points), PointB(Points)
            End If

    End Select
    _Display
Loop Until kk$ = Chr$(27)
Sub CircleFill (CX As Integer, CY As Integer, R As Integer, C As _Unsigned Long)
    ' CX = center x coordinate
    ' CY = center y coordinate
    '  R = radius
    '  C = fill color
    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