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

temporary fix for core/effects

db4
Doug Coleman 2009-08-22 20:56:28 -04:00
parent a6c7e9d9d4
commit 679a7c9b01
1 changed files with 12 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
core/effects/effects.factor
View File

@ -6,25 +6,29 @@ IN: effects
TUPLE: effect { in read-only } { out read-only } { terminated? read-only } ; TUPLE: effect { in read-only } { out read-only } { terminated? read-only } ;
GENERIC: effect-length ( obj -- n )
M: sequence effect-length length ;
M: integer effect-length ;
: <effect> ( in out -- effect ) : <effect> ( in out -- effect )
dup { "*" } sequence= [ drop { } t ] [ f ] if dup { "*" } sequence= [ drop { } t ] [ f ] if
effect boa ; effect boa ;
: effect-height ( effect -- n ) : effect-height ( effect -- n )
[ out>> length ] [ in>> length ] bi - ; inline [ out>> effect-length ] [ in>> effect-length ] bi - ; inline
: effect<= ( effect1 effect2 -- ? ) : effect<= ( effect1 effect2 -- ? )
{ {
{ [ over terminated?>> ] [ t ] } { [ over terminated?>> ] [ t ] }
{ [ dup terminated?>> ] [ f ] } { [ dup terminated?>> ] [ f ] }
{ [ 2dup [ in>> length ] bi@ > ] [ f ] } { [ 2dup [ in>> effect-length ] bi@ > ] [ f ] }
{ [ 2dup [ effect-height ] bi@ = not ] [ f ] } { [ 2dup [ effect-height ] bi@ = not ] [ f ] }
[ t ] [ t ]
} cond 2nip ; inline } cond 2nip ; inline
: effect= ( effect1 effect2 -- ? ) : effect= ( effect1 effect2 -- ? )
[ [ in>> length ] bi@ = ] [ [ in>> effect-length ] bi@ = ]
[ [ out>> length ] bi@ = ] [ [ out>> effect-length ] bi@ = ]
[ [ terminated?>> ] bi@ = ] [ [ terminated?>> ] bi@ = ]
2tri and and ; 2tri and and ;
@ -62,7 +66,7 @@ M: effect clone
stack-effect effect-height ; stack-effect effect-height ;
: split-shuffle ( stack shuffle -- stack1 stack2 ) : split-shuffle ( stack shuffle -- stack1 stack2 )
in>> length cut* ; in>> effect-length cut* ;
: shuffle-mapping ( effect -- mapping ) : shuffle-mapping ( effect -- mapping )
[ out>> ] [ in>> ] bi [ index ] curry map ; [ out>> ] [ in>> ] bi [ index ] curry map ;
@ -77,8 +81,9 @@ M: effect clone
over terminated?>> [ over terminated?>> [
drop drop
] [ ] [
[ [ [ in>> length ] [ out>> length ] bi ] [ in>> length ] bi* swap [-] + ] [ [ [ in>> effect-length ] [ out>> effect-length ] bi ] [ in>> effect-length ] bi* swap [-] + ]
[ [ out>> length ] [ [ in>> length ] [ out>> length ] bi ] bi* [ [-] ] dip + ] [ [ out>> effect-length ] [ [ in>> effect-length ] [ out>> effect-length ] bi ] bi* [ [-] ] dip + ]
[ nip terminated?>> ] 2tri [ nip terminated?>> ] 2tri
[ [ [ "obj" ] replicate ] bi@ ] dip
effect boa effect boa
] if ; inline ] if ; inline