1 ! Copyright (C) 2007 Slava Pestov, Chris Double, Doug Coleman,
2 ! Eduardo Cavazos, Daniel Ehrenberg.
3 ! See http://factorcode.org/license.txt for BSD license.
4 USING: combinators.lib kernel sequences math namespaces assocs
5 random sequences.private shuffle math.functions
6 arrays math.parser math.private sorting strings ascii macros
7 assocs.lib quotations hashtables math.order locals ;
10 : each-withn ( seq quot n -- ) nwith each ; inline
12 : each-with ( seq quot -- ) with each ; inline
14 : each-with2 ( obj obj list quot -- ) 2 each-withn ; inline
16 : map-withn ( seq quot n -- newseq ) nwith map ; inline
18 : map-with ( seq quot -- ) with map ; inline
20 : map-with2 ( obj obj list quot -- newseq ) 2 map-withn ; inline
22 MACRO: firstn ( n -- )
23 [ [ swap nth ] curry [ keep ] curry ] map
27 : prepare-index ( seq quot -- seq n quot )
28 >r dup length r> ; inline
30 : each-index ( seq quot -- )
31 #! quot: ( elt index -- )
32 prepare-index 2each ; inline
34 : map-index ( seq quot -- )
35 #! quot: ( elt index -- obj )
36 prepare-index 2map ; inline
38 : reduce-index ( seq identity quot -- )
39 #! quot: ( prev elt index -- next )
40 swapd each-index ; inline
42 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
44 : each-percent ( seq quot -- )
52 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
54 : map-reduce ( seq map-quot reduce-quot -- result )
55 >r [ unclip ] dip [ call ] keep r> compose reduce ; inline
57 : reduce* ( seq quot -- result ) [ ] swap map-reduce ; inline
59 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
61 : higher ( a b quot -- c ) [ compare +gt+ eq? ] curry most ; inline
63 : lower ( a b quot -- c ) [ compare +lt+ eq? ] curry most ; inline
65 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
67 : longer ( a b -- c ) [ length ] higher ;
69 : shorter ( a b -- c ) [ length ] lower ;
71 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
73 : longest ( seq -- item ) [ longer ] reduce* ;
75 : shortest ( seq -- item ) [ shorter ] reduce* ;
77 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
79 : bigger ( a b -- c ) [ ] higher ;
81 : smaller ( a b -- c ) [ ] lower ;
83 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
85 : biggest ( seq -- item ) [ bigger ] reduce* ;
87 : smallest ( seq -- item ) [ smaller ] reduce* ;
89 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
91 : minmax ( seq -- min max )
92 #! find the min and max of a seq in one pass
93 1/0. -1/0. rot [ tuck max >r min r> ] each ;
95 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
97 : ,, ( obj -- ) building get peek push ;
98 : v, ( -- ) V{ } clone , ;
99 : ,v ( -- ) building get dup peek empty? [ dup pop* ] when drop ;
101 : (monotonic-split) ( seq quot -- newseq )
103 >r dup unclip suffix r>
104 v, [ pick ,, call [ v, ] unless ] curry 2each ,v
107 : monotonic-split ( seq quot -- newseq )
108 over empty? [ 2drop { } ] [ (monotonic-split) ] if ;
110 : delete-random ( seq -- value )
111 [ length random ] keep [ nth ] 2keep delete-nth ;
113 ERROR: element-not-found ;
114 : split-around ( seq quot -- before elem after )
115 dupd find over [ element-not-found ] unless
116 >r cut rest r> swap ; inline
118 : (map-until) ( quot pred -- quot )
119 [ dup ] swap 3compose
120 [ [ drop t ] [ , f ] if ] compose [ find 2drop ] curry ;
122 : map-until ( seq quot pred -- newseq )
123 (map-until) { } make ;
125 : take-while ( seq quot -- newseq )
127 [ find drop [ head-slice ] when* ] curry
128 [ dup ] prepose keep like ;
130 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
133 : translate-string ( n alphabet out-len -- seq )
134 [ drop /mod ] with map nip ;
136 : map-alphabet ( alphabet seq[seq] -- seq[seq] )
137 [ [ swap nth ] with map ] with map ;
139 : exact-number-strings ( n out-len -- seqs )
140 [ ^ ] 2keep [ translate-string ] 2curry map ;
142 : number-strings ( n max-length -- seqs )
143 1+ [ exact-number-strings ] with map concat ;
146 : exact-strings ( alphabet length -- seqs )
147 >r dup length r> exact-number-strings map-alphabet ;
149 : strings ( alphabet length -- seqs )
150 >r dup length r> number-strings map-alphabet ;
152 : switches ( seq1 seq -- subseq )
153 ! seq1 is a sequence of ones and zeroes
154 >r [ length ] keep [ nth 1 = ] curry filter r>
155 [ nth ] curry { } map-as ;
157 : power-set ( seq -- subsets )
158 2 over length exact-number-strings swap [ switches ] curry map ;
160 : push-either ( elt quot accum1 accum2 -- )
161 >r >r keep swap r> r> ? push ; inline
163 : 2pusher ( quot -- quot accum1 accum2 )
164 V{ } clone V{ } clone [ [ push-either ] 3curry ] 2keep ; inline
166 : partition ( seq quot -- trueseq falseseq )
167 over >r 2pusher >r >r each r> r> r> drop ; inline
169 : cut-find ( seq pred -- before after )
170 dupd find drop dup [ cut ] when ;
172 : cut3 ( seq pred -- first mid last )
173 [ cut-find ] keep [ not ] compose cut-find ;
175 : (cut-all) ( seq pred quot -- )
176 [ >r cut3 r> dip >r >r , r> [ , ] when* r> ] 2keep
177 pick [ (cut-all) ] [ 3drop ] if ;
179 : cut-all ( seq pred quot -- first mid last )
180 [ (cut-all) ] { } make ;
182 : human-sort ( seq -- newseq )
183 [ dup [ digit? ] [ string>number ] cut-all ] { } map>assoc
186 : ?first ( seq -- first/f ) 0 swap ?nth ; inline
187 : ?second ( seq -- second/f ) 1 swap ?nth ; inline
188 : ?third ( seq -- third/f ) 2 swap ?nth ; inline
189 : ?fourth ( seq -- fourth/f ) 3 swap ?nth ; inline
191 : ?first2 ( seq -- 1st/f 2nd/f ) dup ?first swap ?second ; inline
192 : ?first3 ( seq -- 1st/f 2nd/f 3rd/f ) dup ?first2 rot ?third ; inline
193 : ?first4 ( seq -- 1st/f 2nd/f 3rd/f 4th/f ) dup ?first3 roll ?fourth ; inline
196 : ?subseq ( from to seq -- subseq )
198 [ length tuck min >r min r> ] keep subseq ;
200 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
202 ! List the positions of obj in seq
204 : indices ( seq obj -- seq )
205 >r dup length swap r>
206 [ = [ ] [ drop f ] if ] curry
211 : (attempt-each-integer) ( i n quot -- result )
214 [ 3nip ] [ iterate-next (attempt-each-integer) ] if*
215 ] [ 3drop f ] if-iterate? ; inline
218 : attempt-each ( seq quot -- result )
219 (each) iterate-prep (attempt-each-integer) ; inline
221 : ?nth* ( n seq -- elt/f ? )
222 2dup bounds-check? [ nth-unsafe t ] [ 2drop f f ] if ; flushable
224 : nths ( seq indices -- seq' )
225 swap [ nth ] curry map ;
227 : replace ( str oldseq newseq -- str' )
228 zip >hashtable substitute ;
230 : remove-nth ( seq n -- seq' )
231 cut-slice rest-slice append ;
233 : if-seq ( seq quot1 quot2 -- )
234 [ f like ] 2dip if* ; inline
236 : if-empty ( seq quot1 quot2 -- )