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. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences math ;
USING: kernel combinators arrays sequences math combinators.lib ;
IN: colors.hsv IN: colors.hsv
<PRIVATE <PRIVATE
: f_ >r swap rot >r 2dup r> 6 * r> - ; : H ( hsv -- H ) first ;
: p ( v s x -- v p x ) >r dupd neg 1 + * r> ;
: q ( v s f -- q ) * neg 1 + * ; : S ( hsv -- S ) second ;
: t_ ( v s f -- t_ ) neg 1 + * neg 1 + * ;
: 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> PRIVATE>
: mod-cond ( p vector -- ) ! h [0,360)
#! Call p mod q'th entry of the vector of quotations, where ! s [0,1]
#! q is the length of the vector. The value q remains on the ! v [0,1]
#! stack.
[ dupd length mod ] keep nth call ;
: hsv>rgb ( h s v -- r g b ) : hsv>rgb ( hsv -- rgb )
pick 6 * >fixnum { dup Hi
[ f_ t_ p swap ] ! v p t { { 0 [ [ V ] [ t ] [ p ] tri ] }
[ f_ q p -rot ] ! q v p { 1 [ [ q ] [ V ] [ p ] tri ] }
[ f_ t_ p swapd ] ! p v t { 2 [ [ p ] [ V ] [ t ] tri ] }
[ f_ q p rot ] ! p q v { 3 [ [ p ] [ q ] [ V ] tri ] }
[ f_ t_ p swap rot ] ! t p v { 4 [ [ t ] [ p ] [ V ] tri ] }
[ f_ q p ] ! v p q { 5 [ [ V ] [ p ] [ q ] tri ] } } case 3array ;
} mod-cond ;