colors.xyy: implement CIE xyY colors.

extra/colors/xyy/authors.txt

@@ -0,0 +1 @@
+John Benediktsson

extra/colors/xyy/summary.txt

@@ -0,0 +1 @@
+xyY colors

extra/colors/xyy/xyy-docs.factor

@@ -0,0 +1,14 @@
+USING: help.markup help.syntax ;
+IN: colors.xyy
+
+HELP: xyYa
+{ $class-description "The class of CIE xyY colors with an alpha channel." } ;
+
+ARTICLE: "colors.xyy" "xyY colors"
+"The " { $vocab-link "colors.xyy" } " vocabulary implements CIE xyY colors, together with an alpha channel."
+{ $subsections
+    xyYa
+    <xyYa>
+    >xyYa
+}
+{ $see-also "colors" } ;

extra/colors/xyy/xyy-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.xyy
+
+{ 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 >xyYa >rgba
+                [ >rgba-components 4array ] bi@
+                [ 0.00001 ~ ] 2all?
+            ] all?
+        ] all?
+    ] all?
+] unit-test

extra/colors/xyy/xyy.factor

@@ -0,0 +1,40 @@
+! Copyright (C) 2014 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: accessors colors colors.xyz kernel locals math ;
+
+IN: colors.xyy
+
+TUPLE: xyYa x y Y alpha ;
+
+C: <xyYa> xyYa
+
+M: xyYa >rgba
+    >xyza >rgba ;
+
+M: xyYa >xyza
+    [
+        [let
+            [ x>> ] [ y>> ] [ Y>> ] tri :> ( x y Y )
+            x y / Y *
+            Y
+            1 x - y - y / Y *
+        ]
+    ] [ alpha>> ] bi <xyza> ;
+
+GENERIC: >xyYa ( color -- xyYa )
+
+M: object >xyYa >xyza >xyYa ;
+
+M: xyYa >xyYa ; inline
+
+M: xyza >xyYa
+    [
+        [let
+            [ x>> ] [ y>> ] [ z>> ] tri :> ( x y z )
+            x y z + +
+            [ x swap / ]
+            [ y swap / ] bi
+            y
+        ]
+    ] [ alpha>> ] bi <xyYa> ;