diff options
Diffstat (limited to 'ipl/gprocs/color.icn')
| -rw-r--r-- | ipl/gprocs/color.icn | 526 |
1 files changed, 526 insertions, 0 deletions
diff --git a/ipl/gprocs/color.icn b/ipl/gprocs/color.icn new file mode 100644 index 0000000..615ca05 --- /dev/null +++ b/ipl/gprocs/color.icn @@ -0,0 +1,526 @@ +############################################################################ +# +# File: color.icn +# +# Subject: Procedures dealing with colors +# +# Author: Gregg M. Townsend +# +# Date: April 1, 1997 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# These procedures deal with colors in various ways. +# +# ScaleGamma(v, g) scales a number with gamma correction. +# +# Blend(k1, k2, ...) generates a sequence of colors. +# +# Contrast(win, k) returns "white" or "black" contrasting with k. +# +# Shade(win, k) sets Fg(), with dithering on a bilevel screen. +# +# RandomColor(W, p) returns a randomly chosen color from a palette. +# +# PaletteGrays(W, p) returns the gray entries of a palette. +# +# RGBKey(W, p, r, g, b) returns the palette key closest to (r,g,b). +# +# HSVKey(W, p, h, s, v) returns the palette key closest to (h/s/v). +# +# HSV(k) returns the h/s/v interpretation of a color. +# +# HSVValue(hsv) returns the ColorValue() of an h/s/v string. +# +# HLS(k) returns the h:l:s interpretation of a color. +# +# HLSValue(hls) returns the ColorValue() of an h:l:s string. +# +############################################################################ +# +# ScaleGamma(v, g) nonlinearly scales the number v (between 0.0 and 1.0) +# to an integer between 0 and 65535 using a gamma correction factor g. +# the default value of g is 2.5. +# +# Blend(color1, color2, color3,...) generates ColorValue(color1), then +# some intermediate shades, then ColorValue(color2), then some more +# intermediate shades, and so on, finally generating the color value of +# the last argument. An integer argument can be interpolated at any +# point to set the number of steps (the default is four) from one color +# to the next. +# +# Contrast(win, colr) returns either "white" or "black", depending +# on which provides the greater contrast with the specified color. +# +# Shade(win, colr) sets the foreground for an area filling operation. +# On a color screen, Shade() sets the foreground color and returns the +# window. On a bilevel monochrome screen, Shade() sets the foreground +# to a magic-square dithering pattern approximating the luminance of the +# color specified. If the environment variable XSHADE is set to "gray" +# (or "grey") then Shade simulates a multilevel grayscale monitor. +# If it is set to any other value, Shade simulates a bilevel monitor. +# +# RandomColor(win, palette) returns a randomly chosen color from the +# given image palette, excluding the "extra" grays of the palette, if +# any. (Colors are selected from a small finite palette, rather than +# from the entire color space, to avoid running out of colors if a +# large number of random choices are desired.) The default palette +# for this procedure is "c6". +# +# PaletteGrays([win,] palette) is like PaletteChars but it returns only +# the characters corresponding to shades of gray. The characters are +# ordered from black to white, and in all palettes the shades of gray +# are equally spaced. +# +# RGBKey([win,] palette, r, g, b) returns a palette key given the +# three color components as real number from 0.0 to 1.0. +# HSVKey([win,] palette, h, s, v) returns a palette key given a +# hue, saturation, and value as real numbers from 0.0 to 1.0. +# +# HSV() and HSVValue() convert between Icon color strings and strings +# containing slash-separated HSV values with maxima of "360/100/100". +# HSV(k) returns the h/s/v interpretation of an Icon color specification; +# HSVValue(hsv) translates an h/s/v value into an Icon r,g,b value. +# +# HLS() and HLSValue() convert between Icon color strings and strings +# containing colon-separated HLS values with maxima of "360:100:100". +# HLS(k) returns the h:l:s interpretation of an Icon color specification; +# HLSValue(hls) translates an h:l:s value into an Icon r,g,b value. +# +############################################################################ +# +# Requires: Version 9 graphics +# +############################################################################ + + +# ScaleGamma(v, g) -- scale fraction to int with gamma correction. + +procedure ScaleGamma(v, g) #: scale with gamma correction + /g := 2.5 + return integer(65535 * v ^ (1.0 / g)) +end + + +# Blend(color1, color2, ...) -- generate sequence of colors + +procedure Blend(args[]) #: generate sequence of colors + local win, n, s, a, i, f1, f2, r1, g1, b1, r2, g2, b2, r3, g3, b3 + static type + + initial type := proc("type", 0) # protect attractive name + + n := 4 + if type(args[1]) == "window" then + win := get(args) + else + win := &window + + while a := get(args) do + if integer(a) >= 0 then + n := integer(a) + else { + s := ColorValue(win, a) | fail + s ? { + r2 := tab(many(&digits)); move(1) + g2 := tab(many(&digits)); move(1) + b2 := tab(many(&digits)) + } + if /r1 then + suspend s + else + every i := 1 to n do { + f2 := real(i) / real(n) + f1 := 1.0 - f2 + r3 := integer(f1 * r1 + f2 * r2) + g3 := integer(f1 * g1 + f2 * g2) + b3 := integer(f1 * b1 + f2 * b2) + suspend r3 || "," || g3 || "," || b3 + } + r1 := r2 + g1 := g2 + b1 := b2 + } +end + + +# Contrast(win, color) -- return "white" or "black" to maximize contrast + +procedure Contrast(win, color) #: choose contrasting color + static l, type + initial { + l := ["white", "black"] + type := proc("type", 0) # protect attractive name + } + + if type(win) == "window" then + return l[1 + PaletteKey(win, "g2", color)] + else + return l[1 + PaletteKey("g2", win)] +end + + +# Shade(win, color) -- approximate a shade with a pattern if bilevel screen + +procedure Shade(win, color) #: dither shade using pattern + local r, g, b + static dmat, env, type + + initial { + env := ("" ~== map(getenv("XSHADE"))) + type := proc("type", 0) # protect attractive name + } + + if type(win) ~== "window" then { + color := win + win := &window + } + if WAttrib(win, "depth") ~== "1" & /env then { + Fg(win, color) | fail + return win + } + (ColorValue(win, color) | fail) ? { + r := tab(many(&digits)); move(1) + g := tab(many(&digits)); move(1) + b := tab(many(&digits)) + } + g := integer(0.30 * r + 0.59 * g + 0.11 * b) + + if \env == ("gray" | "grey") then { + Fg(win, g || "," || g || "," || g) + return win + } + + /dmat := [ + "4,15,15,15,15", + "4,15,15,13,15", + "4,11,15,13,15", + "4,10,15,13,15", + "4,10,15,5,15", + "4,10,7,5,15", + "4,10,7,5,14", + "4,10,7,5,10", + "4,10,5,5,10", + "4,10,5,5,2", + "4,10,4,5,2", + "4,10,0,5,2", + "4,10,0,5,0", + "4,8,0,5,0", + "4,8,0,1,0", + "4,8,0,0,0", + "4,0,0,0,0", + ] + WAttrib(win, "fillstyle=textured") + g := g / 3856 + 1 + Pattern(win, dmat[g]) + return win +end + + +# RandomColor(win, palette) -- choose random color + +procedure RandomColor(win, palette) #: choose random color + local s, n + static type + + initial type := proc("type", 0) # protect attractive name + + if type(win) ~== "window" then + palette:= win # window allowed but ignored + /palette := "c6" + + s := PaletteChars(palette) + palette ? + if ="c" & any('23456') then { + n := integer(move(1)) + s := s[1 +: n * n * n] + } + return PaletteColor(palette, ?s) + +end + + +# PaletteGrays(win, palette) -- return grayscale entries from palette. + +procedure PaletteGrays(win, palette) #: grayscale entries from palette + static type + + initial type := proc("type", 0) # protect attractive name + if (type(win) ~== "window") then + palette := win # window not needed + + palette := string(palette) | runerr(103, palette) + + if palette ? ="g" then + return PaletteChars(palette) + + return case palette of { + "c1": "0123456" + "c2": "kxw" + "c3": "@abMcdZ" + "c4": "0$%&L*+-g/?@}" + "c5": "\0}~\177\200\37\201\202\203\204>\205\206\207\210]_ + \211\212\213\214|" + "c6": "\0\330\331\332\333\334+\335\336\337\340\341V\342\343\344\345_ + \346\201\347\350\351\352\353\254\354\355\356\357\360\327" + default: fail + } +end + + +# RGBKey(win, palette, r, g, b) -- find key given real-valued color + +procedure RGBKey(win, palette, r, g, b) #: return palette key for color + static type + + initial type := proc("type", 0) # protect attractive name + if type(win) ~== "window" then # allow unused window argument + win :=: palette :=: r :=: g :=: b + r := integer(r * 65535.99) + g := integer(g * 65535.99) + b := integer(b * 65535.99) + return PaletteKey(palette, r || "," || g || "," || b) +end + + +# HSVKey(win, palette, h, s, v) -- find nearest key from h,s,v in [0.0,1.0] +# +# HSV conversion based on Foley et al, 2/e, p.593 + +procedure HSVKey(win, palette, h, s, v) #: nearest key from HSV specification + local i, f, p, q, t, r, g, b + static type + + initial type := proc("type", 0) # protect attractive name + if type(win) ~== "window" then # allow unused window argument + win :=: palette :=: h :=: s :=: v + + if s = 0.0 then # achromatic case + return RGBKey(palette, v, v, v) + + h *:= 6.0 # hue [0.0 - 6.0) + if h >= 6.0 then + h := 0.0 + + i := integer(h) + f := h - i + p := v * (1.0 - s) + q := v * (1.0 - f * s) + t := v * (1.0 - (1.0 - f) * s) + + case i of { + 0: { r := v; g := t; b := p } # red - yellow + 1: { r := q; g := v; b := p } # yellow - green + 2: { r := p; g := v; b := t } # green - cyan + 3: { r := p; g := q; b := v } # cyan - blue + 4: { r := t; g := p; b := v } # blue - magenta + 5: { r := v; g := p; b := q } # magenta - red + } + + return RGBKey(palette, r, g, b) +end + + +# HSV(k) -- return h/s/v interpretation of color spec. +# +# h is hue (0 <= h < 360) +# s is saturation (0 <= s <= 100) +# v is value (0 <= v <= 100) +# +# based on Foley et al, 2/e, p.592 + +procedure HSV(k) #: HSV interpretation of color + local r, g, b, h, s, v, min, max, d + + (ColorValue(k) | fail) ? { + r := tab(many(&digits)) / 65535.0 + move(1) + g := tab(many(&digits)) / 65535.0 + move(1) + b := tab(many(&digits)) / 65535.0 + } + + min := r; min >:= g; min >:= b # minimum + max := r; max <:= g; max <:= b # maximum + d := max - min # difference + + v := max # value is max of all values + if max > 0 then + s := d / max # saturation is (max-min)/max + else + s := 0.0 + + if s = 0 then + h := 0.0 # use hue 0 if unsaturated + else if g = max then + h := 2 + (b - r) / d # yellow through cyan + else if b = max then + h := 4 + (r - g) / d # cyan through magenta + else if g < b then + h := 6 + (g - b) / d # magenta through red + else + h := (g - b) / d # red through yellow + + return integer(60 * h + 0.5) || "/" || + integer(100 * s + 0.5) || "/" || integer(100 * v + 0.5) +end + + +# HSVValue(hsv) -- return ColorValue of h/s/v string +# +# h is hue (0 <= h <= 360) +# s is saturation (0 <= s <= 100) +# v is value (0 <= v <= 100) +# +# based on Foley et al, 2/e, p.593 + +procedure HSVValue(hsv) #: color value of HSV specification + local h, s, v, r, g, b, i, f, p, q, t + + hsv ? { + h := tab(many(&digits)) / 360.0 | fail + ="/" | fail + s := tab(many(&digits)) / 100.0 | fail + ="/" | fail + v := tab(many(&digits)) / 100.0 | fail + pos(0) | fail + } + if (h | s | v) > 1 then fail + + if s = 0.0 then { # achromatic case + v := integer(65535 * v + 0.499999) + return v || "," || v || "," || v + } + + h *:= 6.0 # hue [0.0 - 6.0) + if h >= 6.0 then + h := 0.0 + + i := integer(h) + f := h - i + p := v * (1.0 - s) + q := v * (1.0 - f * s) + t := v * (1.0 - (1.0 - f) * s) + + case i of { + 0: { r := v; g := t; b := p } # red - yellow + 1: { r := q; g := v; b := p } # yellow - green + 2: { r := p; g := v; b := t } # green - cyan + 3: { r := p; g := q; b := v } # cyan - blue + 4: { r := t; g := p; b := v } # blue - magenta + 5: { r := v; g := p; b := q } # magenta - red + } + + return integer(65535 * r + 0.499999) || "," || + integer(65535 * g + 0.499999) || "," || integer(65535 * b + 0.499999) +end + + +# HLS(k) -- return h:l:s interpretation of color spec. +# +# h is hue (0 <= h < 360) +# l is lightness (0 <= l <= 100) +# s is saturation (0 <= s <= 100) +# +# based on Foley et al, 2/e, p.595 + +procedure HLS(k) #: HLS interpretation of color + local r, g, b, h, l, s, min, max, delta + + (ColorValue(k) | fail) ? { + r := tab(many(&digits)) / 65535.0 + move(1) + g := tab(many(&digits)) / 65535.0 + move(1) + b := tab(many(&digits)) / 65535.0 + } + + min := r; min >:= g; min >:= b # minimum + max := r; max <:= g; max <:= b # maximum + delta := max - min # difference + + l := (max + min) / 2 # lightness + + if max = min then + h := s := 0 # achromatic + + else { + + if l <= 0.5 then + s := delta / (max + min) # saturation + else + s := delta / (2 - max - min) + + if r = max then + h := (g - b) / delta # yellow through magenta + else if g = max then + h := 2 + (b - r) / delta # cyan through yellow + else # b = max + h := 4 + (r - g) / delta # magenta through cyan + if h < 0 then + h +:= 6 # ensure positive value + } + + return integer(60 * h + 0.5) || ":" || + integer(100 * l + 0.5) || ":" || integer(100 * s + 0.5) +end + + +# HLSValue(hls) -- return ColorValue of h:l:s string +# +# h is hue (0 <= h <= 360) +# l is lightness (0 <= l <= 100) +# s is saturation (0 <= s <= 100) +# +# based on Foley & Van Dam, 1/e, p.619 + +procedure HLSValue(hls) #: color value of HLS specification + local h, l, s, r, g, b, m1, m2 + + hls ? { + h := tab(many(&digits)) / 360.0 | fail + =":" | fail + l := tab(many(&digits)) / 100.0 | fail + =":" | fail + s := tab(many(&digits)) / 100.0 | fail + pos(0) | fail + } + if (h | l | s) > 1 then fail + + if l <= 0.5 then + m2 := l * (1 + s) + else + m2 := l + s - (l * s) + m1 := 2 * l - m2 + + if s = 0.0 then + r := g := b := l # achromatic + else { + r := hls_rgb_val(m1, m2, h + 0.3333333) + g := hls_rgb_val(m1, m2, h) + b := hls_rgb_val(m1, m2, h - 0.3333333) + } + + return integer(65535 * r + 0.499999) || "," || + integer(65535 * g + 0.499999) || "," || integer(65535 * b + 0.499999) +end + +procedure hls_rgb_val(n1, n2, hue) # helper function for HLSValue + hue *:= 6 + if hue >= 6 then + hue -:= 6 + else if hue < 0 then + hue +:= 6 + if (hue < 1) then + return n1 + (n2 - n1) * hue + else if (hue < 3) then + return n2 + else if (hue < 4) then + return n1 + (n2 - n1) * (4 - hue) + else + return n1 +end |