1 ! Copyright (C) 2008 Eduardo Cavazos.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays colors combinators fry kernel locals
4 math math.functions random sequences sorting ;
12 { saturation read-only }
20 : Hi ( hsv -- Hi ) hue>> 60 / floor 6 mod >integer ; inline
22 : f ( hsv -- f ) [ hue>> 60 / ] [ Hi ] bi - ; inline
24 : p ( hsv -- p ) [ saturation>> 1 swap - ] [ value>> ] bi * ; inline
26 : q ( hsv -- q ) [ [ f ] [ saturation>> ] bi * 1 swap - ] [ value>> ] bi * ; inline
28 : t ( hsv -- t ) [ [ f 1 swap - ] [ saturation>> ] bi * 1 swap - ] [ value>> ] bi * ; inline
32 M: hsva >rgba ( hsva -- rgba )
36 { 0 [ [ value>> ] [ t ] [ p ] tri ] }
37 { 1 [ [ q ] [ value>> ] [ p ] tri ] }
38 { 2 [ [ p ] [ value>> ] [ t ] tri ] }
39 { 3 [ [ p ] [ q ] [ value>> ] tri ] }
40 { 4 [ [ t ] [ p ] [ value>> ] tri ] }
41 { 5 [ [ value>> ] [ p ] [ q ] tri ] }
43 ] [ alpha>> ] bi <rgba> ; inline
47 : sort-triple ( a b c -- d e f )
48 sort-pair [ sort-pair ] dip sort-pair ;
52 GENERIC: >hsva ( color -- hsva )
54 M: object >hsva >rgba >hsva ;
56 M: hsva >hsva ; inline
58 M:: rgba >hsva ( rgba -- hsva )
59 rgba >rgba-components :> ( r g b a )
60 r g b sort-triple :> ( z y x )
61 x z = x zero? or [ 0 0 x a <hsva> ] [
63 { [ r x = g z = and ] [ 5 x b - x z - / + ] }
64 { [ r x = g z > and ] [ 1 x g - x z - / - ] }
65 { [ g x = b z = and ] [ 1 x r - x z - / + ] }
66 { [ g x = b z > and ] [ 3 x b - x z - / - ] }
67 { [ b x = r z = and ] [ 3 x g - x z - / + ] }
68 { [ b x = r z > and ] [ 5 x r - x z - / - ] }
69 } cond 6 / 360 * x z - x / x a <hsva>
72 : complimentary-color ( color -- color' )
74 [ hue>> 180 + 360 mod ]
80 : golden-rainbow ( num-colors saturation luminance -- colors )
81 [ random-unit ] 3dip '[
82 0.618033988749895 + 1.0 mod dup _ _ 1.0 <hsva>