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: kernel kernel.private sequences sequences.private math
5 combinators macros math.order math.ranges quotations fry effects
6 memoize.private arrays ;
9 ! These words can be inline combinators the word does no math on
10 ! the input parameters, e.g. n.
11 ! If math is done, the word needs to be a macro so the math can
12 ! be done at compile-time.
15 ALIAS: n*quot (n*quot)
17 MACRO: call-n ( n -- quot )
18 [ call ] <repetition> '[ _ cleave ] ;
20 : repeat ( n obj quot -- ) swapd times ; inline
24 MACRO: nsum ( n -- quot )
27 ERROR: nonpositive-npick n ;
29 MACRO: npick ( n -- quot )
31 { [ dup 0 <= ] [ nonpositive-npick ] }
32 { [ dup 1 = ] [ drop [ dup ] ] }
33 [ 1 - [ dup ] [ '[ _ dip swap ] ] repeat ]
36 MACRO: nover ( n -- quot )
37 dup 1 + '[ _ npick ] n*quot ;
40 [ '[ _ npick ] ] keep call-n ; inline
42 MACRO: dupn ( n -- quot )
44 [ 1 - [ dup ] n*quot ] if-zero ;
46 MACRO: nrot ( n -- quot )
47 1 - [ ] [ '[ _ dip swap ] ] repeat ;
49 MACRO: -nrot ( n -- quot )
50 1 - [ ] [ '[ swap _ dip ] ] repeat ;
53 [ drop ] swap call-n ; inline
56 '[ _ ndrop ] dip ; inline
59 [ [ dip ] curry ] swap call-n call ; inline
62 dup '[ [ _ ndup ] dip _ ndip ] call ; inline
65 [ curry ] swap call-n ; inline
68 [ with ] swap call-n ; inline
70 : nbi ( quot1 quot2 n -- )
71 [ nip nkeep ] [ drop nip call ] 3bi ; inline
73 MACRO: ncleave ( quots n -- quot )
74 [ '[ _ '[ _ _ nkeep ] ] map [ ] join ] [ '[ _ ndrop ] ] bi
77 MACRO: nspread ( quots n -- quot )
78 over empty? [ 2drop [ ] ] [
82 '[ [ _ _ nspread ] _ ndip @ ]
85 MACRO: spread* ( n -- quot )
87 [1,b) [ '[ [ [ _ ndip ] curry ] dip compose ] ] map [ ] concat-as
91 MACRO: nspread* ( m n -- quot )
93 [ * 0 ] [ drop neg ] 2bi
94 <range> rest >array dup length iota <reversed>
96 '[ [ [ _ ndip ] curry ] _ ndip ]
97 ] 2map dup rest-slice [ [ compose ] compose ] map! drop
98 [ ] concat-as [ call ] compose
101 MACRO: cleave* ( n -- quot )
103 [ 1 - [ [ [ keep ] curry ] dip compose ] n*quot [ call ] compose ]
106 : napply ( quot n -- )
107 [ dupn ] [ spread* ] bi ; inline
109 : mnapply ( quot m n -- )
110 [ nip dupn ] [ nspread* ] 2bi ; inline
112 : apply-curry ( a... quot n -- )
113 [ [curry] ] dip napply ; inline
115 : cleave-curry ( a quot... n -- )
116 [ [curry] ] swap [ napply ] [ cleave* ] bi ; inline
118 : spread-curry ( a... quot... n -- )
119 [ [curry] ] swap [ napply ] [ spread* ] bi ; inline
121 MACRO: mnswap ( m n -- quot )
122 1 + '[ _ -nrot ] swap '[ _ _ napply ] ;
124 MACRO: nweave ( n -- quot )
125 [ dup iota <reversed> [ '[ _ _ mnswap ] ] with map ] keep
129 [ bi-curry ] swap call-n ; inline
131 MACRO: map-compose ( quots quot -- quot' )
132 '[ _ compose ] map '[ _ ] ;