I was prompted by Rosetta Code suggested tasks- and natural curiosity- to play with RGB and HSL ways of displaying and specifying colour. It was also related to graphic exercises where I wanted repeated cycling through a range of colours.
Some of the results were unexpected.
' to-do's step 2 degrees and use fill?
' mix radially with r/radius *black ( or white)
nomainwin
global hdc, col$
WindowWidth =600
WindowHeight =600
graphicbox #w.gb, 10, 10, 540, 540
open "Colour wheel" for window as #w
h = hwnd( #w.gb)
calldll #user32, "GetDC", h as ulong, hdc as ulong
#w "trapclose quit"
#w.gb "down ; fill 0 0 0 ; size 3 ; flush"
radius =250
pi =4 *atn( 1)
for angle =0 to 359.998 step 0.5
sector =int( angle /60)
slope =10 +4 *( angle mod 60)
scan
select case sector
case 0
col$ ="255 " +str$( int( slope)) +" 0"
case 1
col$ =str$( int( 256 -slope)) +" 255 0"
case 2
col$ ="0 255 " +str$( int( slope))
case 3
col$ ="0 "; str$( int( 256 -slope)) +" 255"
case 4
col$ =str$( int( slope)) +" 0 255"
case 5
col$ ="255 0 " +str$( int( 256 -slope))
end select
call bresenham int( 270 +radius *cos( angle /180 *pi)), int( 270 +radius *sin( angle /180 *pi)), 270, 270
next angle
#w.gb "flush ; getbmp scr 0 0 500 500"
bmpsave "scr", "colWheel" +str$( time$( "seconds")) +".bmp"
wait
sub bresenham x1, y1, x2, y2 ' Inputs are x1, y1, x2, y2: destroys value of x1, y1
'X1 =x1: Y1 =y1
dx = abs( x2 - x1): sx = -1: if x1 < x2 then sx = 1
dy = abs( y2 - y1): sy = -1: if y1 < y2 then sy = 1
er = 0 -dy: if dx > dy then er = dx
er = int( er / 2)
red =val( word$( col$, 1))
grn =val( word$( col$, 2))
blu =val( word$( col$, 3))
[more]
R =(( x1 -270)^2 +( y1 -270)^2)^0.5 /256 ' fade components up to full white centre
redR =int( R *255 +red *( 1 -R))
grnR =int( R *255 +grn *( 1 -R))
bluR =int( R *255 +blu *( 1 -R))
redR =int( ( 1 -R) *255 +red *( R))
grnR =int( ( 1 -R) *255 +grn *( R))
bluR =int( ( 1 -R) *255 +blu *( R))
c$ =str$( redR) +" " +str$( grnR) +" " +str$( bluR)
#w.gb "color " +c$
#w.gb "set "; x1; " "; y1
scan
if ( ( x1 = x2) and ( y1 = y2)) then exit sub
if ( ( x2 > 540) or ( x2 < 10) or ( y2 > 540) or ( y2 < 10)) then exit sub ' should not happen!
e2 = er
if ( e2 > 0 -dx) then er = ( er - dy): x1 = ( x1 + sx)
if ( e2 < dy) then er = ( er + dx): y1 = ( y1 + sy)
goto [more]
end sub
function getPixel( x, y)
calldll #gdi32, "GetPixel", hdc as ulong, x as long, y as long, pixcol as ulong
getPixel =pixcol
end function
sub quit h$
close #h$
calldll #user32, "ReleaseDC", hw as ulong, hdc as ulong 'release the DC
end
end sub
' ** colourWheelRethink2.bas ***
' ** raster scan resulting image and calculate angle and radius to find appropriate colour RGB components
nomainwin
global hdc, col$, pi
pi =4 *atn( 1)
ptSize =1
WindowWidth =600
WindowHeight =600
graphicbox #w.gb, 10, 10, 540, 540
open "Colour wheel" for window as #w
h =hwnd( #w.gb)
calldll #user32, "GetDC", h as ulong, hdc as ulong
#w "trapclose quit"
#w.gb "down ; fill white ; size "; ptSize; " ; font Ubuntu_Mono 12"
#w.gb "when leftButtonDown [getPixel]"
radius =250
for x =0 to 518 step ptSize
for y =0 to 520 step ptSize
angle =atan2( y -250, x -250) *360 / 2 /pi ' Angle in degrees round full circle....
sector =int( angle /60) ' ...split into six 60 degree sectors, labelled 0 to 5
slope =( angle mod 60) /60 *255 ' ...and each split into 1 degree sectors.
scan
select case sector
case 0
col$ ="255 "; str$( int( slope)); " 0"
case 1
col$ =str$( int( 256 -slope)); " 255 0"
case 2
col$ ="0 255 "; str$( int( slope))
case 3
col$ ="0 "; str$( int( 256 -slope)); " 255"
case 4
col$ =str$( int( slope)); " 0 255"
case 5
col$ ="255 0 "; str$( int( 256 -slope))
end select
red =val( word$( col$, 1)): grn =val( word$( col$, 2)): blu =val( word$( col$, 3))
R =( ( x -270)^2 +( y -270)^2)^0.5 /250
redR =R *int( red): grnR =R *int( grn): bluR =R *int( blu) ' fade to rim black
#w.gb "color "; str$( redR) +" " +str$( grnR) +" " +str$( bluR)
if R >1 then #w.gb "color white"
#w.gb "set "; x; " "; y
next y
next x
#w.gb "flush ; getbmp scr 0 0 540 540"
bmpsave "scr", "colWheelToRimWhiteNoFade.bmp"
wait
[getPixel]
xx =MouseX
yy =MouseY
calldll #gdi32, "GetPixel", hdc as ulong, xx as long, yy as long, pixcol as ulong
#w.gb "up ; goto 20 20 ; down ; color black"
#w.gb "\ " +right$( " " +str$( pixcol), 10) +" "
wait
sub quit h$
close #h$
calldll #user32, "ReleaseDC", hw as ulong, hdc as ulong 'release the DC
end
end sub
function atan2( y, x)
result$ ="Undetermined"
If ( x =0) and ( y >0) then atan2 = pi /2: result$ ="Determined"
if ( x =0) and ( y <0) then atan2 =3 * pi /2: result$ ="Determined"
if ( x >0) and ( y =0) then atan2 =0: result$ ="Determined"
if ( x <0) and ( y =0) then atan2 =pi: result$ ="Determined"
If result$ <>"Determined" then
if x =0 and y =0 then
atan2 =0
else
baseAngle =atn( abs( y) /abs( x))
If ( x >0) and ( y >0) then atan2 = baseAngle
If ( x <0) and ( y >0) then atan2 = pi -baseAngle
If ( x <0) and ( y <0) then atan2 = pi +baseAngle
If ( x >0) and ( y <0) then atan2 = 2*pi -baseAngle
end if
end if
end function
' to-do's step 2 degrees and use fill?
' mix radially with r/radius *black ( or white)
nomainwin
global hdc, col$
WindowWidth =600
WindowHeight =600
graphicbox #w.gb, 10, 10, 540, 540
open "Colour wheel" for window as #w
h = hwnd( #w.gb)
calldll #user32, "GetDC", h as ulong, hdc as ulong
#w "trapclose quit"
#w.gb "down ; fill 0 0 0 ; size 3 ; flush"
radius =250
pi =4 *atn( 1)
for angle =0 to 359.998 step 0.5
sector =int( angle /60)
slope =10 +4 *( angle mod 60)
scan
select case sector
case 0
col$ ="255 " +str$( int( slope)) +" 0"
case 1
col$ =str$( int( 256 -slope)) +" 255 0"
case 2
col$ ="0 255 " +str$( int( slope))
case 3
col$ ="0 "; str$( int( 256 -slope)) +" 255"
case 4
col$ =str$( int( slope)) +" 0 255"
case 5
col$ ="255 0 " +str$( int( 256 -slope))
end select
call bresenham int( 270 +radius *cos( angle /180 *pi)), int( 270 +radius *sin( angle /180 *pi)), 270, 270
next angle
#w.gb "flush ; getbmp scr 0 0 500 500"
bmpsave "scr", "colWheel" +str$( time$( "seconds")) +".bmp"
wait
sub bresenham x1, y1, x2, y2 ' Inputs are x1, y1, x2, y2: destroys value of x1, y1
'X1 =x1: Y1 =y1
dx = abs( x2 - x1): sx = -1: if x1 < x2 then sx = 1
dy = abs( y2 - y1): sy = -1: if y1 < y2 then sy = 1
er = 0 -dy: if dx > dy then er = dx
er = int( er / 2)
red =val( word$( col$, 1))
grn =val( word$( col$, 2))
blu =val( word$( col$, 3))
[more]
R =(( x1 -270)^2 +( y1 -270)^2)^0.5 /256 ' fade components up to full white centre
redR =int( R *255 +red *( 1 -R))
grnR =int( R *255 +grn *( 1 -R))
bluR =int( R *255 +blu *( 1 -R))
redR =int( ( 1 -R) *255 +red *( R))
grnR =int( ( 1 -R) *255 +grn *( R))
bluR =int( ( 1 -R) *255 +blu *( R))
c$ =str$( redR) +" " +str$( grnR) +" " +str$( bluR)
#w.gb "color " +c$
#w.gb "set "; x1; " "; y1
scan
if ( ( x1 = x2) and ( y1 = y2)) then exit sub
if ( ( x2 > 540) or ( x2 < 10) or ( y2 > 540) or ( y2 < 10)) then exit sub ' should not happen!
e2 = er
if ( e2 > 0 -dx) then er = ( er - dy): x1 = ( x1 + sx)
if ( e2 < dy) then er = ( er + dx): y1 = ( y1 + sy)
goto [more]
end sub
function getPixel( x, y)
calldll #gdi32, "GetPixel", hdc as ulong, x as long, y as long, pixcol as ulong
getPixel =pixcol
end function
sub quit h$
close #h$
calldll #user32, "ReleaseDC", hw as ulong, hdc as ulong 'release the DC
end
end sub
The only thing to remember is that hue varies 0 to 360, while saturation and value are between 0 and 0.9999.
Works nicely with LB graphic commands and with LB Bresenham routine ( see RC) you can draw very easily lines from A to B whose colour varies along their length.
nomainwin
global pi, col$: pi =3.14158265
WindowWidth =570
WindowHeight =600
UpperLeftX =int( ( DisplayWidth -WindowWidth) /2)
UpperLeftY =int( ( DisplayHeight -WindowHeight) /2)
graphicBox #w.g, 9, 9, 537, 537
open "Ring fade demo" for window as #w
#w "trapClose quit"
#w.g "down; fill darkblue ; goto 267 267"
#w.g "size 2"
for R =1 to 255 step 0.25
call hsv2rgb R, 0.49, 0.79 ' hue, saturation, value
#w.g "color "; col$
#w.g "circle "; R
scan
next R
#w.g "getbmp scr 1 1 537 537"
bmpsave "scr", "ring" +str$( time$( "seconds")) +".bmp"
wait
sub hsv2rgb h, s, v ' hue 0-360, saturation 0-1, value 0-1
c =v *s ' chroma
h =h
x =c *( 1 -abs( ( ( h /60) mod 2) -1))
m =v -c ' matching adjustment
select case
case h < 60
r = c: g = x: b = 0
case h <120
r = x: g = c: b = 0
case h <180
r = 0: g = c: b = x
case h <240
r = 0: g = x: b = c
case h <300
r = x: g = 0: b = c
case else
r = c: g = 0: b = x
end select
rd = abs( int( 256 *( r + m)))
gn = abs( int( 256 *( g + m)))
bu = abs( int( 256 *( b + m)))
col$ =right$( " " +str$( rd), 3) +" " +right$( " " +str$( gn), 3) +" " +right$( " " +str$( bu), 3)
end sub
sub quit handle$
close #w
end
end sub
nomainwin
global col$, i
i = 0
WindowWidth = 1200
WindowHeight = 700
menu #wg, "File", "Save", [save], "Reverse", [reverse]
open "The tooth(paste) fairy paints again!!" for graphics_nsb as #wg
#wg "when leftButtonMove [paint]"
#wg "down ; fill 40 40 40 ; backcolor 40 40 40 ; size 30"
wait
[paint]
#wg "set "; MouseX; " "; MouseY
i =( i + 1) mod 360
'call hsv2rgb i, 0.99, 0.99
call sinRGB 1, 2.3, 3.7
#wg "color "; col$
'print col$
scan
wait
[save]
#wg "getbmp scr 0 0 1200 700"
bmpsave "scr", "message" +str$( time$( "seconds")) +".bmp"
wait
[reverse]
incr =-1 *incr
wait
sub sinRGB u, v, w
rd = int( 128 +127 *sinRad( u *i))
gn = int( 128 +127 *sinRad( v *i))
bu = int( 128 +127 *sinRad( w *i))
col$ =right$( " " +str$( rd), 3) +" " +right$( " " +str$( gn), 3) +" " +right$( " " +str$( bu), 3)
end sub
sub hsv2rgb h, s, v ' hue 0-360, saturation 0-1, value 0-1
c =v *s ' chroma
h =h
x =c *( 1 -abs( ( ( h /60) mod 2) -1))
m =v -c ' matching adjustment
select case
case h < 60
r = c: g = x: b = 0
case h <120
r = x: g = c: b = 0
case h <180
r = 0: g = c: b = x
case h <240
r = 0: g = x: b = c
case h <300
r = x: g = 0: b = c
case else
r = c: g = 0: b = x
end select
rd = abs( int( 256 *( r + m)))
gn = abs( int( 256 *( g + m)))
bu = abs( int( 256 *( b + m)))
col$ =right$( " " +str$( rd), 3) +" " +right$( " " +str$( gn), 3) +" " +right$( " " +str$( bu), 3)
'print col$
end sub
function getPixel( x, y)
calldll #gdi32, "GetPixel", hdc as ulong, x as long, y as long, pixcol as ulong
getPixel =pixcol
end function
function sinRad( t)
sinRad =sin( t *3.114159265 /180)
end function