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

colors.hsv is the old cfdg.hsv

release
Eduardo Cavazos 2007-09-29 13:25:36 -05:00
parent 3995a5c824
commit 3f62ef3a2d
1 changed files with 32 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

52
extra/colors/hsv/hsv.factor
View File

@ -1,29 +1,41 @@
! Copyright (C) 2003, 2007 Slava Pestov.
! Copyright (C) 2007 Eduardo Cavazos
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences math ;
USING: kernel combinators arrays sequences math combinators.lib ;
IN: colors.hsv
<PRIVATE
: f_ >r swap rot >r 2dup r> 6 * r> - ;
: p ( v s x -- v p x ) >r dupd neg 1 + * r> ;
: q ( v s f -- q ) * neg 1 + * ;
: t_ ( v s f -- t_ ) neg 1 + * neg 1 + * ;
: 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>
: mod-cond ( p vector -- )
#! Call p mod q'th entry of the vector of quotations, where
#! q is the length of the vector. The value q remains on the
#! stack.
[ dupd length mod ] keep nth call ;
! h [0,360)
! s [0,1]
! v [0,1]
: hsv>rgb ( h s v -- r g b )
pick 6 * >fixnum {
[ f_ t_ p swap ] ! v p t
[ f_ q p -rot ] ! q v p
[ f_ t_ p swapd ] ! p v t
[ f_ q p rot ] ! p q v
[ f_ t_ p swap rot ] ! t p v
[ f_ q p ] ! v p q
} mod-cond ;
: 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 ;