colors.lab: implement CIELAB colors.

extra/colors/lab/authors.txt

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

extra/colors/lab/lab-docs.factor

@@ -0,0 +1,14 @@
+USING: help.markup help.syntax ;
+IN: colors.lab
+
+HELP: laba
+{ $class-description "The class of CIE 1976 LAB colors with an alpha channel." } ;
+
+ARTICLE: "colors.lab" "CIE 1976 LAB colors"
+"The " { $vocab-link "colors.lab" } " vocabulary implements CIE 1976 LAB colors, specifying luminance (in approximately " { $snippet "[0,100]" } "), red/green, and blue/yellow components, together with an alpha channel."
+{ $subsections
+    laba
+    <laba>
+    >laba
+}
+{ $see-also "colors" } ;

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

extra/colors/lab/lab.factor

@@ -0,0 +1,63 @@
+USING: accessors colors colors.xyz colors.xyz.private kernel
+locals math math.functions ;
+
+IN: colors.lab
+
+TUPLE: laba l a b alpha ;
+
+C: <laba> laba
+
+M: laba >rgba >xyza >rgba ;
+
+M: laba >xyza
+    [
+        [let
+            [ l>> ] [ a>> ] [ b>> ] tri :> ( l a b )
+            l 16 + 116 / :> fy
+            a 500 / fy + :> fx
+            fy b 200 / - :> fz
+
+            fx 3 ^ :> fx3
+            fz 3 ^ :> fz3
+
+            fx3 xyz_epsilon > [
+                fx3
+            ] [
+                116 fx * 16 - xyz_kappa /
+            ] if :> x
+
+            l xyz_kappa xyz_epsilon * > [
+                l 16 + 116 / 3 ^
+            ] [
+                l xyz_kappa /
+            ] if :> y
+
+            fz3 xyz_epsilon > [
+                fz3
+            ] [
+                116 fz * 16 - xyz_kappa /
+            ] if :> z
+
+            x wp_x * y wp_y * z wp_z *
+        ]
+    ] [ alpha>> ] bi <xyza> ;
+
+GENERIC: >laba ( color -- laba )
+
+M: object >laba >rgba >laba ;
+
+M: rgba >laba >xyza >laba ;
+
+M: xyza >laba
+    [
+        [let
+            [ x>> wp_x / ] [ y>> wp_y / ] [ z>> wp_z / ] tri
+            [
+                dup xyz_epsilon >
+                [ 1/3 ^ ] [ xyz_kappa * 16 + 116 / ] if
+            ] tri@ :> ( fx fy fz )
+            116 fy * 16 -
+            500 fx fy - *
+            200 fy fz - *
+        ]
+    ] [ alpha>> ] bi <laba> ;

extra/colors/lab/summary.txt

@@ -0,0 +1 @@
+CIE 1976 LAB colors