basis/colors/hsl/hsl.factor

   1 ! Copyright (C) 2012 John Benediktsson
   2 ! See http://factorcode.org/license.txt for BSD license
   3
   4 USING: accessors colors combinators kernel math math.order ;
   5
   6 IN: colors.hsl
   7
   8 TUPLE: hsla
   9 { hue read-only }
  10 { saturation read-only }
  11 { lightness read-only }
  12 { alpha read-only } ;
  13
  14 C: <hsla> hsla
  15
  16 INSTANCE: hsla color
  17
  18 <PRIVATE
  19
  20 : value ( p q t -- value )
  21     dup 0 < [ 1.0 + ] when
  22     dup 1 > [ 1.0 - ] when
  23     {
  24         { [ dup 1/6 < ] [ [ over - ] dip * 6 * + ] }
  25         { [ dup 1/2 < ] [ drop nip ] }
  26         { [ dup 2/3 < ] [ [ over - ] dip 2/3 swap - * 6 * + ] }
  27         [ 2drop ]
  28     } cond ;
  29
  30 PRIVATE>
  31
  32 M: hsla >rgba
  33     {
  34         [ hue>> ] [ saturation>> ] [ lightness>> ] [ alpha>> ]
  35     } cleave [| h s l |
  36         s zero? [
  37             l l l
  38         ] [
  39             l 0.5 < [ l s 1 + * ] [ l s + l s * - ] if :> q
  40             l 2 * q - :> p
  41             p q h 1/3 + value
  42             p q h value
  43             p q h 1/3 - value
  44         ] if
  45     ] dip <rgba> ; inline
  46
  47 GENERIC: >hsla ( color -- hsla )
  48
  49 M: object >hsla >rgba >hsla ;
  50
  51 M: hsla >hsla ; inline
  52
  53 M: rgba >hsla
  54     >rgba-components [| r g b |
  55         r g b min min :> min-c
  56         r g b max max :> max-c
  57         min-c max-c + 2 / :> l
  58         max-c min-c - :> d
  59         d zero? [ 0.0 0.0 ] [
  60             max-c {
  61                 { r [ g b - d / g b < 6.0 0.0 ? + ] }
  62                 { g [ b r - d / 2.0 + ] }
  63                 { b [ r g - d / 4.0 + ] }
  64             } case 6.0 /
  65             l 0.5 > [
  66                 d 2 max-c - min-c - /
  67             ] [
  68                 d max-c min-c + /
  69             ] if
  70         ] if l
  71     ] dip <hsla> ;