steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Move hsva to colors.hsv

db4
Slava Pestov 2008-10-02 03:37:53 -05:00
parent 87c71ee376
commit 1ef5dbe3fb
6 changed files with 90 additions and 70 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

49
basis/colors/colors.factor
View File

@ -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. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors ;
USING: kernel combinators sequences arrays classes.tuple accessors colors.hsv ;
IN: colors IN: colors
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
TUPLE: color ; TUPLE: color ;
TUPLE: rgba < color red green blue alpha ; 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 ) GENERIC: >rgba ( object -- rgba )
M: rgba >rgba ( rgba -- 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 red>> ( color -- red ) >rgba red>> ;
M: color green>> ( color -- green ) >rgba green>> ; M: color green>> ( color -- green ) >rgba green>> ;
M: color blue>> ( color -- blue ) >rgba blue>> ; 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 } ;

11
basis/colors/gray/gray.factor Normal file
View File

@ -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> ;

26
basis/colors/hsv/hsv-tests.factor Normal file
View File

@ -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

65
basis/colors/hsv/hsv.factor
View File

@ -1,41 +1,38 @@
! Copyright (C) 2007 Eduardo Cavazos ! Copyright (C) 2008 Eduardo Cavazos.
! See http://factorcode.org/license.txt for BSD license. ! 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 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) ! h [0,360)
! s [0,1] ! s [0,1]
! v [0,1] ! v [0,1]
TUPLE: hsva < color hue saturation value alpha ;
: hsv>rgb ( hsv -- rgb ) C: <hsva> hsva
dup Hi
{ { 0 [ [ V ] [ t ] [ p ] tri ] } <PRIVATE
{ 1 [ [ q ] [ V ] [ p ] tri ] }
{ 2 [ [ p ] [ V ] [ t ] tri ] } : Hi ( hsv -- Hi ) hue>> 60 / floor 6 mod ; inline
{ 3 [ [ p ] [ q ] [ V ] tri ] }
{ 4 [ [ t ] [ p ] [ V ] tri ] } : f ( hsv -- f ) [ hue>> 60 / ] [ Hi ] bi - ; inline
{ 5 [ [ V ] [ p ] [ q ] tri ] } } case 3array ;
: 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 <rgba> ;

7
extra/benchmark/mandel/colors/colors.factor
View File

@ -1,10 +1,11 @@
USING: math math.order kernel arrays byte-arrays sequences 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 IN: benchmark.mandel.colors
: scale 255 * >fixnum ; inline : 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 : sat 0.85 ; inline
: val 0.85 ; inline : val 0.85 ; inline
@ -12,7 +13,7 @@ IN: benchmark.mandel.colors
: <color-map> ( nb-cols -- map ) : <color-map> ( nb-cols -- map )
dup [ dup [
360 * swap 1+ / sat val 360 * swap 1+ / sat val
3array hsv>rgb first3 scale-rgb 1 <hsva> >rgba scale-rgb
] with map ; ] with map ;
: color-map ( -- map ) : color-map ( -- map )

2
extra/color-picker/color-picker.factor
View File

@ -23,7 +23,7 @@ M: color-preview model-changed
swap value>> >>interior relayout-1 ; swap value>> >>interior relayout-1 ;
: <color-model> ( model -- model ) : <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 ) : <color-sliders> ( -- model gadget )
3 [ 0 0 0 255 <range> ] replicate 3 [ 0 0 0 255 <range> ] replicate