diff options
Diffstat (limited to 'stdlib/source/lux/data/color.lux')
-rw-r--r-- | stdlib/source/lux/data/color.lux | 424 |
1 files changed, 0 insertions, 424 deletions
diff --git a/stdlib/source/lux/data/color.lux b/stdlib/source/lux/data/color.lux deleted file mode 100644 index 921137d9a..000000000 --- a/stdlib/source/lux/data/color.lux +++ /dev/null @@ -1,424 +0,0 @@ -(.module: - [lux #* - [abstract - [equivalence (#+ Equivalence)] - [monoid (#+ Monoid)] - ["." hash (#+ Hash)]] - [data - [collection - ["." list ("#\." functor)]]] - ["." math - [number - ["n" nat] - ["f" frac] - ["." int] - ["." rev ("#\." interval)] - ["." i64]]] - [type - abstract]]) - -(def: rgb 256) -(def: top (dec rgb)) - -(def: rgb_factor (|> top .int int.frac)) - -(def: down - (-> Nat Frac) - (|>> .int int.frac (f./ rgb_factor))) - -(def: up - (-> Frac Nat) - (|>> (f.* rgb_factor) f.int .nat)) - -(type: #export RGB - {#red Nat - #green Nat - #blue Nat}) - -(type: #export HSL - [Frac Frac Frac]) - -(type: #export CMYK - {#cyan Frac - #magenta Frac - #yellow Frac - #key Frac}) - -(type: #export HSB - [Frac Frac Frac]) - -(abstract: #export Color - RGB - - (def: #export (from_rgb [red green blue]) - (-> RGB Color) - (:abstraction {#red (n.% ..rgb red) - #green (n.% ..rgb green) - #blue (n.% ..rgb blue)})) - - (def: #export to_rgb - (-> Color RGB) - (|>> :representation)) - - (implementation: #export equivalence - (Equivalence Color) - - (def: (= reference sample) - (let [[rR gR bR] (:representation reference) - [rS gS bS] (:representation sample)] - (and (n.= rR rS) - (n.= gR gS) - (n.= bR bS))))) - - (implementation: #export hash - (Hash Color) - - (def: &equivalence ..equivalence) - - (def: (hash value) - (let [[r g b] (:representation value)] - ($_ i64.or - (i64.left_shift 16 r) - (i64.left_shift 8 g) - b)))) - - (def: #export black - (..from_rgb {#red 0 - #green 0 - #blue 0})) - - (def: #export white - (..from_rgb {#red ..top - #green ..top - #blue ..top})) - - (implementation: #export addition - (Monoid Color) - - (def: identity ..black) - - (def: (compose left right) - (let [[lR lG lB] (:representation left) - [rR rG rB] (:representation right)] - (:abstraction {#red (n.max lR rR) - #green (n.max lG rG) - #blue (n.max lB rB)})))) - - (def: (complement' value) - (-> Nat Nat) - (|> ..top (n.- value))) - - (def: #export (complement color) - (-> Color Color) - (let [[red green blue] (:representation color)] - (:abstraction {#red (complement' red) - #green (complement' green) - #blue (complement' blue)}))) - - (implementation: #export subtraction - (Monoid Color) - - (def: identity ..white) - - (def: (compose left right) - (let [[lR lG lB] (:representation (..complement left)) - [rR rG rB] (:representation right)] - (:abstraction {#red (n.min lR rR) - #green (n.min lG rG) - #blue (n.min lB rB)})))) - ) - -(def: #export (to_hsl color) - (-> Color HSL) - (let [[red green blue] (to_rgb color) - red (..down red) - green (..down green) - blue (..down blue) - max ($_ f.max red green blue) - min ($_ f.min red green blue) - luminance (|> (f.+ max min) (f./ +2.0))] - (if (f.= max min) - ## Achromatic - [+0.0 - +0.0 - luminance] - ## Chromatic - (let [diff (|> max (f.- min)) - saturation (|> diff - (f./ (if (f.> +0.5 luminance) - (|> +2.0 (f.- max) (f.- min)) - (|> max (f.+ min))))) - hue' (cond (f.= red max) - (|> green (f.- blue) (f./ diff) - (f.+ (if (f.< blue green) +6.0 +0.0))) - - (f.= green max) - (|> blue (f.- red) (f./ diff) - (f.+ +2.0)) - - ## (f.= blue max) - (|> red (f.- green) (f./ diff) - (f.+ +4.0)))] - [(|> hue' (f./ +6.0)) - saturation - luminance])))) - -(def: (hue_to_rgb p q t) - (-> Frac Frac Frac Frac) - (let [t (cond (f.< +0.0 t) (f.+ +1.0 t) - (f.> +1.0 t) (f.- +1.0 t) - ## else - t) - f2/3 (f./ +3.0 +2.0)] - (cond (f.< (f./ +6.0 +1.0) t) - (|> q (f.- p) (f.* +6.0) (f.* t) (f.+ p)) - - (f.< (f./ +2.0 +1.0) t) - q - - (f.< f2/3 t) - (|> q (f.- p) (f.* (|> f2/3 (f.- t))) (f.* +6.0) (f.+ p)) - - ## else - p))) - -(def: #export (from_hsl [hue saturation luminance]) - (-> HSL Color) - (if (f.= +0.0 saturation) - ## Achromatic - (let [intensity (..up luminance)] - (from_rgb {#red intensity - #green intensity - #blue intensity})) - ## Chromatic - (let [q (if (f.< +0.5 luminance) - (|> saturation (f.+ +1.0) (f.* luminance)) - (|> luminance (f.+ saturation) (f.- (f.* saturation luminance)))) - p (|> luminance (f.* +2.0) (f.- q)) - third (|> +1.0 (f./ +3.0))] - (from_rgb {#red (..up (|> hue (f.+ third) (hue_to_rgb p q))) - #green (..up (|> hue (hue_to_rgb p q))) - #blue (..up (|> hue (f.- third) (hue_to_rgb p q)))})))) - -(def: #export (to_hsb color) - (-> Color HSB) - (let [[red green blue] (to_rgb color) - red (..down red) - green (..down green) - blue (..down blue) - max ($_ f.max red green blue) - min ($_ f.min red green blue) - brightness max - diff (|> max (f.- min)) - saturation (if (f.= +0.0 max) - +0.0 - (|> diff (f./ max)))] - (if (f.= max min) - ## Achromatic - [+0.0 saturation brightness] - ## Chromatic - (let [hue (cond (f.= red max) - (|> green (f.- blue) (f./ diff) - (f.+ (if (f.< blue green) +6.0 +0.0))) - - (f.= green max) - (|> blue (f.- red) (f./ diff) - (f.+ +2.0)) - - ## (f.= blue max) - (|> red (f.- green) (f./ diff) - (f.+ +4.0)))] - [(|> hue (f./ +6.0)) - saturation - brightness])))) - -(def: #export (from_hsb [hue saturation brightness]) - (-> HSB Color) - (let [hue (|> hue (f.* +6.0)) - i (math.floor hue) - f (|> hue (f.- i)) - p (|> +1.0 (f.- saturation) (f.* brightness)) - q (|> +1.0 (f.- (f.* f saturation)) (f.* brightness)) - t (|> +1.0 (f.- (|> +1.0 (f.- f) (f.* saturation))) (f.* brightness)) - v brightness - mod (|> i (f.% +6.0) f.int .nat) - red (case mod 0 v 1 q 2 p 3 p 4 t 5 v _ (undefined)) - green (case mod 0 t 1 v 2 v 3 q 4 p 5 p _ (undefined)) - blue (case mod 0 p 1 p 2 t 3 v 4 v 5 q _ (undefined))] - (from_rgb {#red (..up red) - #green (..up green) - #blue (..up blue)}))) - -(def: #export (to_cmyk color) - (-> Color CMYK) - (let [[red green blue] (to_rgb color) - red (..down red) - green (..down green) - blue (..down blue) - key (|> +1.0 (f.- ($_ f.max red green blue))) - f (if (f.< +1.0 key) - (|> +1.0 (f./ (|> +1.0 (f.- key)))) - +0.0) - cyan (|> +1.0 (f.- red) (f.- key) (f.* f)) - magenta (|> +1.0 (f.- green) (f.- key) (f.* f)) - yellow (|> +1.0 (f.- blue) (f.- key) (f.* f))] - {#cyan cyan - #magenta magenta - #yellow yellow - #key key})) - -(def: #export (from_cmyk [cyan magenta yellow key]) - (-> CMYK Color) - (if (f.= +1.0 key) - (from_rgb {#red 0 - #green 0 - #blue 0}) - (let [red (|> (|> +1.0 (f.- cyan)) - (f.* (|> +1.0 (f.- key)))) - green (|> (|> +1.0 (f.- magenta)) - (f.* (|> +1.0 (f.- key)))) - blue (|> (|> +1.0 (f.- yellow)) - (f.* (|> +1.0 (f.- key))))] - (from_rgb {#red (..up red) - #green (..up green) - #blue (..up blue)})))) - -(def: (normalize ratio) - (-> Frac Frac) - (cond (f.> +1.0 ratio) - (f.% +1.0 ratio) - - (f.< +0.0 ratio) - (|> ratio (f.% +1.0) (f.+ +1.0)) - - ## else - ratio)) - -(def: #export (interpolate ratio end start) - (-> Frac Color Color Color) - (let [dS (..normalize ratio) - dE (|> +1.0 (f.- dS)) - interpolate' (: (-> Nat Nat Nat) - (function (_ end start) - (|> (|> start .int int.frac (f.* dS)) - (f.+ (|> end .int int.frac (f.* dE))) - f.int - .nat))) - [redS greenS blueS] (to_rgb start) - [redE greenE blueE] (to_rgb end)] - (from_rgb {#red (interpolate' redE redS) - #green (interpolate' greenE greenS) - #blue (interpolate' blueE blueS)}))) - -(template [<name> <target>] - [(def: #export (<name> ratio color) - (-> Frac Color Color) - (..interpolate ratio <target> color))] - - [darker black] - [brighter white] - ) - -(template [<name> <op>] - [(def: #export (<name> ratio color) - (-> Frac Color Color) - (let [[hue saturation luminance] (to_hsl color)] - (from_hsl [hue - (|> saturation - (f.* (|> +1.0 (<op> (..normalize ratio)))) - (f.min +1.0)) - luminance])))] - - [saturate f.+] - [de_saturate f.-] - ) - -(def: #export (gray_scale color) - (-> Color Color) - (let [[_ _ luminance] (to_hsl color)] - (from_hsl [+0.0 - +0.0 - luminance]))) - -(template [<name> <1> <2>] - [(def: #export (<name> color) - (-> Color [Color Color Color]) - (let [[hue saturation luminance] (to_hsl color)] - [color - (from_hsl [(|> hue (f.+ <1>) ..normalize) - saturation - luminance]) - (from_hsl [(|> hue (f.+ <2>) ..normalize) - saturation - luminance])]))] - - [triad (|> +1.0 (f./ +3.0)) (|> +2.0 (f./ +3.0))] - [clash (|> +1.0 (f./ +4.0)) (|> +3.0 (f./ +4.0))] - [split_complement (|> +1.0 (f./ +5.0)) (|> +3.0 (f./ +5.0))] - ) - -(template [<name> <1> <2> <3>] - [(def: #export (<name> color) - (-> Color [Color Color Color Color]) - (let [[hue saturation luminance] (to_hsb color)] - [color - (from_hsb [(|> hue (f.+ <1>) ..normalize) - saturation - luminance]) - (from_hsb [(|> hue (f.+ <2>) ..normalize) - saturation - luminance]) - (from_hsb [(|> hue (f.+ <3>) ..normalize) - saturation - luminance])]))] - - [square (|> +1.0 (f./ +4.0)) (|> +2.0 (f./ +4.0)) (|> +3.0 (f./ +4.0))] - [tetradic (|> +2.0 (f./ +12.0)) (|> +6.0 (f./ +12.0)) (|> +8.0 (f./ +12.0))] - ) - -(type: #export Spread - Frac) - -(type: #export Palette - (-> Spread Nat Color (List Color))) - -(def: #export (analogous spread variations color) - (-> Spread Nat Color (List Color)) - (let [[hue saturation brightness] (to_hsb color) - spread (..normalize spread)] - (list\map (function (_ idx) - (from_hsb [(|> idx inc .int int.frac (f.* spread) (f.+ hue) ..normalize) - saturation - brightness])) - (list.indices variations)))) - -(def: #export (monochromatic spread variations color) - (-> Spread Nat Color (List Color)) - (let [[hue saturation brightness] (to_hsb color) - spread (..normalize spread)] - (|> (list.indices variations) - (list\map (|>> inc .int int.frac - (f.* spread) - (f.+ brightness) - ..normalize - [hue saturation] - from_hsb))))) - -(type: #export Alpha - Rev) - -(def: #export transparent - Alpha - rev\bottom) - -(def: #export translucent - Alpha - .5) - -(def: #export opaque - Alpha - rev\top) - -(type: #export Pigment - {#color Color - #alpha Alpha}) |