1 ! Copyright (C) 2009 Joe Groff.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: arrays combinators generalizations kernel math math.order
4 memoize.private quotations sequences sequences.private ;
5 IN: sequences.generalizations
7 MACRO: (nsequence) ( n -- quot )
8 <iota> reverse [ '[ [ _ swap set-nth-unsafe ] keep ] ] map concat ;
10 MACRO: nsequence ( n exemplar -- quot )
11 [ [nsequence] ] keep '[ @ _ like ] ;
13 MACRO: narray ( n -- quot )
14 '[ _ { } nsequence ] ;
16 MACRO: firstn-unsafe ( n -- quot )
19 MACRO: firstn ( n -- quot )
21 [ 1 - swap bounds-check 2drop ]
26 MACRO: set-firstn-unsafe ( n -- quot )
28 [ <iota> [ '[ _ rot [ set-nth-unsafe ] keep ] ] map ] bi
29 '[ _ -nrot _ spread drop ] ;
31 MACRO: set-firstn ( n -- quot )
33 [ 1 - swap bounds-check 2drop ]
38 MACRO: ?firstn ( n -- quot )
39 dup '[ _ f pad-tail _ firstn-unsafe ] ;
41 : nappend ( n -- seq ) narray concat ; inline
43 : nappend-as ( n exemplar -- seq )
44 [ narray ] [ concat-as ] bi* ; inline
46 MACRO: nmin-length ( n -- quot )
47 dup 1 - [ min ] n*quot
48 '[ [ length ] _ napply @ ] ;
50 : nnth ( n seq... n -- )
51 [ nth ] swap [ apply-curry ] [ cleave* ] bi ; inline
53 : nnth-unsafe ( n seq... n -- )
54 [ nth-unsafe ] swap [ apply-curry ] [ cleave* ] bi ; inline
56 MACRO: nset-nth-unsafe ( n -- quot )
58 [ '[ [ set-nth-unsafe ] _ [ apply-curry ] [ cleave-curry ] [ spread* ] tri ] ]
61 : (neach) ( seq... quot n -- len quot' )
63 '[ [ _ nmin-length ] _ nkeep [ _ nnth-unsafe ] _ ncurry ] dip compose ; inline
65 : neach ( seq... quot n -- )
66 (neach) each-integer ; inline
68 : nmap-as ( seq... quot exemplar n -- result )
69 '[ _ (neach) ] dip map-integers ; inline
71 : nmap ( seq... quot n -- result )
72 dup '[ [ _ npick ] dip swap ] dip nmap-as ; inline
74 MACRO: nnew-sequence ( n -- quot )
76 [ dup '[ [ new-sequence ] _ apply-curry _ cleave* ] ] if-zero ;
78 : nnew-like ( len exemplar... quot n -- result... )
81 [ [ _ nnew-sequence ] dip call ]
87 MACRO: (ncollect) ( n -- quot )
89 '[ [ [ keep ] _ ndip _ nset-nth-unsafe ] _ ncurry ] ;
91 : ncollect ( len quot into... n -- )
92 (ncollect) each-integer ; inline
94 : nmap-integers ( len quot exemplar... n -- result... )
96 '[ [ over ] _ ndip [ [ _ ncollect ] _ nkeep ] _ nnew-like ] call ; inline
98 : mnmap-as ( m*seq quot n*exemplar m n -- result*n )
99 dup '[ [ _ (neach) ] _ ndip _ nmap-integers ] call ; inline
101 : mnmap ( m*seq quot m n -- result*n )
102 2dup '[ [ _ npick ] dip swap _ dupn ] 2dip mnmap-as ; inline
104 : ncollector-as ( quot exemplar... n -- quot' vec... )
106 [ [ length ] keep new-resizable ] _ napply
107 [ [ [ push ] _ apply-curry _ spread* ] _ ncurry compose ] _ nkeep
110 : ncollector ( quot n -- quot' vec... )
111 [ V{ } swap dupn ] keep ncollector-as ; inline
113 : nproduce-as ( pred quot exemplar... n -- seq... )
116 [ _ ncollector-as [ while ] _ ndip ]
118 [ like ] _ apply-curry _ spread*
121 : nproduce ( pred quot n -- seq... )
122 [ { } swap dupn ] keep nproduce-as ; inline
124 MACRO: nmap-reduce ( map-quot reduce-quot n -- quot )
125 -rot dupd compose overd over '[
126 [ [ first ] _ napply @ 1 ] _ nkeep
127 _ _ (neach) (each-integer)
130 : nall? ( seqs... quot n -- ? )
131 (neach) all-integers? ; inline
133 MACRO: finish-nfind ( n -- quot )
134 [ 1 + ] keep dup dup dup f <array> >quotation '[
136 [ [ dup ] _ ndip _ nnth-unsafe ]
141 : (nfind) ( seqs... quot n quot' -- i elts... )
143 [ '[ _ _ (neach) @ ] ] dip
144 [ '[ _ finish-nfind ] ] keep
147 : nfind ( seqs... quot n -- i elts... )
148 [ find-integer ] (nfind) ; inline
150 : nany? ( seqs... quot n -- ? )
151 [ nfind ] [ ndrop ] bi >boolean ; inline