! Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences sequences.private math combinators
-macros quotations fry ;
+macros quotations fry stack-checker.transforms effects ;
IN: generalizations
<<
[ narray concat ] dip like ; inline
: nappend ( n -- seq ) narray concat ; inline
+
+: nths-quot ( indices -- quot )
+ [ [ '[ _ swap nth ] ] map ] [ length ] bi
+ '[ _ cleave _ narray ] ;
+
+\ shuffle [
+ shuffle-mapping nths-quot
+] 1 define-transform
\ No newline at end of file
[ 2 ] [ (( a b -- c )) in>> length ] unit-test
[ 1 ] [ (( a b -- c )) out>> length ] unit-test
-
+[ "(( object -- object ))" ] [ { f } { f } <effect> unparse ] unit-test
[ "(( a b -- c d ))" ] [ { "a" "b" } { "c" "d" } <effect> unparse ] unit-test
[ "(( -- c d ))" ] [ { } { "c" "d" } <effect> unparse ] unit-test
[ "(( a b -- ))" ] [ { "a" "b" } { } <effect> unparse ] unit-test
[ "(( -- ))" ] [ { } { } <effect> unparse ] unit-test
[ "(( a b -- c ))" ] [ (( a b -- c )) unparse ] unit-test
+
+[ { "x" "y" } ] [ { "y" "x" } (( a b -- b a )) shuffle ] unit-test
+[ { "y" "x" "y" } ] [ { "y" "x" } (( a b -- a b a )) shuffle ] unit-test
+[ { } ] [ { "y" "x" } (( a b -- )) shuffle ] unit-test
\ No newline at end of file
-! Copyright (C) 2006, 2008 Slava Pestov.
+! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.parser namespaces make sequences strings
words assocs combinators accessors arrays ;
GENERIC: effect>string ( obj -- str )
M: string effect>string ;
+M: object effect>string drop "object" ;
M: word effect>string name>> ;
M: integer effect>string number>string ;
M: pair effect>string first2 [ effect>string ] bi@ ": " glue ;
GENERIC: stack-effect ( word -- effect/f )
M: word stack-effect
- { "declared-effect" "inferred-effect" }
- swap props>> [ at ] curry map [ ] find nip ;
+ "inferred-effect" "declared-effect"
+ [ word-prop ] bi-curry@ bi or ;
M: effect clone
[ in>> clone ] [ out>> clone ] bi <effect> ;
: split-shuffle ( stack shuffle -- stack1 stack2 )
in>> length cut* ;
-: load-shuffle ( stack shuffle -- )
- in>> [ set ] 2each ;
-
-: shuffled-values ( shuffle -- values )
- out>> [ get ] map ;
+: shuffle-mapping ( effect -- mapping )
+ [ out>> ] [ in>> ] bi [ index ] curry map ;
: shuffle ( stack shuffle -- newstack )
- [ [ load-shuffle ] keep shuffled-values ] with-scope ;
+ shuffle-mapping swap nths ;