--- /dev/null
+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" } ;
--- /dev/null
+! 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> ;