diff --git a/basis/combinators/smart/smart-tests.factor b/basis/combinators/smart/smart-tests.factor index afafd174d3..11624dcf10 100644 --- a/basis/combinators/smart/smart-tests.factor +++ b/basis/combinators/smart/smart-tests.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: tools.test combinators.smart math kernel accessors ; +USING: accessors arrays combinators.smart kernel math +tools.test ; IN: combinators.smart.tests : test-bi ( -- 9 11 ) @@ -59,3 +60,6 @@ IN: combinators.smart.tests [ 7 ] [ 10 3 smart-if-test ] unit-test [ 16 ] [ 25 41 smart-if-test ] unit-test + +[ { 1 2 } { 3 4 } { 5 6 } ] [ 1 2 3 4 5 6 [ 2array ] 3 smart-apply ] unit-test +[ { 1 2 3 } { 4 5 6 } ] [ 1 2 3 4 5 6 [ 3array ] 2 smart-apply ] unit-test diff --git a/basis/combinators/smart/smart.factor b/basis/combinators/smart/smart.factor index 05185fec2e..3ad5b6c7ee 100644 --- a/basis/combinators/smart/smart.factor +++ b/basis/combinators/smart/smart.factor @@ -51,3 +51,6 @@ MACRO: nullary ( quot -- quot' ) MACRO: smart-if ( pred true false -- ) '[ _ preserving _ _ if ] ; + +MACRO: smart-apply ( quot n -- ) + [ dup inputs ] dip '[ _ _ mnapply ] ; diff --git a/basis/generalizations/generalizations-tests.factor b/basis/generalizations/generalizations-tests.factor index 0c35f15714..84b6565de1 100644 --- a/basis/generalizations/generalizations-tests.factor +++ b/basis/generalizations/generalizations-tests.factor @@ -108,3 +108,8 @@ IN: generalizations.tests 2 1 0 -1 [ + ] [ - ] [ * ] [ / ] 4 spread-curry 4 spread* ] unit-test +[ { 1 2 } { 3 4 } { 5 6 } ] +[ 1 2 3 4 5 6 [ 2array ] 2 3 mnapply ] unit-test + +[ { 1 2 3 } { 4 5 6 } ] +[ 1 2 3 4 5 6 [ 3array ] 3 2 mnapply ] unit-test diff --git a/basis/generalizations/generalizations.factor b/basis/generalizations/generalizations.factor index 6c8a0b5fde..667cff7b8a 100644 --- a/basis/generalizations/generalizations.factor +++ b/basis/generalizations/generalizations.factor @@ -124,6 +124,10 @@ 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 ] ;