1 ! Copyright (C) 2007, 2009 Chris Double, Doug Coleman, Eduardo
2 ! Cavazos, Slava Pestov.
3 ! See http://factorcode.org/license.txt for BSD license.
4 USING: arrays combinators kernel kernel.private math ranges
5 memoize.private sequences ;
8 ! These words can be inline combinators when the word does no math
9 ! on the input parameters, e.g. n.
10 ! If math is done, the word needs to be a macro so the math can
11 ! be done at compile-time.
14 ALIAS: n*quot (n*quot)
16 MACRO: call-n ( n -- quot )
17 [ call ] <repetition> '[ _ cleave ] ;
21 MACRO: nsum ( n -- quot )
24 ERROR: nonpositive-npick n ;
26 MACRO: npick ( n -- quot )
28 { [ dup 0 <= ] [ nonpositive-npick ] }
29 { [ dup 1 = ] [ drop [ dup ] ] }
30 [ 1 - [ dup ] [ '[ _ dip swap ] ] swapd times ]
34 [ '[ _ npick ] ] keep call-n ; inline
36 MACRO: dupn ( n -- quot )
38 [ 1 - [ dup ] n*quot ] if-zero ;
40 MACRO: nrot ( n -- quot )
41 1 - [ ] [ '[ _ dip swap ] ] swapd times ;
43 MACRO: -nrot ( n -- quot )
44 1 - [ ] [ '[ swap _ dip ] ] swapd times ;
47 [ [ dip ] curry ] swap call-n call ; inline
50 [ drop ] swap call-n ; inline
53 '[ _ ndrop ] dip ; inline
56 MACRO: nrotd ( n d -- quot )
58 [ neg ] dip '[ _ _ -nrotd ]
60 [ 1 - [ ] [ '[ _ dip swap ] ] swapd times ] dip '[ _ _ ndip ]
63 MACRO: -nrotd ( n d -- quot )
65 [ neg ] dip '[ _ _ nrotd ]
67 [ 1 - [ ] [ '[ swap _ dip ] ] swapd times ] dip '[ _ _ ndip ]
70 MACRO: nrotated ( nrots depth dip -- quot )
71 [ '[ [ _ nrot ] ] replicate [ ] concat-as ] dip '[ _ _ ndip ] ;
73 MACRO: -nrotated ( -nrots depth dip -- quot )
74 [ '[ [ _ -nrot ] ] replicate [ ] concat-as ] dip '[ _ _ ndip ] ;
76 MACRO: nrotate-heightd ( n height dip -- quot )
77 [ '[ [ _ nrot ] ] replicate concat ] dip '[ _ _ ndip ] ;
79 MACRO: -nrotate-heightd ( n height dip -- quot )
81 '[ [ _ -nrot ] ] replicate concat
84 : ndupd ( n dip -- ) '[ [ _ ndup ] _ ndip ] call ; inline
86 MACRO: ntuckd ( ntuck ndip -- quot )
87 [ 1 + ] dip '[ [ dup _ -nrot ] _ ndip ] ;
89 MACRO: nover ( n -- quot )
90 dup 1 + '[ _ npick ] n*quot ;
92 MACRO: noverd ( n depth dip -- quot' )
93 [ + ] [ 2drop ] [ [ + ] dip ] 3tri
94 '[ _ _ ndupd _ _ _ nrotated ] ;
96 MACRO: mntuckd ( ndup depth ndip -- quot )
97 { [ nip ] [ 2drop ] [ drop + ] [ 2nip ] } 3cleave
98 '[ _ _ ndupd _ _ _ -nrotated ] ;
101 dup '[ [ _ ndup ] dip _ ndip ] call ; inline
104 [ curry ] swap call-n ; inline
107 [ with ] swap call-n ; inline
109 : nbi ( quot1 quot2 n -- )
110 [ nip nkeep ] [ drop nip call ] 3bi ; inline
112 MACRO: ncleave ( quots n -- quot )
113 [ '[ _ '[ _ _ nkeep ] ] map [ ] join ] [ '[ _ ndrop ] ] bi
116 MACRO: nspread ( quots n -- quot )
117 over empty? [ 2drop [ ] ] [
121 '[ [ _ _ nspread ] _ ndip @ ]
124 MACRO: spread* ( n -- quot )
126 [1..b) [ '[ [ [ _ ndip ] curry ] dip compose ] ] map [ ] concat-as
130 MACRO: nspread* ( m n -- quot )
132 [ * 0 ] [ drop neg ] 2bi
133 <range> rest >array dup length <iota> <reversed>
134 [ '[ [ [ _ ndip ] curry ] _ ndip ] ] 2map
136 [ length 1 - [ compose ] <array> concat append ] bi
140 MACRO: cleave* ( n -- quot )
142 [ 1 - [ [ [ keep ] curry ] dip compose ] n*quot [ call ] compose ]
145 : napply ( quot n -- )
146 [ dupn ] [ spread* ] bi ; inline
148 : mnapply ( quot m n -- )
149 [ nip dupn ] [ nspread* ] 2bi ; inline
151 : apply-curry ( a... quot n -- )
152 [ currier ] dip napply ; inline
154 : cleave-curry ( a quot... n -- )
155 [ currier ] swap [ napply ] [ cleave* ] bi ; inline
157 : spread-curry ( a... quot... n -- )
158 [ currier ] swap [ napply ] [ spread* ] bi ; inline
160 MACRO: mnswap ( m n -- quot )
161 1 + '[ _ -nrot ] swap '[ _ _ napply ] ;
163 MACRO: nweave ( n -- quot )
164 [ dup <iota> <reversed> [ '[ _ _ mnswap ] ] with map ] keep
168 [ bi-curry ] swap call-n ; inline
170 MACRO: map-compose ( quots quot -- quot' )
171 '[ _ compose ] map '[ _ ] ;