color wheel animation / screensaver

[madscijr]

Code: (Select All)

_Title "Color wheel" ' madscijr 2025-04-19

'Const fps = 60
Const cShowValues = _FALSE

Type PointType
    x As Long
    y As Long
    d As Integer
End Type

Dim xmin, ymin As Integer
Dim xmax, ymax As Integer
Dim r, g, b As Long
Dim dr, dg, db As Integer
Dim cv, vr, vg, vb As Integer
Dim OldMouseX, OldMouseY As Integer
Dim arr(1 To 2) As PointType
Dim i As Integer
Dim count As Integer
Dim m$

Randomize Timer
xmin = 0: ymin = 0: xmax = 640: ymax = 480
'xmax = _DesktopWidth - 1: ymax = _DesktopHeight - 1

Screen _NewImage(xmax, ymax, 32)
_FullScreen

_Delay 2 ' wait a couple seconds before getting mouse coords
While _MouseInput: Wend: OldMouseX = _MouseX: OldMouseY = _MouseY ' initial mouse placement

r = 255: g = 0: b = 0
dr = 0: dg = 0: db = 1
cv = 7: vr = cv: vg = cv: vb = cv
arr(1).x = 0: arr(1).y = 0: arr(1).d = 1
arr(2).x = xmax: arr(2).y = ymax: arr(2).d = 3
count = 0

While _KeyDown(27) = 0
    Line (arr(1).x, arr(1).y)-(arr(2).x, arr(2).y), _RGB32(r, g, b)

    For i = 1 To 2
        Select Case arr(i).d
            Case 1:
                arr(i).x = arr(i).x + 1
                If arr(i).x >= xmax Then arr(i).d = 2
            Case 2:
                arr(i).y = arr(i).y + 1
                If arr(i).y >= ymax Then arr(i).d = 3
            Case 3:
                arr(i).x = arr(i).x - 1
                If arr(i).x <= xmin Then arr(i).d = 4
            Case 4:
                arr(i).y = arr(i).y - 1
                If arr(i).y <= ymin Then arr(i).d = 1: count = count + 1
        End Select
    Next i

    'If count = 2 Then Exit While ' exit after one cycle

    ' COLOR CHANGE TRUTH TABLE:

    'RGB DR DG DB
    '0FF  0  0 -1
    '0F-

    '0F0 +1  0  0
    '+F0

    'FF0
    'F-0  0 -1  0

    'F00
    'F0+  0  0 +1

    'F0F
    '-0F -1  0  0

    '00F
    '0+F  0 +1  0

    If dr = 1 And dg = 0 And db = 0 Then
        r = r + vr
        If r >= 255 Then r = 255: dr = 0: dg = -1: db = 0

    ElseIf dr = -1 And dg = 0 And db = 0 Then
        r = r - vr
        If r <= 0 Then r = 0: dr = 0: dg = 1: db = 0

    ElseIf dr = 0 And dg = 1 And db = 0 Then
        g = g + vg
        If g >= 255 Then g = 255: dr = 0: dg = 0: db = -1

    ElseIf dr = 0 And dg = -1 And db = 0 Then
        g = g - vg
        If g <= 0 Then g = 0: dr = 0: dg = 0: db = 1

    ElseIf dr = 0 And dg = 0 And db = 1 Then
        b = b + vb
        If b >= 255 Then b = 255: dr = -1: dg = 0: db = 0

    ElseIf dr = 0 And dg = 0 And db = -1 Then
        b = b - vb
        If b <= 0 Then b = 0: dr = 1: dg = 0: db = 0

    End If

    If cShowValues = _TRUE Then
        Color _RGB32(0, 0, 0), _RGB32(255, 0, 0)
        m$ = "R=" + Right$(String$(3, " ") + _ToStr$(r), 3)
        Locate 2, 3: Print m$;

        Color _RGB32(0, 0, 0), _RGB32(0, 255, 0)
        m$ = "G=" + Right$(String$(3, " ") + _ToStr$(g), 3)
        Locate 2, 9: Print m$;

        Color _RGB32(0, 0, 0), _RGB32(0, 0, 255)
        m$ = "B=" + Right$(String$(3, " ") + _ToStr$(b), 3)
        Locate 2, 15: Print m$;

        Color _RGB32(0, 0, 0), _RGB32(255, 0, 0)
        m$ = "DR=" + Right$(String$(3, " ") + _ToStr$(dr), 3)
        Locate 4, 2: Print m$;

        Color _RGB32(0, 0, 0), _RGB32(0, 255, 0)
        m$ = "DG=" + Right$(String$(3, " ") + _ToStr$(dg), 3)
        Locate 4, 8: Print m$;

        Color _RGB32(0, 0, 0), _RGB32(0, 0, 255)
        m$ = "DB=" + Right$(String$(3, " ") + _ToStr$(db), 3)
        Locate 4, 14: Print m$;
    End If

    ' If user moves mouse, quit
    While _MouseInput: Wend: If _MouseX <> OldMouseX Or _MouseY <> OldMouseY Then Exit While

    _Display
    '_Limit fps
Wend

'_AutoDisplay
'Sleep

System

[madscijr]

Here's a simpler version using HSL color. Still not seeing enough oranges/purples/yellows!
I think timing is the key. 

Code: (Select All)

_Title "Color wheel" ' madscijr 2025-04-19

Const fps = 120
Const cShowValues = _FALSE

Type PointType
    x As Long
    y As Long
    d As Integer
End Type

Dim xmin, ymin As Integer
Dim xmax, ymax As Integer
Dim dx, dy As Integer
Dim OldMouseX, OldMouseY As Integer
Dim arr(1 To 2) As PointType
Dim i As Integer
Dim count As Integer
Dim m$
Dim hue#
Dim dhue#
Dim sat#
Dim dsat#
Dim c~&

Randomize Timer
xmin = 0: ymin = 0: xmax = 640: ymax = 480
'xmax = _DesktopWidth - 1: ymax = _DesktopHeight - 1

Screen _NewImage(xmax, ymax, 32)
_FullScreen

_Delay 2 ' wait a couple seconds before getting mouse coords
While _MouseInput: Wend: OldMouseX = _MouseX: OldMouseY = _MouseY ' initial mouse placement

arr(1).x = 0: arr(1).y = 0: arr(1).d = 1
arr(2).x = xmax: arr(2).y = ymax: arr(2).d = 3
dx = 1: dy = 1
count = 0
hue# = 0
dhue# = 1
sat# = 0
dsat# = -.25

While _KeyDown(27) = 0
    ''color32value~& = _HSBA32(hue#, saturation#, brightness#, alpha#)
    c~& = _HSBA32(hue#, sat#, 100, 100)
    Line (arr(1).x, arr(1).y)-(arr(2).x, arr(2).y), c~&

    For i = 1 To 2
        Select Case arr(i).d
            Case 1:
                arr(i).x = arr(i).x + dx
                If arr(i).x >= xmax Then arr(i).x = xmax: arr(i).d = 2
            Case 2:
                arr(i).y = arr(i).y + dy
                If arr(i).y >= ymax Then arr(i).y = ymax: arr(i).d = 3
            Case 3:
                arr(i).x = arr(i).x - dx
                If arr(i).x <= xmin Then arr(i).x = xmin: arr(i).d = 4
            Case 4:
                arr(i).y = arr(i).y - dy
                If arr(i).y <= ymin Then arr(i).y = ymin: arr(i).d = 1: 'count = count + 1
        End Select
    Next i

    hue# = hue# + dhue#
    If hue# > 359 Then
        hue# = 0
    End If

    sat# = sat# + dsat#
    If sat# <= 0 Then
        sat# = 0: dsat# = -dsat#
    ElseIf dsat# >= 100 Then
        dsat# = 100: dsat# = -dsat#
    End If

    ' If user moves mouse, quit
    While _MouseInput: Wend: If _MouseX <> OldMouseX Or _MouseY <> OldMouseY Then Exit While

    _Display
    '_Limit fps
Wend

'_AutoDisplay
'Sleep

System

[Sprezzo]

ey bud, try this for a color wheel. i promise you wont find it elsewhere unless the AI already scraped me

Code: (Select All)

_Title "Color wheel" ' madscijr 2025-04-19



Const pi = 3.14159

Const fps = 120

Const cShowValues = _FALSE



Type PointType

    x As Long

    y As Long

    d As Integer

End Type



Dim xmin, ymin As Integer

Dim xmax, ymax As Integer

Dim dx, dy As Integer

Dim OldMouseX, OldMouseY As Integer

Dim arr(1 To 2) As PointType

Dim i As Integer

Dim count As Integer

Dim m$

Dim hue#

Dim dhue#

Dim sat#

Dim dsat#

Dim c~&



Randomize Timer

xmin = 0: ymin = 0: xmax = 640: ymax = 480

'xmax = _DesktopWidth - 1: ymax = _DesktopHeight - 1



Screen _NewImage(xmax, ymax, 32)

_FullScreen



_Delay 2 ' wait a couple seconds before getting mouse coords

While _MouseInput: Wend: OldMouseX = _MouseX: OldMouseY = _MouseY ' initial mouse placement



arr(1).x = 0: arr(1).y = 0: arr(1).d = 1

arr(2).x = xmax: arr(2).y = ymax: arr(2).d = 3

dx = 1: dy = 1

count = 0

hue# = 0

dhue# = 1

sat# = 0

dsat# = -.25



While _KeyDown(27) = 0

    ''color32value~& = _HSBA32(hue#, saturation#, brightness#, alpha#)

    c~& = hpRGB~&(hue# / 360, .25) '_HSBA32(hue#, sat#, 100, 100)

    Line (arr(1).x, arr(1).y)-(arr(2).x, arr(2).y), c~&



    For i = 1 To 2

        Select Case arr(i).d

            Case 1:

                arr(i).x = arr(i).x + dx

                If arr(i).x >= xmax Then arr(i).x = xmax: arr(i).d = 2

            Case 2:

                arr(i).y = arr(i).y + dy

                If arr(i).y >= ymax Then arr(i).y = ymax: arr(i).d = 3

            Case 3:

                arr(i).x = arr(i).x - dx

                If arr(i).x <= xmin Then arr(i).x = xmin: arr(i).d = 4

            Case 4:

                arr(i).y = arr(i).y - dy

                If arr(i).y <= ymin Then arr(i).y = ymin: arr(i).d = 1: 'count = count + 1

        End Select

    Next i



    hue# = hue# + dhue#

    If hue# > 359 Then

        hue# = 0

    End If



    sat# = sat# + dsat#

    If sat# <= 0 Then

        sat# = 0: dsat# = -dsat#

    ElseIf dsat# >= 100 Then

        dsat# = 100: dsat# = -dsat#

    End If



    ' If user moves mouse, quit

    While _MouseInput: Wend: If _MouseX <> OldMouseX Or _MouseY <> OldMouseY Then Exit While



    _Display

    '_Limit fps

Wend



'_AutoDisplay

'Sleep



System



Function hpRGB~& (h As Double, p As Double)

    Dim As Double r0, g0, b0

    Dim As Double r, g, b

    Dim As Double x, f, m, hh

    hh = h ^ 1.5

    x = pi * (hh + 1 / 2)

    r0 = Abs(Sin(x))

    g0 = Abs(Sin(x - pi / 3))

    b0 = Abs(Sin(x + pi / 3))

    f = p * (1 - r0 - g0 - b0)

    r = r0 + f

    g = g0 + f

    b = b0 + f

    m = 1 / Max3##(r, g, b)

    r = r * m

    g = g * m

    b = b * m

    If (r < 0) Then r = 0

    If (g < 0) Then g = 0

    If (b < 0) Then b = 0

    hpRGB~& = _RGB32(r * 255, g * 255, b * 255, 255)

End Function



Function Max3## (x As Double, y As Double, z As Double)

    Dim TheReturn As Double

    TheReturn = x

    If (y > TheReturn) Then TheReturn = y

    If (z > TheReturn) Then TheReturn = z

    Max3## = TheReturn

End Function

[madscijr]

ey bud, try this for a color wheel. i promise you wont find it elsewhere unless the AI already scraped me

Beautiful! 

Keep the cool visuals coming!