diff --git a/basis/colors/colors.factor b/basis/colors/colors.factor index 77a1f46c87..1183c2e46c 100644 --- a/basis/colors/colors.factor +++ b/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 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 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 diff --git a/basis/colors/gray/gray.factor b/basis/colors/gray/gray.factor new file mode 100644 index 0000000000..26ec1177b6 --- /dev/null +++ b/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 + +M: gray >rgba ( gray -- rgba ) + [ gray>> dup dup ] [ alpha>> ] bi ; diff --git a/basis/colors/hsv/hsv-tests.factor b/basis/colors/hsv/hsv-tests.factor new file mode 100644 index 0000000000..8a736553bb --- /dev/null +++ b/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 >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 diff --git a/basis/colors/hsv/hsv.factor b/basis/colors/hsv/hsv.factor index dd2811822b..6f658818a1 100644 --- a/basis/colors/hsv/hsv.factor +++ b/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: kernel combinators arrays sequences math math.functions ; - +USING: colors kernel combinators math math.functions accessors ; IN: colors.hsv - - ! h [0,360) ! s [0,1] ! v [0,1] +TUPLE: hsva < color hue saturation value alpha ; -: 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 ; +C: hsva + +> 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 [ [ 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 ; diff --git a/extra/benchmark/mandel/colors/colors.factor b/extra/benchmark/mandel/colors/colors.factor index 7bbb25a47d..218f566eda 100644 --- a/extra/benchmark/mandel/colors/colors.factor +++ b/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 : ( nb-cols -- map ) dup [ 360 * swap 1+ / sat val - 3array hsv>rgb first3 scale-rgb + 1 >rgba scale-rgb ] with map ; : color-map ( -- map ) diff --git a/extra/color-picker/color-picker.factor b/extra/color-picker/color-picker.factor index 4a0c148145..6ed8c1220c 100755 --- a/extra/color-picker/color-picker.factor +++ b/extra/color-picker/color-picker.factor @@ -23,7 +23,7 @@ M: color-preview model-changed swap value>> >>interior relayout-1 ; : ( model -- model ) - [ [ 256 /f ] map 1 suffix first4 rgba boa ] ; + [ first3 [ 256 /f ] tri@ 1 ] ; : ( -- model gadget ) 3 [ 0 0 0 255 ] replicate