Move hsva to colors.hsv
Slava Pestov
parent
87c71ee376
commit
1ef5dbe3fb
|
|
@ -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> 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
|
||||
|
|
|
|||
|
|
@ -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> ;
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
||||
<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 )
|
||||
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> 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 [ [ 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> ;
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue