- Added module for color computations.

2 files changed, 402 insertions, 0 deletions

diff --git a/stdlib/source/lux/data/color.lux b/stdlib/source/lux/data/color.lux
new file mode 100644
index 000000000..f4799726f
--- /dev/null
+++ b/stdlib/source/lux/data/color.lux
@@ -0,0 +1,306 @@
+(;module:
+  lux
+  (lux (control [eq])
+       (data (coll [list "L/" Functor<List>]))
+       [math]
+       (type opaque)))
+
+(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: rgb-factor Real (nat-to-real top))
+
+(def: scale-down
+  (-> Nat Real)
+  (|>. nat-to-real (r./ rgb-factor)))
+
+(def: scale-up
+  (-> Real Nat)
+  (|>. (r.* rgb-factor) real-to-nat))
+
+(opaque: #export Color {}
+  {#red Nat
+   #green Nat
+   #blue Nat}
+
+  (def: #export (color [red green blue])
+    (-> [Nat Nat Nat] Color)
+    (@opaque [(n.% rgb red)
+              (n.% rgb green)
+              (n.% rgb blue)]))
+
+  (def: #export unpack
+    (-> Color [Nat Nat Nat])
+    (|>. @repr))
+
+  (struct: #export _ (eq;Eq Color)
+    (def: (= reference sample)
+      (let [[rr rg rb] (@repr reference)
+            [sr sg sb] (@repr sample)]
+        (and (n.= rr sr)
+             (n.= rg sg)
+             (n.= rb sb)))))
+  )
+
+(def: #export (to-hsl color)
+  (-> Color [Real Real Real])
+  (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)
+      ## Achromatic
+      [0.0 0.0 luminance]
+      ## Chromatic
+      (let [diff (|> max (r.- 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)))
+                       
+                       (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))
+         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)
+                ## 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))
+          
+          (r.< (r./ 2.0 1.0) t)
+          q
+          
+          (r.< f2/3 t)
+          (|> q (r.- p) (r.* (|> f2/3 (r.- t))) (r.* 6.0) (r.+ p))
+          
+          ## else
+          p)))
+
+(def: #export (from-hsl [hue saturation luminance])
+  (-> [Real Real Real] Color)
+  (if (r.= 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)))
+              (scale-up (|> hue (hue-to-rgb p q)))
+              (scale-up (|> hue (r.- third) (hue-to-rgb p q)))]))))
+
+(def: #export (to-hsb color)
+  (-> Color [Real Real Real])
+  (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)
+        brightness max
+        diff (|> max (r.- min))
+        saturation (if (r.= 0.0 max)
+                     0.0
+                     (|> diff (r./ max)))]
+    (if (r.= 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))
+         saturation
+         brightness]))))
+
+(def: #export (from-hsb [hue saturation brightness])
+  (-> [Real Real Real] Color)
+  (let [hue (|> hue (r.* 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))
+        v brightness
+        mod (|> i (r.% 6.0) real-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))]
+    (color [(scale-up red)
+            (scale-up green)
+            (scale-up blue)])))
+
+(def: #export (to-cmyk color)
+  (-> Color [Real Real Real Real])
+  (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))))
+            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 magenta yellow key]))
+
+(def: #export (from-cmyk [cyan magenta yellow key])
+  (-> [Real Real Real Real] Color)
+  (if (r.= 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))))]
+      (color [(scale-up red) (scale-up green) (scale-up blue)]))))
+
+(def: (normalize ratio)
+  (-> Real Real)
+  (cond (r.> 1.0 ratio)
+        (r.% 1.0 ratio)
+
+        (r.< 0.0 ratio)
+        (|> 1.0 (r.+ (r.% 1.0 ratio)))
+
+        ## else
+        ratio))
+
+(def: #export (interpolate ratio end start)
+  (-> Real Color Color Color)
+  (let [dS (normalize ratio)
+        dE (|> 1.0 (r.- dS))
+        interpolate' (: (-> Nat Nat Nat)
+                        (function [end start]
+                          (real-to-nat (r.+ (r.* dE (nat-to-real end))
+                                            (r.* dS (nat-to-real start))))))
+        [redS greenS blueS] (unpack start)
+        [redE greenE blueE] (unpack end)]
+    (color [(interpolate' redE redS)
+            (interpolate' greenE greenS)
+            (interpolate' blueE blueS)])))
+
+(def: black Color (color [+0 +0 +0]))
+(def: white Color (color [top top top]))
+
+(do-template [<name> <target>]
+  [(def: #export (<name> ratio color)
+     (-> Real Color Color)
+     (interpolate ratio <target> color))]
+
+  [darker   black]
+  [brighter white]
+  )
+
+(def: #export (complement color)
+  (-> Color Color)
+  (let [[red green blue] (unpack color)
+        adjust (function [value] (|> top (n.- value)))]
+    (;;color [(adjust red)
+              (adjust green)
+              (adjust blue)])))
+
+(do-template [<name> <op>]
+  [(def: #export (<name> ratio color)
+     (-> Real Color Color)
+     (let [[hue saturation luminance] (to-hsl color)]
+       (from-hsl [hue
+                  (|> saturation
+                      (r.* (|> 1.0 (<op> (normalize ratio))))
+                      (r.min 1.0))
+                  luminance])))]
+
+  [saturate    r.+]
+  [de-saturate r.-]
+  )
+
+(def: #export (gray-scale color)
+  (-> Color Color)
+  (let [[_ _ luminance] (to-hsl color)]
+    (from-hsl [0.0 0.0 luminance])))
+
+(do-template [<name> <1> <2>]
+  [(def: #export (<name> 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])]))]
+
+  [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))]
+  )
+
+(do-template [<name> <1> <2> <3>]
+  [(def: #export (<name> color)
+     (-> 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])]))]
+
+  [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))]
+  )
+
+(def: #export (analogous results slice color)
+  (-> Nat Real 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)
+                          saturation
+                          luminance]))
+             (list;n.range +0 (n.dec results))))))
+
+(def: #export (monochromatic results color)
+  (-> Nat Color (List Color))
+  (if (n.= +0 results)
+    (list)
+    (let [[hue saturation brightness] (to-hsb color)
+          slice (|> 1.0 (r./ (nat-to-real results)))]
+      (|> (list;n.range +0 (n.dec results))
+          (L/map (|>. nat-to-real
+                      (r.* slice)
+                      (r.+ brightness)
+                      normalize
+                      [hue saturation]
+                      from-hsb))))))
diff --git a/stdlib/test/test/lux/data/color.lux b/stdlib/test/test/lux/data/color.lux
new file mode 100644
index 000000000..0187f9430
--- /dev/null
+++ b/stdlib/test/test/lux/data/color.lux
@@ -0,0 +1,96 @@
+(;module:
+  lux
+  (lux [io]
+       (control [monad #+ do])
+       (data ["@" color]
+             [number "real/" Number<Real>])
+       [math]
+       ["r" math/random])
+  lux/test)
+
+(def: color
+  (r;Random @;Color)
+  (|> ($_ r;seq r;nat r;nat r;nat)
+      (:: r;Monad<Random> map @;color)))
+
+(def: scale
+  (-> Nat Real)
+  (|>. nat-to-int int-to-real))
+
+(def: square (-> Real Real) (math;pow 2.0))
+
+(def: (distance from to)
+  (-> @;Color @;Color Real)
+  (let [[fr fg fb] (@;unpack from)
+        [tr tg tb] (@;unpack to)]
+    (math;root2 ($_ r.+
+                    (|> (scale tr) (r.- (scale fr)) square)
+                    (|> (scale tg) (r.- (scale fg)) square)
+                    (|> (scale tb) (r.- (scale fb)) square)))))
+
+(def: error-margin Real 1.8)
+
+(def: black @;Color (@;color [+0 +0 +0]))
+(def: white @;Color (@;color [+255 +255 +255]))
+
+(do-template [<field>]
+  [(def: (<field> color)
+     (-> @;Color Real)
+     (let [[hue saturation luminance] (@;to-hsl color)]
+       <field>))]
+
+  [saturation]
+  [luminance]
+  )
+
+(context: "Color."
+  [any color
+   colorful (|> color
+                (r;filter (function [color] (|> (distance color black) (r.>= 100.0))))
+                (r;filter (function [color] (|> (distance color white) (r.>= 100.0)))))
+   mediocre (|> color
+                (r;filter (|>. saturation
+                               ((function [saturation]
+                                  (and (r.>= 0.25 saturation)
+                                       (r.<= 0.75 saturation)))))))
+   ratio (|> r;real (r;filter (r.>= 0.5)))]
+  ($_ seq
+      (test "Has equality."
+            (:: @;Eq<Color> = any any))
+      (test "Can convert to/from HSL."
+            (|> any @;to-hsl @;from-hsl
+                (distance any)
+                (r.<= error-margin)))
+      (test "Can convert to/from HSB."
+            (|> any @;to-hsb @;from-hsb
+                (distance any)
+                (r.<= error-margin)))
+      (test "Can convert to/from CMYK."
+            (|> any @;to-cmyk @;from-cmyk
+                (distance any)
+                (r.<= error-margin)))
+      (test "Can interpolate between 2 colors."
+            (and (r.<= (distance colorful black)
+                       (distance (@;darker ratio colorful) black))
+                 (r.<= (distance colorful white)
+                       (distance (@;brighter ratio colorful) white))))
+      (test "Can calculate complement."
+            (let [~any (@;complement any)
+                  (^open "@/") @;Eq<Color>]
+              (and (not (@/= any ~any))
+                   (@/= any (@;complement ~any)))))
+      (test "Can saturate color."
+            (r.> (saturation mediocre)
+                 (saturation (@;saturate ratio mediocre))))
+      (test "Can de-saturate color."
+            (r.< (saturation mediocre)
+                 (saturation (@;de-saturate ratio mediocre))))
+      (test "Can gray-scale color."
+            (let [gray'ed (@;gray-scale mediocre)]
+              (and (r.= 0.0
+                        (saturation gray'ed))
+                   (|> (luminance gray'ed)
+                       (r.- (luminance mediocre))
+                       real/abs
+                       (r.<= error-margin)))))
+      ))