factor: trim using lists

[factor.git] / basis / colors / hsv / hsv.factor

diff --git a/basis/colors/hsv/hsv.factor b/basis/colors/hsv/hsv.factor
index e4451fcb1c10363937a3c28da003842ad3f4c7b3..0ebc0e58edec37637fb755d654189a9ddbff1661 100644 (file)
--- a/basis/colors/hsv/hsv.factor
+++ b/basis/colors/hsv/hsv.factor
@@ -1,18 +1,25 @@
 ! Copyright (C) 2008 Eduardo Cavazos.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: colors kernel combinators math math.functions accessors ;
+USING: accessors colors combinators kernel math math.functions
+random sequences sorting ;
 IN: colors.hsv
 
 ! h [0,360)
 ! s [0,1]
 ! v [0,1]
-TUPLE: hsva < color { hue read-only } { saturation read-only } { value read-only } { alpha read-only } ;
+TUPLE: hsva
+{ hue read-only }
+{ saturation read-only }
+{ value read-only }
+{ alpha read-only } ;
 
 C: <hsva> hsva
 
+INSTANCE: hsva color
+
 <PRIVATE
 
-: Hi ( hsv -- Hi ) hue>> 60 / floor 6 mod ; inline
+: Hi ( hsv -- Hi ) hue>> 60 / floor 6 mod >integer ; inline
 
 : f ( hsv -- f ) [ hue>> 60 / ] [ Hi ] bi - ; inline
 
@@ -24,7 +31,7 @@ C: <hsva> hsva
 
 PRIVATE>
 
-M: hsva >rgba ( hsva -- rgba )
+M: hsva >rgba
     [
         dup Hi
         {
@@ -35,4 +42,44 @@ M: hsva >rgba ( hsva -- rgba )
             { 4 [ [ t ] [ p ] [ value>> ] tri ] }
             { 5 [ [ value>> ] [ p ] [ q ] tri ] }
         } case
-    ] [ alpha>> ] bi <rgba> ;
+    ] [ alpha>> ] bi <rgba> ; inline
+
+<PRIVATE
+
+: sort-triple ( a b c -- d e f )
+    sort-pair [ sort-pair ] dip sort-pair ;
+
+PRIVATE>
+
+GENERIC: >hsva ( color -- hsva )
+
+M: object >hsva >rgba >hsva ;
+
+M: hsva >hsva ; inline
+
+M:: rgba >hsva ( rgba -- hsva )
+    rgba >rgba-components :> ( r g b a )
+    r g b sort-triple :> ( z y x )
+    x z = x zero? or [ 0 0 x a <hsva> ] [
+        {
+            { [ r x = g z = and ] [ 5 x b - x z - / + ] }
+            { [ r x = g z > and ] [ 1 x g - x z - / - ] }
+            { [ g x = b z = and ] [ 1 x r - x z - / + ] }
+            { [ g x = b z > and ] [ 3 x b - x z - / - ] }
+            { [ b x = r z = and ] [ 3 x g - x z - / + ] }
+            { [ b x = r z > and ] [ 5 x r - x z - / - ] }
+        } cond 6 / 360 * x z - x / x a <hsva>
+    ] if ;
+
+: complimentary-color ( color -- color' )
+    >hsva {
+        [ hue>> 180 + 360 mod ]
+        [ saturation>> ]
+        [ value>> ]
+        [ alpha>> ]
+    } cleave <hsva> ;
+
+: golden-rainbow ( num-colors saturation luminance -- colors )
+    [ random-unit ] 3dip '[
+        0.618033988749895 + 1.0 mod dup _ _ 1.0 <hsva>
+    ] replicate nip ;