Posts: 1,035
Threads: 139
Joined: Apr 2022
Reputation:
23
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
Posts: 1,035
Threads: 139
Joined: Apr 2022
Reputation:
23
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
Posts: 11
Threads: 1
Joined: Apr 2022
Reputation:
6
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
Posts: 1,035
Threads: 139
Joined: Apr 2022
Reputation:
23
04-20-2025, 07:20 PM
(This post was last modified: 04-20-2025, 07:21 PM by madscijr.)
(04-20-2025, 03:36 AM)Sprezzo Wrote: 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!
|
