colors.luv: implement CIELUV colors.

extra/colors/luv/authors.txt

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

extra/colors/luv/luv-docs.factor

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

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

extra/colors/luv/luv.factor

@@ -0,0 +1,77 @@
+! Copyright (C) 2014 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: accessors colors colors.xyz kernel locals math
+math.functions ;
+
+IN: colors.luv
+
+TUPLE: luva l u v alpha ;
+
+C: <luva> luva
+
+<PRIVATE
+
+CONSTANT: xyz_epsilon 216/24389
+CONSTANT: xyz_kappa 24389/27
+
+:: xyz-to-uv ( x y z -- u v )
+    x y 15 * z 3 * + + :> d
+    4 x * d /
+    9 y * d / ; foldable
+
+CONSTANT: wp_x 0.95047
+CONSTANT: wp_y 1.00000
+CONSTANT: wp_z 1.08883
+
+PRIVATE>
+
+M: luva >rgba >xyza >rgba ;
+
+M: luva >xyza
+    [
+        [let
+            wp_x wp_y wp_z xyz-to-uv :> ( u_wp v_wp )
+            [ l>> ] [ u>> ] [ v>> ] tri :> ( l u v )
+
+            52 l * 13 l * u_wp * u + / 1 - 3 / :> a
+            l xyz_kappa xyz_epsilon * > [
+                l 16 + 116 / 3 ^ wp_y *
+            ] [
+                l xyz_kappa / wp_y *
+            ] if :> y
+            y -5 * :> b
+            39 l * 13 l * v_wp * v + / 5 - y * :> d
+            d b - a 1/3 + / :> x
+            a x * b + :> z
+
+            x y z
+        ]
+    ] [ alpha>> ] bi <xyza> ;
+
+GENERIC: >luva ( color -- luva )
+
+M: object >luva >xyza >luva ;
+
+M: luva >luva ; inline
+
+M: xyza >luva
+    [
+        [let
+            wp_x wp_y wp_z xyz-to-uv :> ( u_wp v_wp )
+            [ x>> ] [ y>> ] [ z>> ] tri :> ( x_ y_ z_ )
+            x_ y_ z_ xyz-to-uv :> ( u_ v_ )
+
+            y_ wp_y / :> y
+
+            y xyz_epsilon > [
+                y 1/3 ^ 116 * 16 -
+            ] [
+                xyz_kappa y *
+            ] if :> l
+            13 l * u_ u_wp - * :> u
+            13 l * v_ v_wp - * :> v
+
+            l u v
+        ]
+    ] [ alpha>> ] bi <luva> ;

extra/colors/luv/summary.txt

@@ -0,0 +1 @@
+CIELUV colors