diff options
Diffstat (limited to 'stdlib/source/lux/data/color.lux')
| -rw-r--r-- | stdlib/source/lux/data/color.lux | 232 |
1 files changed, 116 insertions, 116 deletions
diff --git a/stdlib/source/lux/data/color.lux b/stdlib/source/lux/data/color.lux index f4799726f..61ee1249a 100644 --- a/stdlib/source/lux/data/color.lux +++ b/stdlib/source/lux/data/color.lux @@ -8,18 +8,18 @@ (def: rgb Nat +256) (def: top Nat (n.dec rgb)) -(def: nat-to-real (-> Nat Real) (|>. nat-to-int int-to-real)) -(def: real-to-nat (-> Real Nat) (|>. real-to-int int-to-nat)) +(def: nat-to-frac (-> Nat Frac) (|>. nat-to-int int-to-frac)) +(def: frac-to-nat (-> Frac Nat) (|>. frac-to-int int-to-nat)) -(def: rgb-factor Real (nat-to-real top)) +(def: rgb-factor Frac (nat-to-frac top)) (def: scale-down - (-> Nat Real) - (|>. nat-to-real (r./ rgb-factor))) + (-> Nat Frac) + (|>. nat-to-frac (f./ rgb-factor))) (def: scale-up - (-> Real Nat) - (|>. (r.* rgb-factor) real-to-nat)) + (-> Frac Nat) + (|>. (f.* rgb-factor) frac-to-nat)) (opaque: #export Color {} {#red Nat @@ -46,115 +46,115 @@ ) (def: #export (to-hsl color) - (-> Color [Real Real Real]) + (-> Color [Frac Frac Frac]) (let [[red green blue] (unpack color) red (scale-down red) green (scale-down green) blue (scale-down blue) - max ($_ r.max red green blue) - min ($_ r.min red green blue) - luminance (|> (r.+ max min) (r./ 2.0))] - (if (r.= max min) + 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 (r.- min)) + (let [diff (|> max (f.- min)) saturation (|> diff - (r./ (if (r.> 0.5 luminance) - (|> 2.0 (r.- max) (r.- min)) - (|> max (r.+ min))))) - hue' (cond (r.= red max) - (|> green (r.- blue) (r./ diff) - (r.+ (if (r.< blue green) 6.0 0.0))) + (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))) - (r.= green max) - (|> blue (r.- red) (r./ diff) - (r.+ 2.0)) + (f.= green max) + (|> blue (f.- red) (f./ diff) + (f.+ 2.0)) - ## (r.= blue max) - (|> red (r.- green) (r./ diff) - (r.+ 4.0)))] - [(|> hue' (r./ 6.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) - (-> Real Real Real Real) - (let [t (cond (r.< 0.0 t) (r.+ 1.0 t) - (r.> 1.0 t) (r.- 1.0 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 (r./ 3.0 2.0)] - (cond (r.< (r./ 6.0 1.0) t) - (|> q (r.- p) (r.* 6.0) (r.* t) (r.+ p)) + 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)) - (r.< (r./ 2.0 1.0) t) + (f.< (f./ 2.0 1.0) t) q - (r.< f2/3 t) - (|> q (r.- p) (r.* (|> f2/3 (r.- t))) (r.* 6.0) (r.+ p)) + (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]) - (-> [Real Real Real] Color) - (if (r.= 0.0 saturation) + (-> [Frac Frac Frac] Color) + (if (f.= 0.0 saturation) ## Achromatic (let [intensity (scale-up luminance)] (color [intensity intensity intensity])) ## Chromatic - (let [q (if (r.< 0.5 luminance) - (|> saturation (r.+ 1.0) (r.* luminance)) - (|> luminance (r.+ saturation) (r.- (r.* saturation luminance)))) - p (|> luminance (r.* 2.0) (r.- q)) - third (|> 1.0 (r./ 3.0))] - (color [(scale-up (|> hue (r.+ third) (hue-to-rgb p q))) + (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))] + (color [(scale-up (|> hue (f.+ third) (hue-to-rgb p q))) (scale-up (|> hue (hue-to-rgb p q))) - (scale-up (|> hue (r.- third) (hue-to-rgb p q)))])))) + (scale-up (|> hue (f.- third) (hue-to-rgb p q)))])))) (def: #export (to-hsb color) - (-> Color [Real Real Real]) + (-> Color [Frac Frac Frac]) (let [[red green blue] (unpack color) red (scale-down red) green (scale-down green) blue (scale-down blue) - max ($_ r.max red green blue) - min ($_ r.min red green blue) + max ($_ f.max red green blue) + min ($_ f.min red green blue) brightness max - diff (|> max (r.- min)) - saturation (if (r.= 0.0 max) + diff (|> max (f.- min)) + saturation (if (f.= 0.0 max) 0.0 - (|> diff (r./ max)))] - (if (r.= max min) + (|> diff (f./ max)))] + (if (f.= max min) ## Achromatic [0.0 saturation brightness] ## Chromatic - (let [hue (cond (r.= red max) - (|> green (r.- blue) (r./ diff) - (r.+ (if (r.< blue green) 6.0 0.0))) - - (r.= green max) - (|> blue (r.- red) (r./ diff) - (r.+ 2.0)) - - ## (r.= blue max) - (|> red (r.- green) (r./ diff) - (r.+ 4.0)))] - [(|> hue (r./ 6.0)) + (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]) - (-> [Real Real Real] Color) - (let [hue (|> hue (r.* 6.0)) + (-> [Frac Frac Frac] Color) + (let [hue (|> hue (f.* 6.0)) i (math;floor hue) - f (|> hue (r.- i)) - p (|> 1.0 (r.- saturation) (r.* brightness)) - q (|> 1.0 (r.- (r.* f saturation)) (r.* brightness)) - t (|> 1.0 (r.- (|> 1.0 (r.- f) (r.* saturation))) (r.* brightness)) + 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 (r.% 6.0) real-to-nat) + mod (|> i (f.% 6.0) frac-to-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))] @@ -163,51 +163,51 @@ (scale-up blue)]))) (def: #export (to-cmyk color) - (-> Color [Real Real Real Real]) + (-> Color [Frac Frac Frac Frac]) (let [[red green blue] (unpack color) red (scale-down red) green (scale-down green) blue (scale-down blue) - key (|> 1.0 (r.- ($_ r.max red green blue))) - f (if (r.< 1.0 key) - (|> 1.0 (r./ (|> 1.0 (r.- key)))) + 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 (r.- red) (r.- key) (r.* f)) - magenta (|> 1.0 (r.- green) (r.- key) (r.* f)) - yellow (|> 1.0 (r.- blue) (r.- key) (r.* f))] + 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 magenta yellow key])) (def: #export (from-cmyk [cyan magenta yellow key]) - (-> [Real Real Real Real] Color) - (if (r.= 1.0 key) + (-> [Frac Frac Frac Frac] Color) + (if (f.= 1.0 key) (color [+0 +0 +0]) - (let [red (|> (|> 1.0 (r.- cyan)) - (r.* (|> 1.0 (r.- key)))) - green (|> (|> 1.0 (r.- magenta)) - (r.* (|> 1.0 (r.- key)))) - blue (|> (|> 1.0 (r.- yellow)) - (r.* (|> 1.0 (r.- key))))] + (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))))] (color [(scale-up red) (scale-up green) (scale-up blue)])))) (def: (normalize ratio) - (-> Real Real) - (cond (r.> 1.0 ratio) - (r.% 1.0 ratio) + (-> Frac Frac) + (cond (f.> 1.0 ratio) + (f.% 1.0 ratio) - (r.< 0.0 ratio) - (|> 1.0 (r.+ (r.% 1.0 ratio))) + (f.< 0.0 ratio) + (|> 1.0 (f.+ (f.% 1.0 ratio))) ## else ratio)) (def: #export (interpolate ratio end start) - (-> Real Color Color Color) + (-> Frac Color Color Color) (let [dS (normalize ratio) - dE (|> 1.0 (r.- dS)) + dE (|> 1.0 (f.- dS)) interpolate' (: (-> Nat Nat Nat) (function [end start] - (real-to-nat (r.+ (r.* dE (nat-to-real end)) - (r.* dS (nat-to-real start)))))) + (frac-to-nat (f.+ (f.* dE (nat-to-frac end)) + (f.* dS (nat-to-frac start)))))) [redS greenS blueS] (unpack start) [redE greenE blueE] (unpack end)] (color [(interpolate' redE redS) @@ -219,7 +219,7 @@ (do-template [<name> <target>] [(def: #export (<name> ratio color) - (-> Real Color Color) + (-> Frac Color Color) (interpolate ratio <target> color))] [darker black] @@ -236,16 +236,16 @@ (do-template [<name> <op>] [(def: #export (<name> ratio color) - (-> Real Color Color) + (-> Frac Color Color) (let [[hue saturation luminance] (to-hsl color)] (from-hsl [hue (|> saturation - (r.* (|> 1.0 (<op> (normalize ratio)))) - (r.min 1.0)) + (f.* (|> 1.0 (<op> (normalize ratio)))) + (f.min 1.0)) luminance])))] - [saturate r.+] - [de-saturate r.-] + [saturate f.+] + [de-saturate f.-] ) (def: #export (gray-scale color) @@ -258,12 +258,12 @@ (-> Color [Color Color Color]) (let [[hue saturation luminance] (to-hsl color)] [color - (from-hsl [(|> hue (r.+ <1>) normalize) saturation luminance]) - (from-hsl [(|> hue (r.+ <2>) normalize) saturation luminance])]))] + (from-hsl [(|> hue (f.+ <1>) normalize) saturation luminance]) + (from-hsl [(|> hue (f.+ <2>) normalize) saturation luminance])]))] - [triad (|> 1.0 (r./ 3.0)) (|> 2.0 (r./ 3.0))] - [clash (|> 1.0 (r./ 4.0)) (|> 3.0 (r./ 4.0))] - [split-complement (|> 1.0 (r./ 5.0)) (|> 3.0 (r./ 5.0))] + [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))] ) (do-template [<name> <1> <2> <3>] @@ -271,22 +271,22 @@ (-> Color [Color Color Color Color]) (let [[hue saturation luminance] (to-hsl color)] [color - (from-hsl [(|> hue (r.+ <1>) normalize) saturation luminance]) - (from-hsl [(|> hue (r.+ <2>) normalize) saturation luminance]) - (from-hsl [(|> hue (r.+ <3>) normalize) saturation luminance])]))] + (from-hsl [(|> hue (f.+ <1>) normalize) saturation luminance]) + (from-hsl [(|> hue (f.+ <2>) normalize) saturation luminance]) + (from-hsl [(|> hue (f.+ <3>) normalize) saturation luminance])]))] - [square (|> 1.0 (r./ 4.0)) (|> 2.0 (r./ 4.0)) (|> 3.0 (r./ 4.0))] - [tetradic (|> 2.0 (r./ 12.0)) (|> 6.0 (r./ 12.0)) (|> 8.0 (r./ 12.0))] + [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))] ) (def: #export (analogous results slice color) - (-> Nat Real Color (List Color)) + (-> Nat Frac Color (List Color)) (if (n.= +0 results) (list) (let [[hue saturation luminance] (to-hsl color) slice (normalize slice)] (L/map (function [idx] - (from-hsl [(|> idx nat-to-real (r.* slice) (r.+ hue) normalize) + (from-hsl [(|> idx nat-to-frac (f.* slice) (f.+ hue) normalize) saturation luminance])) (list;n.range +0 (n.dec results)))))) @@ -296,11 +296,11 @@ (if (n.= +0 results) (list) (let [[hue saturation brightness] (to-hsb color) - slice (|> 1.0 (r./ (nat-to-real results)))] + slice (|> 1.0 (f./ (nat-to-frac results)))] (|> (list;n.range +0 (n.dec results)) - (L/map (|>. nat-to-real - (r.* slice) - (r.+ brightness) + (L/map (|>. nat-to-frac + (f.* slice) + (f.+ brightness) normalize [hue saturation] from-hsb)))))) |