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