colors.hwb: adding HWB (Hue, Whiteness, Blackness) colors

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

diff --git a/basis/colors/hwb/hwb-docs.factor b/basis/colors/hwb/hwb-docs.factor
new file mode 100644 (file)
index 0000000..5072eb3
--- /dev/null
+++ b/basis/colors/hwb/hwb-docs.factor
@@ -0,0 +1,16 @@
+USING: help.markup help.syntax ;
+IN: colors.hwb
+
+HELP: hwba
+{ $class-description "The class of HWB (Hue, Whiteness, Blackness) colors with an alpha channel. All slots store values in the interval " { $snippet "[0,1]" } "." } ;
+
+ARTICLE: "colors.hwb" "HWB colors"
+"The " { $vocab-link "colors.hwb" } " vocabulary implements colors specified by their hue, whiteness and blackness components, together with an alpha channel."
+{ $subsections
+    hwba
+    <hwba>
+    >hwba
+}
+{ $see-also "colors" } ;
+
+ABOUT: "colors.hwb"

diff --git a/basis/colors/hwb/hwb-tests.factor b/basis/colors/hwb/hwb-tests.factor
new file mode 100644 (file)
index 0000000..43c902b
--- /dev/null
+++ b/basis/colors/hwb/hwb-tests.factor
@@ -0,0 +1,15 @@
+! Copyright (C) 2022 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: arrays colors colors.hwb 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 >hwba color=
+            ] all?
+        ] all?
+    ] all?
+] unit-test

diff --git a/basis/colors/hwb/hwb.factor b/basis/colors/hwb/hwb.factor
new file mode 100644 (file)
index 0000000..66efc80
--- /dev/null
+++ b/basis/colors/hwb/hwb.factor
@@ -0,0 +1,61 @@
+! Copyright (C) 2022 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: accessors colors colors.gray colors.hsl combinators
+kernel locals math math.order ;
+
+IN: colors.hwb
+
+TUPLE: hwba
+{ hue read-only }
+{ whiteness read-only }
+{ blackness read-only }
+{ alpha read-only } ;
+
+C: <hwba> hwba
+
+INSTANCE: hwba color
+
+<PRIVATE
+
+: value ( p q t -- value )
+    dup 0 < [ 1.0 + ] when
+    dup 1 > [ 1.0 - ] when
+    {
+        { [ dup 1/6 < ] [ [ over - ] dip * 6 * + ] }
+        { [ dup 1/2 < ] [ drop nip ] }
+        { [ dup 2/3 < ] [ [ over - ] dip 2/3 swap - * 6 * + ] }
+        [ 2drop ]
+    } cond ;
+
+PRIVATE>
+
+M: hwba >rgba
+    [let
+        {
+            [ hue>> ] [ whiteness>> ] [ blackness>> ] [ alpha>> ]
+        } cleave :> ( h w b a )
+
+        w b + :> w+b
+
+        w+b 1 >= [
+            w w+b / a <gray>
+        ] [
+            h 1.0 0.5 a <hsla> >rgba-components
+            [ [ 1 w+b - * w + ] tri@ ] dip <rgba>
+        ] if
+    ] ; inline
+
+GENERIC: >hwba ( color -- hsla )
+
+M: object >hwba >rgba >hwba ;
+
+M: hwba >hwba ; inline
+
+M: rgba >hwba
+    [let
+        >hsla [ hue>> ] [ >rgba-components ] bi :> ( h r g b a )
+        r g b min min :> w
+        r g b max max 1 swap - :> b
+        h w b a <hwba>
+    ] ;

diff --git a/basis/colors/hwb/summary.txt b/basis/colors/hwb/summary.txt
new file mode 100644 (file)
index 0000000..033bb23
--- /dev/null
+++ b/basis/colors/hwb/summary.txt
@@ -0,0 +1 @@
+HWB colors