colors.hcl: adding HCL color space

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

diff --git a/basis/colors/hcl/hcl-docs.factor b/basis/colors/hcl/hcl-docs.factor
new file mode 100644 (file)
index 0000000..80bcb65
--- /dev/null
+++ b/basis/colors/hcl/hcl-docs.factor
@@ -0,0 +1,17 @@
+USING: help.markup help.syntax ;
+IN: colors.hcl
+
+HELP: hcla
+{ $class-description "The class of HCL (Hue, Chroma, Luminance) colors with an alpha channel. All slots store values in the interval " { $snippet "[0,1]" } "." } ;
+
+ARTICLE: "colors.hcl" "HCL colors"
+"The " { $vocab-link "colors.hcl" } " vocabulary implements colors specified by their hue, chroma, and luminance components, together with an alpha channel."
+{ $subsections
+    hcla
+    <hcla>
+    >hcla
+}
+"The HCL color space is simply the polar representation of the CIELUV color space. For more information."
+{ $see-also "colors" "colors.luv" } ;
+
+ABOUT: "colors.hcl"

diff --git a/basis/colors/hcl/hcl-tests.factor b/basis/colors/hcl/hcl-tests.factor
new file mode 100644 (file)
index 0000000..8c5f6d9
--- /dev/null
+++ b/basis/colors/hcl/hcl-tests.factor
@@ -0,0 +1,17 @@
+! Copyright (C) 2022 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: arrays colors colors.hcl kernel locals math.functions
+ranges sequences tools.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 >hcla >rgba
+                [ >rgba-components 4array ] bi@
+                [ 0.00001 ~ ] 2all?
+            ] all?
+        ] all?
+    ] all?
+] unit-test

diff --git a/basis/colors/hcl/hcl.factor b/basis/colors/hcl/hcl.factor
new file mode 100644 (file)
index 0000000..64dd655
--- /dev/null
+++ b/basis/colors/hcl/hcl.factor
@@ -0,0 +1,61 @@
+! Copyright (C) 2022 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: accessors colors colors.luv combinators kernel locals math
+math.constants math.functions math.libm math.order ;
+
+IN: colors.hcl
+
+TUPLE: hcla
+{ hue read-only }
+{ chroma read-only }
+{ luminance read-only }
+{ alpha read-only } ;
+
+C: <hcla> hcla
+
+INSTANCE: hcla color
+
+<PRIVATE
+
+: deg2rad ( degree -- radian ) pi 180.0 / * ; inline
+
+: rad2deg ( radian -- degree ) 180.0 pi / * ; inline
+
+PRIVATE>
+
+M: hcla >luva
+    [let
+        {
+            [ hue>> ] [ chroma>> ] [ luminance>> ] [ alpha>> ]
+        } cleave :> ( h c l a )
+
+        l
+        h deg2rad :> angle
+        c angle cos *
+        c angle sin *
+        a
+        <luva>
+    ] ;
+
+M: hcla >rgba >luva >rgba ;
+
+GENERIC: >hcla ( color -- hcla )
+
+M: object >hcla >luva >hcla ;
+
+M: hcla >hcla ; inline
+
+M: luva >hcla
+    [let
+        {
+            [ l>> ] [ u>> ] [ v>> ] [ alpha>> ]
+        } cleave :> ( l u v a )
+
+        u sq v sq + sqrt :> c
+        v u fatan2 rad2deg
+        [ dup 360 > ] [ 360 - ] while
+        [ dup 0 < ] [ 360 + ] while :> h
+
+        h c l a <hcla>
+    ] ;

diff --git a/basis/colors/hcl/summary.txt b/basis/colors/hcl/summary.txt
new file mode 100644 (file)
index 0000000..4911790
--- /dev/null
+++ b/basis/colors/hcl/summary.txt
@@ -0,0 +1 @@
+HCL colors