diff options
Diffstat (limited to 'ipl/gprogs/hsvpick.icn')
| -rw-r--r-- | ipl/gprogs/hsvpick.icn | 205 |
1 files changed, 205 insertions, 0 deletions
diff --git a/ipl/gprogs/hsvpick.icn b/ipl/gprogs/hsvpick.icn new file mode 100644 index 0000000..7b5b765 --- /dev/null +++ b/ipl/gprogs/hsvpick.icn @@ -0,0 +1,205 @@ +############################################################################ +# +# 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 |