colors.lch: implement CIELCH colors.

diff --git a/extra/colors/lch/authors.txt b/extra/colors/lch/authors.txt
new file mode 100644 (file)
index 0000000..e091bb8
--- /dev/null
+++ b/extra/colors/lch/authors.txt
@@ -0,0 +1 @@
+John Benediktsson

diff --git a/extra/colors/lch/lch-tests.factor b/extra/colors/lch/lch-tests.factor
new file mode 100644 (file)
index 0000000..9717a6f
--- /dev/null
+++ b/extra/colors/lch/lch-tests.factor
@@ -0,0 +1,31 @@
+! Copyright (C) 2014 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: arrays colors kernel locals math.functions math.ranges
+sequences tools.test ;
+
+IN: colors.lch
+
+{ t } [
+    0.0 1.0 0.1 <range> [| r |
+        0.0 1.0 0.1 <range> [| g |
+            0.0 1.0 0.1 <range> [| b |
+                r g b 1.0 <rgba> dup >LCHuv >rgba
+                [ >rgba-components 4array ] bi@
+                [ 0.00001 ~ ] 2all?
+            ] all?
+        ] all?
+    ] all?
+] unit-test
+
+{ t } [
+    0.0 1.0 0.1 <range> [| r |
+        0.0 1.0 0.1 <range> [| g |
+            0.0 1.0 0.1 <range> [| b |
+                r g b 1.0 <rgba> dup >LCHab >rgba
+                [ >rgba-components 4array ] bi@
+                [ 0.00001 ~ ] 2all?
+            ] all?
+        ] all?
+    ] all?
+] unit-test

diff --git a/extra/colors/lch/lch.factor b/extra/colors/lch/lch.factor
new file mode 100644 (file)
index 0000000..d09e1fb
--- /dev/null
+++ b/extra/colors/lch/lch.factor
@@ -0,0 +1,95 @@
+! Copyright (C) 2014 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: accessors colors colors.lab colors.luv colors.xyz kernel
+locals math math.constants math.functions math.libm ;
+
+IN: colors.lch
+
+TUPLE: LCHuv l c h alpha ;
+
+C: <LCHuv> LCHuv
+
+<PRIVATE
+
+: deg>rad ( degrees -- radians )
+    pi * 180 / ; inline
+
+: rad>deg ( radians -- degrees )
+    180 * pi / ; inline
+
+PRIVATE>
+
+M: LCHuv >rgba >luva >rgba ;
+
+M: LCHuv >xyza >luva >xyza ;
+
+M: LCHuv >luva
+    [
+        [let
+            [ l>> ] [ c>> ] [ h>> ] tri :> ( l c h )
+            h deg>rad :> hr
+
+            l
+            c hr cos *
+            c hr sin *
+        ]
+    ] [ alpha>> ] bi <luva> ;
+
+GENERIC: >LCHuv ( color -- LCHuv )
+
+M: object >LCHuv >luva >LCHuv ;
+
+M: LCHuv >LCHuv ; inline
+
+M: luva >LCHuv
+    [
+        [let
+            [ l>> ] [ u>> ] [ v>> ] tri :> ( l u v )
+            v u fatan2 rad>deg
+            [ dup 360 > ] [ 360 - ] while
+            [ dup 0 < ] [ 360 + ] while :> h
+
+            l
+            u sq v sq + sqrt
+            h
+        ]
+    ] [ alpha>> ] bi <LCHuv> ;
+
+TUPLE: LCHab l c h alpha ;
+
+C: <LCHab> LCHab
+
+M: LCHab >rgba >laba >rgba ;
+
+M: LCHab >laba
+    [
+        [let
+            [ l>> ] [ c>> ] [ h>> ] tri :> ( l c h )
+            h deg>rad :> hr
+
+            l
+            c hr cos *
+            c hr sin *
+        ]
+    ] [ alpha>> ] bi <laba> ;
+
+GENERIC: >LCHab ( color -- LCHab )
+
+M: object >LCHab >laba >LCHab ;
+
+M: LCHab >LCHab ; inline
+
+M: laba >LCHab
+    [
+        [let
+            [ l>> ] [ a>> ] [ b>> ] tri :> ( l a b )
+            b a fatan2 rad>deg
+            [ dup 360 > ] [ 360 - ] while
+            [ dup 0 < ] [ 360 + ] while :> h
+
+            l
+            a sq b sq + sqrt
+            h
+        ]
+    ] [ alpha>> ] bi <LCHab> ;

diff --git a/extra/colors/lch/summary.txt b/extra/colors/lch/summary.txt
new file mode 100644 (file)
index 0000000..bbfed8a
--- /dev/null
+++ b/extra/colors/lch/summary.txt
@@ -0,0 +1 @@
+CIELCH colors