-! 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 combinators sequences arrays classes.tuple accessors colors.hsv ;
-
+USING: kernel accessors ;
IN: colors
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
TUPLE: color ;
TUPLE: rgba < color red green blue alpha ;
-TUPLE: hsva < color hue saturation value alpha ;
-
-TUPLE: gray < color gray alpha ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+C: <rgba> rgba
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 } ;
-: blue T{ rgba f 0.0 0.0 1.0 1.0 } ;
-: cyan T{ rgba f 0 0.941 0.941 1 } ;
-: gray T{ rgba f 0.6 0.6 0.6 1.0 } ;
-: green T{ rgba f 0.0 1.0 0.0 1.0 } ;
-: light-gray T{ rgba f 0.95 0.95 0.95 0.95 } ;
-: light-purple T{ rgba f 0.8 0.8 1.0 1.0 } ;
-: magenta T{ rgba f 0.941 0 0.941 1 } ;
-: orange T{ rgba f 0.941 0.627 0 1 } ;
-: purple T{ rgba f 0.627 0 0.941 1 } ;
-: red T{ rgba f 1.0 0.0 0.0 1.0 } ;
-: white T{ rgba f 1.0 1.0 1.0 1.0 } ;
-: yellow T{ rgba f 1.0 1.0 0.0 1.0 } ;
+: 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
+: cyan T{ rgba f 0 0.941 0.941 1 } ; inline
+: gray T{ rgba f 0.6 0.6 0.6 1.0 } ; inline
+: green T{ rgba f 0.0 1.0 0.0 1.0 } ; inline
+: light-gray T{ rgba f 0.95 0.95 0.95 0.95 } ; inline
+: light-purple T{ rgba f 0.8 0.8 1.0 1.0 } ; inline
+: magenta T{ rgba f 0.941 0 0.941 1 } ; inline
+: orange T{ rgba f 0.941 0.627 0 1 } ; inline
+: purple T{ rgba f 0.627 0 0.941 1 } ; inline
+: red T{ rgba f 1.0 0.0 0.0 1.0 } ; inline
+: white T{ rgba f 1.0 1.0 1.0 1.0 } ; inline
+: yellow T{ rgba f 1.0 1.0 0.0 1.0 } ; inline
--- /dev/null
+! 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> ;
--- /dev/null
+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
-! Copyright (C) 2007 Eduardo Cavazos
+! Copyright (C) 2008 Eduardo Cavazos.
! See http://factorcode.org/license.txt for BSD license.
-
-USING: kernel combinators arrays sequences math math.functions ;
-
+USING: colors kernel combinators math math.functions accessors ;
IN: colors.hsv
-<PRIVATE
-
-: H ( hsv -- H ) first ;
-
-: S ( hsv -- S ) second ;
+! h [0,360)
+! s [0,1]
+! v [0,1]
+TUPLE: hsva < color hue saturation value alpha ;
-: V ( hsv -- V ) third ;
+C: <hsva> hsva
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+<PRIVATE
-: Hi ( hsv -- Hi ) H 60 / floor 6 mod ;
+: Hi ( hsv -- Hi ) hue>> 60 / floor 6 mod ; inline
-: f ( hsv -- f ) [ H 60 / ] [ Hi ] bi - ;
+: f ( hsv -- f ) [ hue>> 60 / ] [ Hi ] bi - ; inline
-: p ( hsv -- p ) [ S 1 swap - ] [ V ] bi * ;
+: p ( hsv -- p ) [ saturation>> 1 swap - ] [ value>> ] bi * ; inline
-: q ( hsv -- q ) [ [ f ] [ S ] bi * 1 swap - ] [ V ] bi * ;
+: q ( hsv -- q ) [ [ f ] [ saturation>> ] bi * 1 swap - ] [ value>> ] bi * ; inline
-: t ( hsv -- t ) [ [ f 1 swap - ] [ S ] bi * 1 swap - ] [ V ] bi * ;
+: t ( hsv -- t ) [ [ f 1 swap - ] [ saturation>> ] bi * 1 swap - ] [ value>> ] bi * ; inline
PRIVATE>
-! h [0,360)
-! s [0,1]
-! v [0,1]
-
-: hsv>rgb ( hsv -- rgb )
-dup Hi
-{ { 0 [ [ V ] [ t ] [ p ] tri ] }
- { 1 [ [ q ] [ V ] [ p ] tri ] }
- { 2 [ [ p ] [ V ] [ t ] tri ] }
- { 3 [ [ p ] [ q ] [ V ] tri ] }
- { 4 [ [ t ] [ p ] [ V ] tri ] }
- { 5 [ [ V ] [ p ] [ q ] tri ] } } case 3array ;
+M: hsva >rgba ( hsva -- rgba )
+ [
+ dup Hi
+ {
+ { 0 [ [ value>> ] [ t ] [ p ] tri ] }
+ { 1 [ [ q ] [ value>> ] [ p ] tri ] }
+ { 2 [ [ p ] [ value>> ] [ t ] tri ] }
+ { 3 [ [ p ] [ q ] [ value>> ] tri ] }
+ { 4 [ [ t ] [ p ] [ value>> ] tri ] }
+ { 5 [ [ value>> ] [ p ] [ q ] tri ] }
+ } case
+ ] [ alpha>> ] bi <rgba> ;
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
: <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 )
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
projects / factor.git / commitdiff