From 0fb4bbb6f3cd557ec1f8a4ed9a5fde63f26cc9c5 Mon Sep 17 00:00:00 2001
From: John Benediktsson <mrjbq7@gmail.com>
Date: Fri, 20 Jun 2014 20:21:59 -0700
Subject: [PATCH] colors.xyz: implement CIE XYZ colors.

---
 extra/colors/xyz/authors.txt      |  1 +
 extra/colors/xyz/summary.txt      |  1 +
 extra/colors/xyz/xyz-docs.factor  | 14 ++++++++
 extra/colors/xyz/xyz-tests.factor | 19 +++++++++++
 extra/colors/xyz/xyz.factor       | 53 +++++++++++++++++++++++++++++++
 5 files changed, 88 insertions(+)
 create mode 100644 extra/colors/xyz/authors.txt
 create mode 100644 extra/colors/xyz/summary.txt
 create mode 100644 extra/colors/xyz/xyz-docs.factor
 create mode 100644 extra/colors/xyz/xyz-tests.factor
 create mode 100644 extra/colors/xyz/xyz.factor

diff --git a/extra/colors/xyz/authors.txt b/extra/colors/xyz/authors.txt
new file mode 100644
index 0000000000..e091bb8164
--- /dev/null
+++ b/extra/colors/xyz/authors.txt
@@ -0,0 +1 @@
+John Benediktsson
diff --git a/extra/colors/xyz/summary.txt b/extra/colors/xyz/summary.txt
new file mode 100644
index 0000000000..87566d01ab
--- /dev/null
+++ b/extra/colors/xyz/summary.txt
@@ -0,0 +1 @@
+XYZ colors
diff --git a/extra/colors/xyz/xyz-docs.factor b/extra/colors/xyz/xyz-docs.factor
new file mode 100644
index 0000000000..b08eac1e09
--- /dev/null
+++ b/extra/colors/xyz/xyz-docs.factor
@@ -0,0 +1,14 @@
+USING: help.markup help.syntax ;
+IN: colors.xyz
+
+HELP: xyza
+{ $class-description "The class of CIE XYZ colors with an alpha channel." } ;
+
+ARTICLE: "colors.xyz" "XYZ colors"
+"The " { $vocab-link "colors.xyz" } " vocabulary implements CIE XYZ colors, together with an alpha channel."
+{ $subsections
+    xyza
+    <xyza>
+    >xyza
+}
+{ $see-also "colors" } ;
diff --git a/extra/colors/xyz/xyz-tests.factor b/extra/colors/xyz/xyz-tests.factor
new file mode 100644
index 0000000000..0c0b1da834
--- /dev/null
+++ b/extra/colors/xyz/xyz-tests.factor
@@ -0,0 +1,19 @@
+! 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.xyz
+
+{ 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 >xyza >rgba
+                [ >rgba-components 4array ] bi@
+                [ 0.00001 ~ ] 2all?
+            ] all?
+        ] all?
+    ] all?
+] unit-test
diff --git a/extra/colors/xyz/xyz.factor b/extra/colors/xyz/xyz.factor
new file mode 100644
index 0000000000..3b1e368e47
--- /dev/null
+++ b/extra/colors/xyz/xyz.factor
@@ -0,0 +1,53 @@
+! Copyright (C) 2014 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: accessors colors kernel locals math math.functions
+math.order ;
+
+IN: colors.xyz
+
+TUPLE: xyza x y z alpha ;
+
+C: <xyza> xyza
+
+<PRIVATE
+
+: srgb-compand ( v -- v' )
+    dup 0.0031308 <= [ 12.92 * ] [ 2.4 recip ^ 1.055 * 0.055 - ] if ;
+
+PRIVATE>
+
+M: xyza >rgba
+    [
+        [let
+            [ x>> ] [ y>> ] [ z>> ] tri :> ( x y z )
+            x 3.2404542 * y -1.5371385 * z -0.4985314 * + +
+            x -0.9692660 * y 1.8760108 * z 0.0415560 * + +
+            x 0.0556434 * y -0.2040259 * z 1.0572252 * + +
+            [ srgb-compand 0.0 1.0 clamp ] tri@
+        ]
+    ] [ alpha>> ] bi <rgba> ;
+
+GENERIC: >xyza ( color -- xyza )
+
+M: object >xyza >rgba >xyza ;
+
+M: xyza >xyza ; inline
+
+<PRIVATE
+
+: invert-rgb-compand ( v -- v' )
+    dup 0.04045 <= [ 12.92 / ] [ 0.055 + 1.055 / 2.4 ^ ] if ;
+
+PRIVATE>
+
+M: rgba >xyza
+    [
+        [let
+            [ red>> ] [ green>> ] [ blue>> ] tri
+            [ invert-rgb-compand ] tri@ :> ( r g b )
+            r 0.4124564 * g 0.3575761 * b 0.1804375 * + +
+            r 0.2126729 * g 0.7151522 * b 0.0721750 * + +
+            r 0.0193339 * g 0.1191920 * b 0.9503041 * + +
+        ]
+    ] [ alpha>> ] bi <xyza> ;