diff --git a/basis/combinators/smart/smart.factor b/basis/combinators/smart/smart.factor index 3ad5b6c7ee..5576421742 100644 --- a/basis/combinators/smart/smart.factor +++ b/basis/combinators/smart/smart.factor @@ -53,4 +53,4 @@ MACRO: smart-if ( pred true false -- ) '[ _ preserving _ _ if ] ; MACRO: smart-apply ( quot n -- ) - [ dup inputs ] dip '[ _ _ mnapply ] ; + [ dup inputs ] dip '[ _ _ _ mnapply ] ; diff --git a/basis/generalizations/generalizations-tests.factor b/basis/generalizations/generalizations-tests.factor index 84b6565de1..477be4a20f 100644 --- a/basis/generalizations/generalizations-tests.factor +++ b/basis/generalizations/generalizations-tests.factor @@ -113,3 +113,12 @@ IN: generalizations.tests [ { 1 2 3 } { 4 5 6 } ] [ 1 2 3 4 5 6 [ 3array ] 3 2 mnapply ] unit-test + +[ { 1 2 3 } { 4 5 6 } ] +[ 1 2 3 4 5 6 [ 3array ] [ 3array ] 3 2 nspread* ] unit-test + +[ ] +[ [ 2array ] 2 0 mnapply ] unit-test + +[ ] +[ 2 0 nspread* ] unit-test diff --git a/basis/generalizations/generalizations.factor b/basis/generalizations/generalizations.factor index 667cff7b8a..dd0665b534 100644 --- a/basis/generalizations/generalizations.factor +++ b/basis/generalizations/generalizations.factor @@ -3,7 +3,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel kernel.private sequences sequences.private math combinators macros math.order math.ranges quotations fry effects -memoize.private ; +memoize.private arrays ; IN: generalizations << @@ -100,10 +100,20 @@ MACRO: nspread ( quots n -- ) MACRO: spread* ( n -- ) [ [ ] ] [ - 1 swap [a,b) [ '[ [ [ _ ndip ] curry ] dip compose ] ] map [ ] concat-as + [1,b) [ '[ [ [ _ ndip ] curry ] dip compose ] ] map [ ] concat-as [ call ] compose ] if-zero ; +MACRO: nspread* ( m n -- ) + [ drop [ ] ] [ + [ * 0 ] [ drop neg ] 2bi + rest >array dup length iota + [ + '[ [ [ _ ndip ] curry ] _ ndip ] + ] 2map dup rest-slice [ [ compose ] compose ] map! drop + [ ] concat-as [ call ] compose + ] if-zero ; + MACRO: cleave* ( n -- ) [ [ ] ] [ 1 - [ [ [ keep ] curry ] dip compose ] n*quot [ call ] compose ] @@ -112,6 +122,9 @@ MACRO: cleave* ( n -- ) : napply ( quot n -- ) [ dupn ] [ spread* ] bi ; inline +: mnapply ( quot m n -- ) + [ nip dupn ] [ nspread* ] 2bi ; inline + : apply-curry ( ...a quot n -- ) [ [curry] ] dip napply ; inline @@ -124,10 +137,6 @@ MACRO: cleave* ( n -- ) MACRO: mnswap ( m n -- ) 1 + '[ _ -nrot ] swap '[ _ _ napply ] ; -MACRO: mnapply ( quot m n -- ) - swap - [ swap '[ _ ] replicate ] dip '[ _ _ nspread ] ; - MACRO: nweave ( n -- ) [ dup iota [ '[ _ _ mnswap ] ] with map ] keep '[ _ _ ncleave ] ;