From 20a398ec160d284f741460c974b39b1a08ca8e1f Mon Sep 17 00:00:00 2001
From: John Benediktsson <mrjbq7@gmail.com>
Date: Mon, 22 Oct 2012 15:19:51 -0700
Subject: [PATCH] colors.hsl: adding HSL color support.

---
 extra/colors/hsl/authors.txt     |  1 +
 extra/colors/hsl/hsl-docs.factor | 14 +++++++
 extra/colors/hsl/hsl.factor      | 64 ++++++++++++++++++++++++++++++++
 extra/colors/hsl/summary.txt     |  1 +
 4 files changed, 80 insertions(+)
 create mode 100644 extra/colors/hsl/authors.txt
 create mode 100644 extra/colors/hsl/hsl-docs.factor
 create mode 100644 extra/colors/hsl/hsl.factor
 create mode 100644 extra/colors/hsl/summary.txt

diff --git a/extra/colors/hsl/authors.txt b/extra/colors/hsl/authors.txt
new file mode 100644
index 0000000000..e091bb8164
--- /dev/null
+++ b/extra/colors/hsl/authors.txt
@@ -0,0 +1 @@
+John Benediktsson
diff --git a/extra/colors/hsl/hsl-docs.factor b/extra/colors/hsl/hsl-docs.factor
new file mode 100644
index 0000000000..38eedc6a51
--- /dev/null
+++ b/extra/colors/hsl/hsl-docs.factor
@@ -0,0 +1,14 @@
+USING: help.markup help.syntax ;
+IN: colors.hsl
+
+HELP: hsla
+{ $class-description "The class of HSL (Hue, Saturation, Lightness) colors with an alpha channel. All slots store values in the interval " { $snippet "[0,1]" } "." } ;
+
+ARTICLE: "colors.hsl" "HSL colors"
+"THe " { $vocab-link "colors.hsl" } " vocabulary implements colors specified by their hue, saturation, and lightness components, together with an alpha channel."
+{ $subsections
+    hsla
+    <hsla>
+    rgba>hsla
+}
+{ $see-also "colors" } ;
diff --git a/extra/colors/hsl/hsl.factor b/extra/colors/hsl/hsl.factor
new file mode 100644
index 0000000000..90478dfe32
--- /dev/null
+++ b/extra/colors/hsl/hsl.factor
@@ -0,0 +1,64 @@
+! Copyright (C) 2012 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: accessors colors combinators kernel locals math
+math.order ;
+
+IN: colors.hsl
+
+TUPLE: hsla < color
+{ hue read-only }
+{ saturation read-only }
+{ lightness read-only }
+{ alpha read-only } ;
+
+C: <hsla> hsla
+
+<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: hsla >rgba
+    {
+        [ hue>> ] [ saturation>> ] [ lightness>> ] [ alpha>> ]
+    } cleave [| h s l |
+        s zero? [
+            l l l
+        ] [
+            l 0.5 < [ l s 1 + * ] [ l s + l s * - ] if :> q
+            l 2 * q - :> p
+            p q h 1/3 + value
+            p q h value
+            p q h 1/3 - value
+        ] if
+    ] dip <rgba> ;
+
+: rgba>hsla ( rgba -- hsla )
+    >rgba-components [| r g b |
+        r g b min min :> min-c
+        r g b max max :> max-c
+        min-c max-c + 2 / :> l
+        max-c min-c - :> d
+        d zero? [ 0.0 0.0 ] [
+            max-c {
+                { r [ g b - d / g b < 6.0 0.0 ? + ] }
+                { g [ b r - d / 2.0 + ] }
+                { b [ r g - d / 4.0 + ] }
+            } case 6.0 /
+            l 0.5 > [
+                d 2 max-c - min-c - /
+            ] [
+                d max-c min-c + /
+            ] if
+        ] if l
+    ] dip <hsla> ;
diff --git a/extra/colors/hsl/summary.txt b/extra/colors/hsl/summary.txt
new file mode 100644
index 0000000000..063c135541
--- /dev/null
+++ b/extra/colors/hsl/summary.txt
@@ -0,0 +1 @@
+HSL colors