basis/colors/hsv/hsv.factor

   1 ! Copyright (C) 2008 Eduardo Cavazos.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors colors combinators kernel math math.functions
   4 random sequences sorting ;
   5 IN: colors.hsv
   6
   7 ! h [0,360)
   8 ! s [0,1]
   9 ! v [0,1]
  10 TUPLE: hsva
  11 { hue read-only }
  12 { saturation read-only }
  13 { value read-only }
  14 { alpha read-only } ;
  15
  16 C: <hsva> hsva
  17
  18 INSTANCE: hsva color
  19
  20 <PRIVATE
  21
  22 : Hi ( hsv -- Hi ) hue>> 60 / floor 6 mod >integer ; inline
  23
  24 : f ( hsv -- f ) [ hue>> 60 / ] [ Hi ] bi - ; inline
  25
  26 : p ( hsv -- p ) [ saturation>> 1 swap - ] [ value>> ] bi * ; inline
  27
  28 : q ( hsv -- q ) [ [ f ] [ saturation>> ] bi * 1 swap - ] [ value>> ] bi * ; inline
  29
  30 : t ( hsv -- t ) [ [ f 1 swap - ] [ saturation>> ] bi * 1 swap - ] [ value>> ] bi * ; inline
  31
  32 PRIVATE>
  33
  34 M: hsva >rgba
  35     [
  36         dup Hi
  37         {
  38             { 0 [ [ value>> ] [ t ] [ p ] tri ] }
  39             { 1 [ [ q ] [ value>> ] [ p ] tri ] }
  40             { 2 [ [ p ] [ value>> ] [ t ] tri ] }
  41             { 3 [ [ p ] [ q ] [ value>> ] tri ] }
  42             { 4 [ [ t ] [ p ] [ value>> ] tri ] }
  43             { 5 [ [ value>> ] [ p ] [ q ] tri ] }
  44         } case
  45     ] [ alpha>> ] bi <rgba> ; inline
  46
  47 <PRIVATE
  48
  49 : sort-triple ( a b c -- d e f )
  50     sort-pair [ sort-pair ] dip sort-pair ;
  51
  52 PRIVATE>
  53
  54 GENERIC: >hsva ( color -- hsva )
  55
  56 M: object >hsva >rgba >hsva ;
  57
  58 M: hsva >hsva ; inline
  59
  60 M:: rgba >hsva ( rgba -- hsva )
  61     rgba >rgba-components :> ( r g b a )
  62     r g b sort-triple :> ( z y x )
  63     x z = x zero? or [ 0 0 x a <hsva> ] [
  64         {
  65             { [ r x = g z = and ] [ 5 x b - x z - / + ] }
  66             { [ r x = g z > and ] [ 1 x g - x z - / - ] }
  67             { [ g x = b z = and ] [ 1 x r - x z - / + ] }
  68             { [ g x = b z > and ] [ 3 x b - x z - / - ] }
  69             { [ b x = r z = and ] [ 3 x g - x z - / + ] }
  70             { [ b x = r z > and ] [ 5 x r - x z - / - ] }
  71         } cond 6 / 360 * x z - x / x a <hsva>
  72     ] if ;
  73
  74 : complimentary-color ( color -- color' )
  75     >hsva {
  76         [ hue>> 180 + 360 mod ]
  77         [ saturation>> ]
  78         [ value>> ]
  79         [ alpha>> ]
  80     } cleave <hsva> ;
  81
  82 : golden-rainbow ( num-colors saturation luminance -- colors )
  83     [ random-unit ] 3dip '[
  84         0.618033988749895 + 1.0 mod dup _ _ 1.0 <hsva>
  85     ] replicate nip ;