Move hsva to colors.hsv

basis/colors/colors.factor

@@ -1,48 +1,33 @@
-! Copyright (C) 2003, 2007, 2008 Slava Pestov.
+! Copyright (C) 2003, 2008 Slava Pestov.
+! Copyright (C) 2008 Eduardo Cavazos.
 ! See http://factorcode.org/license.txt for BSD license.
-
+USING: kernel accessors ;
-USING: kernel combinators sequences arrays classes.tuple accessors colors.hsv ;
-
 IN: colors
 
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
 TUPLE: color ;
 
 TUPLE: rgba < color red green blue alpha ;
 
-TUPLE: hsva < color hue saturation value alpha ;
+C: <rgba> rgba
-
-TUPLE: gray < color gray alpha ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 GENERIC: >rgba ( object -- rgba )
 
 M: rgba >rgba ( rgba -- rgba ) ;
 
-M: hsva >rgba ( hsva -- rgba )
-  { [ hue>> ] [ saturation>> ] [ value>> ] [ alpha>> ] } cleave 4array
-  [ hsv>rgb ] [ peek ] bi suffix first4 rgba boa ;
-
-M: gray >rgba ( gray -- rgba ) [ gray>> dup dup ] [ alpha>> ] bi rgba boa ;
-
 M: color red>>   ( color -- red   ) >rgba red>>   ;
 M: color green>> ( color -- green ) >rgba green>> ;
 M: color blue>>  ( color -- blue  ) >rgba blue>>  ;
 
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+: black        T{ rgba f 0.0   0.0   0.0   1.0  } ; inline
-
+: blue         T{ rgba f 0.0   0.0   1.0   1.0  } ; inline
-: black        T{ rgba f 0.0   0.0   0.0   1.0  } ;
+: cyan         T{ rgba f 0     0.941 0.941 1    } ; inline
-: blue         T{ rgba f 0.0   0.0   1.0   1.0  } ;
+: gray         T{ rgba f 0.6   0.6   0.6   1.0  } ; inline
-: cyan         T{ rgba f 0     0.941 0.941 1    } ;
+: green        T{ rgba f 0.0   1.0   0.0   1.0  } ; inline
-: gray         T{ rgba f 0.6   0.6   0.6   1.0  } ;
+: light-gray   T{ rgba f 0.95  0.95  0.95  0.95 } ; inline
-: green        T{ rgba f 0.0   1.0   0.0   1.0  } ;
+: light-purple T{ rgba f 0.8   0.8   1.0   1.0  } ; inline
-: light-gray   T{ rgba f 0.95  0.95  0.95  0.95 } ;
+: magenta      T{ rgba f 0.941 0     0.941 1    } ; inline
-: light-purple T{ rgba f 0.8   0.8   1.0   1.0  } ;
+: orange       T{ rgba f 0.941 0.627 0     1    } ; inline
-: magenta      T{ rgba f 0.941 0     0.941 1    } ;
+: purple       T{ rgba f 0.627 0     0.941 1    } ; inline
-: orange       T{ rgba f 0.941 0.627 0     1    } ;
+: red          T{ rgba f 1.0   0.0   0.0   1.0  } ; inline
-: purple       T{ rgba f 0.627 0     0.941 1    } ;
+: white        T{ rgba f 1.0   1.0   1.0   1.0  } ; inline
-: red          T{ rgba f 1.0   0.0   0.0   1.0  } ;
+: yellow       T{ rgba f 1.0   1.0   0.0   1.0  } ; inline
-: white        T{ rgba f 1.0   1.0   1.0   1.0  } ;
-: yellow       T{ rgba f 1.0   1.0   0.0   1.0  } ;

basis/colors/gray/gray.factor

@@ -0,0 +1,11 @@
+! Copyright (C) 2008 Eduardo Cavazos.
+! See http://factorcode.org/license.txt for BSD license.
+USING: colors kernel accessors ;
+IN: colors.gray
+
+TUPLE: gray < color gray alpha ;
+
+C: <gray> gray
+
+M: gray >rgba ( gray -- rgba )
+    [ gray>> dup dup ] [ alpha>> ] bi <rgba> ;

basis/colors/hsv/hsv-tests.factor

@@ -0,0 +1,26 @@
+IN: colors.hsv.tests
+USING: accessors kernel colors colors.hsv tools.test math ;
+
+: hsv>rgb ( h s v -- r g b )
+    [ 360 * ] 2dip
+    1 <hsva> >rgba [ red>> ] [ green>> ] [ blue>> ] tri ;
+
+[ 1/2 1/2 1/2 ] [ 0 0 1/2 hsv>rgb ] unit-test
+
+[ 1/2 1/4 1/4 ] [ 0 1/2 1/2 hsv>rgb ] unit-test
+[ 1/3 2/9 2/9 ] [ 0 1/3 1/3 hsv>rgb ] unit-test
+
+[ 24/125 1/5 4/25 ] [ 1/5 1/5 1/5 hsv>rgb ] unit-test
+[ 29/180 1/6 5/36 ] [ 1/5 1/6 1/6 hsv>rgb ] unit-test
+
+[ 6/25 2/5 38/125 ] [ 2/5 2/5 2/5 hsv>rgb ] unit-test
+[ 8/25 4/5 64/125 ] [ 2/5 3/5 4/5 hsv>rgb ] unit-test
+
+[ 6/25 48/125 3/5 ] [ 3/5 3/5 3/5 hsv>rgb ] unit-test
+[ 0 0 0 ] [ 3/5 1/5 0 hsv>rgb ] unit-test
+
+[ 84/125 4/25 4/5 ] [ 4/5 4/5 4/5 hsv>rgb ] unit-test
+[ 7/15 1/3 1/2 ] [ 4/5 1/3 1/2 hsv>rgb ] unit-test
+
+[ 5/6 5/36 5/6 ] [ 5/6 5/6 5/6 hsv>rgb ] unit-test
+[ 1/6 0 1/6 ] [ 5/6 1 1/6 hsv>rgb ] unit-test

basis/colors/hsv/hsv.factor

@@ -1,41 +1,38 @@
-! Copyright (C) 2007 Eduardo Cavazos
+! Copyright (C) 2008 Eduardo Cavazos.
 ! See http://factorcode.org/license.txt for BSD license.
-
+USING: colors kernel combinators math math.functions accessors ;
-USING: kernel combinators arrays sequences math math.functions ;
-
 IN: colors.hsv
 
-<PRIVATE
-
-: H ( hsv -- H ) first ;
-
-: S ( hsv -- S ) second ;
-
-: V ( hsv -- V ) third ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: Hi ( hsv -- Hi ) H 60 / floor 6 mod ;
-
-: f ( hsv -- f ) [ H 60 / ] [ Hi ] bi - ;
-
-: p ( hsv -- p ) [ S 1 swap - ] [ V ] bi * ;
-
-: q ( hsv -- q ) [ [ f ] [ S ] bi * 1 swap - ] [ V ] bi * ;
-
-: t ( hsv -- t ) [ [ f 1 swap - ] [ S ] bi * 1 swap - ] [ V ] bi * ;
-
-PRIVATE>
-
 ! h [0,360)
 ! s [0,1]
 ! v [0,1]
+TUPLE: hsva < color hue saturation value alpha ;
 
-: hsv>rgb ( hsv -- rgb )
+C: <hsva> hsva
+
+<PRIVATE
+
+: Hi ( hsv -- Hi ) hue>> 60 / floor 6 mod ; inline
+
+: f ( hsv -- f ) [ hue>> 60 / ] [ Hi ] bi - ; inline
+
+: p ( hsv -- p ) [ saturation>> 1 swap - ] [ value>> ] bi * ; inline
+
+: q ( hsv -- q ) [ [ f ] [ saturation>> ] bi * 1 swap - ] [ value>> ] bi * ; inline
+
+: t ( hsv -- t ) [ [ f 1 swap - ] [ saturation>> ] bi * 1 swap - ] [ value>> ] bi * ; inline
+
+PRIVATE>
+
+M: hsva >rgba ( hsva -- rgba )
+    [
         dup Hi
-{ { 0 [ [ V ] [ t ] [ p ] tri ] }
+        {
-  { 1 [ [ q ] [ V ] [ p ] tri ] }
+            { 0 [ [ value>> ] [ t ] [ p ] tri ] }
-  { 2 [ [ p ] [ V ] [ t ] tri ] }
+            { 1 [ [ q ] [ value>> ] [ p ] tri ] }
-  { 3 [ [ p ] [ q ] [ V ] tri ] }
+            { 2 [ [ p ] [ value>> ] [ t ] tri ] }
-  { 4 [ [ t ] [ p ] [ V ] tri ] }
+            { 3 [ [ p ] [ q ] [ value>> ] tri ] }
-  { 5 [ [ V ] [ p ] [ q ] tri ] } } case 3array ;
+            { 4 [ [ t ] [ p ] [ value>> ] tri ] }
+            { 5 [ [ value>> ] [ p ] [ q ] tri ] }
+        } case
+    ] [ alpha>> ] bi <rgba> ;

extra/benchmark/mandel/colors/colors.factor

@@ -1,10 +1,11 @@
 USING: math math.order kernel arrays byte-arrays sequences
-colors.hsv benchmark.mandel.params ;
+colors.hsv benchmark.mandel.params accessors colors ;
 IN: benchmark.mandel.colors
 
 : scale 255 * >fixnum ; inline
 
-: scale-rgb ( r g b -- n ) [ scale ] tri@ 3byte-array ;
+: scale-rgb ( rgba -- n )
+    [ red>> scale ] [ green>> scale ] [ blue>> scale ] tri 3byte-array ;
 
 : sat 0.85 ; inline
 : val 0.85 ; inline
@@ -12,7 +13,7 @@ IN: benchmark.mandel.colors
 : <color-map> ( nb-cols -- map )
     dup [
         360 * swap 1+ / sat val
-        3array hsv>rgb first3 scale-rgb
+        1 <hsva> >rgba scale-rgb
     ] with map ;
 
 : color-map ( -- map )

extra/color-picker/color-picker.factor

@@ -23,7 +23,7 @@ M: color-preview model-changed
     swap value>> >>interior relayout-1 ;
 
 : <color-model> ( model -- model )
-    [ [ 256 /f ] map 1 suffix first4 rgba boa <solid> ] <filter> ;
+    [ first3 [ 256 /f ] tri@ 1 <rgba> <solid> ] <filter> ;
 
 : <color-sliders> ( -- model gadget )
     3 [ 0 0 0 255 <range> ] replicate