############################################################################
#
#	File:     hsvpick.icn
#
#	Subject:  Program to pick RGB or HSV colors
#
#	Author:   Gregg M. Townsend
#
#	Date:     November 14, 1994
#
############################################################################
#
#   This file is in the public domain.
#
############################################################################
#
#      hsvpick is a simple HSV color picker.  The three sliders on the
#   left control red, green, blue; the sliders on the right control
#   hue, saturation, value.  The equivalent hexadecimal specification
#   is displayed in the center.
#
############################################################################
#
#  Requires:  Version 9 graphics
#
############################################################################
#
#  Links: button, slider, evmux, graphics
#
############################################################################

link button
link slider
link evmux
link graphics

$define BevelWidth 2
$define WindowMargin 10

record valrec(r, g, b, h, s, v)
global sl		# the six sliders
global val		# the six values [0.0 - 1.0]

global w, h, m, l	# geometry options
global sw		# slider width
global colr		# selected color

procedure main(args)
   local cwin, x, y, ww, hh

   # create window
   Window("size=420,300", args)
   m := WindowMargin				# size of outside margins
   w := w := WAttrib("width") - 2 * m		# usable width
   h := WAttrib("height") - 2 * m		# usable height
   l := WAttrib("leading")			# leading
   sw := 20					# set slider width

   # get mutable color to display the selected color
   # use a new binding to avoid disturbing fg/bg of &window.
   colr := NewColor(&window) | stop("can't allocate mutable color")
   cwin := Clone(&window)
   Bg(cwin, colr)

   # draw the area showing the color itself
   x := 4 * m + 3 * sw
   y := m
   ww := w - 6 * sw - 6 * m
   hh := h - m - 3 * l
   BevelRectangle(x, y, ww, hh, -BevelWidth)
   EraseArea(cwin, x+BevelWidth, y+BevelWidth, ww-2*BevelWidth, hh-2*BevelWidth)

   # set up sliders to control the colors
   val := valrec(0.75, 0.625, 0.50, 0.0, 0.0, 0.0)	# initial values
   sl := valrec(
      slider(&window, setval, 1,              m, m, sw, h, 0.0, val.r, 1.0),
      slider(&window, setval, 2,     sw + 2 * m, m, sw, h, 0.0, val.g, 1.0),
      slider(&window, setval, 3, 2 * sw + 3 * m, m, sw, h, 0.0, val.b, 1.0),
      slider(&window, setval, 4, w - m - 3 * sw, m, sw, h, 0.0, val.h, 1.0),
      slider(&window, setval, 5, w     - 2 * sw, m, sw, h, 0.0, val.s, 1.0),
      slider(&window, setval, 6,     w + m - sw, m, sw, h, 0.0, val.v, 1.0))
   sethsv()						# set hsv from rgb
   setcolor()						# download the colors

   # set up sensors for quitting
   quitsensor(&window)					# q or Q
   button(&window, "QUIT", argless, exit, m + w / 2 - 30, m + h - 20, 60, 20)

   # enter event loop
   evmux(&window)
end

procedure setval(win, i, v)		# set color component i to value v
   val[i] := v
   if i < 4 then
      sethsv()				# rgb slider moved; set hsv values
   else
      setrgb()				# hsv slider moved; set rgv values

   setcolor()				# set color, update display
   return
end

procedure sethsv()			# set hsv from rgb values
					# based on Foley et al, 2/e, p.592
   local min, max, d

   min := val.r;  min >:= val.g;  min >:= val.b		# minimum
   max := val.r;  max <:= val.g;  max <:= val.b		# maximum
   d := max - min					# difference

   val.v := max					# v is max of all values
   if max > 0 then
      val.s := d / max
   else
      val.s := 0				# sat is (max-min)/max

   if val.s > 0 then {
      if val.g = max then
         val.h := 2 + (val.b - val.r) / d	# yellow through cyan
      else if val.b = max then
         val.h := 4 + (val.r - val.g) / d	# cyan through magenta
      else if val.g < val.b then
         val.h := 6 + (val.g - val.b) / d	# magenta through red
      else
         val.h := (val.g - val.b) / d		# red through yellow
      }
   val.h /:= 6					# scale to 0.0 - 1.0

   # set sliders to reflect calculated values
   slidervalue(sl.h, val.h)
   slidervalue(sl.s, val.s)
   slidervalue(sl.v, val.v)
   return
end

procedure setrgb()			# set rgb from hsv values
					# based on Foley et al, 2/e, p.593
   local h, f, i, p, q, t, v

   if val.s = 0.0 then
      val.r := val.g := val.b := val.v	# achromatic
   else {
      h := val.h * 6.0			# hue [0.0 - 6.0)
      if h >= 6.0 then
         h := 0.0
      i := integer(h)
      f := h - i
      v := val.v
      p := val.v * (1.0 - val.s)
      q := val.v * (1.0 - f * val.s)
      t := val.v * (1.0 - (1.0 - f) * val.s)
      case i of {
         0: { val.r := v;  val.g := t;  val.b := p }	# red - yellow
         1: { val.r := q;  val.g := v;  val.b := p }	# yellow - green
         2: { val.r := p;  val.g := v;  val.b := t }	# green - cyan
         3: { val.r := p;  val.g := q;  val.b := v }	# cyan - blue
         4: { val.r := t;  val.g := p;  val.b := v }	# blue - magenta
         5: { val.r := v;  val.g := p;  val.b := q }	# magenta - red
         }
      }

   # set sliders to reflect calculated values
   slidervalue(sl.r, val.r)
   slidervalue(sl.g, val.g)
   slidervalue(sl.b, val.b)
   return
end

procedure setcolor()			# set the color in the color map
   local s, x

   # build and display hex color spec, and set color
   s := "#" || hexv(val.r) || hexv(val.g) || hexv(val.b)
   Color(colr, s)
   GotoXY(m + w / 2 - TextWidth(s) / 2, m + h - 2 * l)
   WWrites(s)

   # display r, g, b values
   x := 4 * m + 3 * sw
   GotoXY(x, m + h - 2 * l)
   WWrites("r: ", right(integer(65535 * val.r), 5))
   GotoXY(x, m + h - l)
   WWrites("g: ", right(integer(65535 * val.g), 5))
   GotoXY(x, m + h)
   WWrites("b: ", right(integer(65535 * val.b), 5))

   # display h, s, v values
   x := w - 2 * m - 3 * sw - TextWidth("h: 000")
   GotoXY(x, m + h - 2 * l)
   WWrites("h: ", right(integer(360 * val.h), 3))
   GotoXY(x, m + h - l)
   WWrites("s: ", right(integer(100 * val.s), 3))
   GotoXY(x, m + h)
   WWrites("v: ", right(integer(100 * val.v), 3))
   return
end

procedure hexv(v)			# two-hex-digit specification of v
   static hextab
   initial {
      every put((hextab := []), !"0123456789ABCDEF" || !"0123456789ABCDEF")
      }
   return hextab [integer(255 * v + 1.5)]
end