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