1 ! Copyright (C) 2010 Joe Groff.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors assocs combinators.short-circuit fry
4 generalizations hash-sets hashtables kernel macros math
5 math.functions math.order sequences sets ;
6 FROM: sequences.private => nth-unsafe set-nth-unsafe ;
7 FROM: hashtables.private => tombstone? ;
11 ! basic cursor protocol
16 GENERIC: cursor-compatible? ( cursor cursor -- ? )
17 GENERIC: cursor-valid? ( cursor -- ? )
18 GENERIC: cursor= ( cursor cursor -- ? )
19 GENERIC: cursor<= ( cursor cursor -- ? )
20 GENERIC: cursor>= ( cursor cursor -- ? )
21 GENERIC: cursor-distance-hint ( cursor cursor -- n )
23 M: cursor cursor<= cursor= ; inline
24 M: cursor cursor>= cursor= ; inline
25 M: cursor cursor-distance-hint 2drop 0 ; inline
32 INSTANCE: forward-cursor cursor
34 GENERIC: inc-cursor ( cursor -- cursor' )
36 MIXIN: bidirectional-cursor
37 INSTANCE: bidirectional-cursor forward-cursor
39 GENERIC: dec-cursor ( cursor -- cursor' )
41 MIXIN: random-access-cursor
42 INSTANCE: random-access-cursor bidirectional-cursor
44 GENERIC#: cursor+ 1 ( cursor n -- cursor' )
45 GENERIC#: cursor- 1 ( cursor n -- cursor' )
46 GENERIC: cursor-distance ( cursor cursor -- n )
47 GENERIC: cursor< ( cursor cursor -- ? )
48 GENERIC: cursor> ( cursor cursor -- ? )
50 M: random-access-cursor inc-cursor 1 cursor+ ; inline
51 M: random-access-cursor dec-cursor -1 cursor+ ; inline
52 M: random-access-cursor cursor- neg cursor+ ; inline
53 M: random-access-cursor cursor<= { [ cursor= ] [ cursor< ] } 2|| ; inline
54 M: random-access-cursor cursor>= { [ cursor= ] [ cursor> ] } 2|| ; inline
55 M: random-access-cursor cursor-distance-hint cursor-distance ; inline
61 ERROR: invalid-cursor cursor ;
65 GENERIC: cursor-key-value ( cursor -- key value )
67 GENERIC: cursor-key-value-unsafe ( cursor -- key value )
69 M: input-cursor cursor-key-value-unsafe cursor-key-value ; inline
70 M: input-cursor cursor-key-value
72 [ cursor-key-value-unsafe ]
73 [ invalid-cursor ] if ; inline
75 : cursor-key ( cursor -- key ) cursor-key-value drop ;
76 : cursor-value ( cursor -- key ) cursor-key-value nip ;
78 : cursor-key-unsafe ( cursor -- key ) cursor-key-value-unsafe drop ;
79 : cursor-value-unsafe ( cursor -- key ) cursor-key-value-unsafe nip ;
87 GENERIC: set-cursor-value ( value cursor -- )
89 GENERIC: set-cursor-value-unsafe ( value cursor -- )
91 M: output-cursor set-cursor-value-unsafe set-cursor-value ; inline
92 M: output-cursor set-cursor-value
94 [ set-cursor-value-unsafe ]
95 [ invalid-cursor ] if ; inline
102 INSTANCE: stream-cursor forward-cursor
104 M: stream-cursor cursor-compatible? 2drop f ; inline
105 M: stream-cursor cursor-valid? drop t ; inline
106 M: stream-cursor cursor= 2drop f ; inline
108 MIXIN: infinite-stream-cursor
109 INSTANCE: infinite-stream-cursor stream-cursor
111 M: infinite-stream-cursor inc-cursor ; inline
113 MIXIN: finite-stream-cursor
114 INSTANCE: finite-stream-cursor stream-cursor
116 SINGLETON: end-of-stream
118 GENERIC: cursor-stream-ended? ( cursor -- ? )
120 M: finite-stream-cursor inc-cursor
121 dup cursor-stream-ended? [ drop end-of-stream ] when ; inline
123 INSTANCE: end-of-stream finite-stream-cursor
125 M: end-of-stream cursor-compatible? drop finite-stream-cursor? ; inline
126 M: end-of-stream cursor-valid? drop f ; inline
127 M: end-of-stream cursor= eq? ; inline
128 M: end-of-stream inc-cursor ; inline
129 M: end-of-stream cursor-stream-ended? drop t ; inline
135 : -each ( ... begin end quot: ( ... cursor -- ... ) -- ... )
136 [ '[ dup _ cursor>= ] ]
137 [ '[ _ keep inc-cursor ] ] bi* until drop ; inline
139 : -find ( ... begin end quot: ( ... cursor -- ... ? ) -- ... cursor )
140 '[ dup _ cursor>= [ t ] [ dup @ ] if ] [ inc-cursor ] until ; inline
142 : -in- ( quot -- quot' )
143 '[ cursor-value-unsafe @ ] ; inline
145 : -out- ( quot -- quot' )
146 '[ _ keep set-cursor-value-unsafe ] ; inline
148 : -out ( ... begin end quot: ( ... cursor -- ... value ) -- ... )
155 TUPLE: numeric-cursor
156 { value read-only } ;
158 M: numeric-cursor cursor-valid? drop t ; inline
160 M: numeric-cursor cursor= [ value>> ] bi@ = ; inline
162 M: numeric-cursor cursor<= [ value>> ] bi@ <= ; inline
163 M: numeric-cursor cursor< [ value>> ] bi@ < ; inline
164 M: numeric-cursor cursor> [ value>> ] bi@ > ; inline
165 M: numeric-cursor cursor>= [ value>> ] bi@ >= ; inline
167 INSTANCE: numeric-cursor input-cursor
169 M: numeric-cursor cursor-key-value value>> dup ; inline
175 TUPLE: linear-cursor < numeric-cursor
176 { delta read-only } ;
177 C: <linear-cursor> linear-cursor
179 INSTANCE: linear-cursor random-access-cursor
181 M: linear-cursor cursor-compatible?
182 [ linear-cursor? ] both? ; inline
184 M: linear-cursor inc-cursor
185 [ value>> ] [ delta>> ] bi [ + ] keep <linear-cursor> ; inline
186 M: linear-cursor dec-cursor
187 [ value>> ] [ delta>> ] bi [ - ] keep <linear-cursor> ; inline
188 M: linear-cursor cursor+
189 [ [ value>> ] [ delta>> ] bi ] dip [ * + ] keep <linear-cursor> ; inline
190 M: linear-cursor cursor-
191 [ [ value>> ] [ delta>> ] bi ] dip [ * - ] keep <linear-cursor> ; inline
193 GENERIC: up/i ( distance delta -- distance' )
194 M: integer up/i [ 1 - + ] keep /i ; inline
195 M: real up/i / ceiling >integer ; inline
197 M: linear-cursor cursor-distance
198 [ [ value>> ] bi@ - ] [ nip delta>> ] 2bi up/i ; inline
204 TUPLE: quadratic-cursor < numeric-cursor
206 { delta2 read-only } ;
208 C: <quadratic-cursor> quadratic-cursor
210 INSTANCE: quadratic-cursor bidirectional-cursor
212 M: quadratic-cursor cursor-compatible?
213 [ linear-cursor? ] both? ; inline
215 M: quadratic-cursor inc-cursor
216 [ value>> ] [ delta>> [ + ] keep ] [ delta2>> [ + ] keep ] tri <quadratic-cursor> ; inline
218 M: quadratic-cursor dec-cursor
219 [ value>> ] [ delta>> ] [ delta2>> ] tri [ - [ - ] keep ] keep <quadratic-cursor> ; inline
227 GENERIC: begin-cursor ( collection -- cursor )
228 GENERIC: end-cursor ( collection -- cursor )
230 : all ( collection -- begin end )
231 [ begin-cursor ] [ end-cursor ] bi ; inline
233 : all- ( collection quot -- begin end quot )
241 INSTANCE: container collection
243 : in- ( container quot -- begin end quot' )
246 : each ( ... container quot: ( ... x -- ... ) -- ... ) in- -each ; inline
248 INSTANCE: finite-stream-cursor container
250 M: finite-stream-cursor begin-cursor ; inline
251 M: finite-stream-cursor end-cursor drop end-of-stream ; inline
257 TUPLE: sequence-cursor
259 { n fixnum read-only } ;
260 C: <sequence-cursor> sequence-cursor
262 INSTANCE: sequence container
264 M: sequence begin-cursor 0 <sequence-cursor> ; inline
265 M: sequence end-cursor dup length <sequence-cursor> ; inline
267 INSTANCE: sequence-cursor random-access-cursor
269 M: sequence-cursor cursor-compatible?
271 [ [ sequence-cursor? ] both? ]
272 [ [ seq>> ] bi@ eq? ]
275 M: sequence-cursor cursor-valid?
276 [ n>> ] [ seq>> ] bi bounds-check? ; inline
278 M: sequence-cursor cursor= [ n>> ] bi@ = ; inline
279 M: sequence-cursor cursor<= [ n>> ] bi@ <= ; inline
280 M: sequence-cursor cursor>= [ n>> ] bi@ >= ; inline
281 M: sequence-cursor cursor< [ n>> ] bi@ < ; inline
282 M: sequence-cursor cursor> [ n>> ] bi@ > ; inline
283 M: sequence-cursor inc-cursor [ seq>> ] [ n>> ] bi 1 + <sequence-cursor> ; inline
284 M: sequence-cursor dec-cursor [ seq>> ] [ n>> ] bi 1 - <sequence-cursor> ; inline
285 M: sequence-cursor cursor+ [ [ seq>> ] [ n>> ] bi ] dip + <sequence-cursor> ; inline
286 M: sequence-cursor cursor- [ [ seq>> ] [ n>> ] bi ] dip - <sequence-cursor> ; inline
287 M: sequence-cursor cursor-distance ( cursor cursor -- n )
288 [ n>> ] bi@ - ; inline
290 INSTANCE: sequence-cursor input-cursor
292 M: sequence-cursor cursor-key-value-unsafe [ n>> dup ] [ seq>> ] bi nth-unsafe ; inline
293 M: sequence-cursor cursor-key-value [ n>> dup ] [ seq>> ] bi nth ; inline
295 INSTANCE: sequence-cursor output-cursor
297 M: sequence-cursor set-cursor-value-unsafe [ n>> ] [ seq>> ] bi set-nth-unsafe ; inline
298 M: sequence-cursor set-cursor-value [ n>> ] [ seq>> ] bi set-nth ; inline
304 TUPLE: hash-set-cursor
305 { hash-set hash-set read-only }
306 { n fixnum read-only } ;
308 C: <hash-set-cursor> hash-set-cursor
311 INSTANCE: hash-set-cursor forward-cursor
313 M: hash-set-cursor cursor-compatible?
315 [ [ hash-set-cursor? ] both? ]
316 [ [ hash-set>> ] bi@ eq? ]
319 M: hash-set-cursor cursor-valid? ( cursor -- ? )
320 [ n>> ] [ hash-set>> array>> ] bi bounds-check? ; inline
322 M: hash-set-cursor cursor= ( cursor cursor -- ? )
323 [ n>> ] bi@ = ; inline
324 M: hash-set-cursor cursor-distance-hint ( cursor cursor -- n )
325 nip hash-set>> cardinality ; inline
328 : (inc-hash-set-cursor) ( array n -- n' )
329 [ 2dup swap { [ length < ] [ nth-unsafe tombstone? ] } 2&& ] [ 1 + ] while nip ; inline
332 M: hash-set-cursor inc-cursor ( cursor -- cursor' )
333 [ hash-set>> dup array>> ] [ n>> 1 + ] bi
334 (inc-hash-set-cursor) <hash-set-cursor> ; inline
336 INSTANCE: hash-set-cursor input-cursor
338 M: hash-set-cursor cursor-key-value-unsafe
339 [ n>> dup ] [ hash-set>> array>> ] bi nth-unsafe ; inline
341 INSTANCE: hash-set container
343 M: hash-set begin-cursor
344 dup array>> 0 (inc-hash-set-cursor) <hash-set-cursor> ; inline
345 M: hash-set end-cursor
346 dup array>> length <hash-set-cursor> ; inline
355 C: <map-cursor> map-cursor
357 INSTANCE: map-cursor forward-cursor
359 M: map-cursor cursor-compatible? [ from>> ] bi@ cursor-compatible? ; inline
360 M: map-cursor cursor-valid? [ from>> ] [ to>> ] bi [ cursor-valid? ] both? ; inline
361 M: map-cursor cursor= [ from>> ] bi@ cursor= ; inline
362 M: map-cursor inc-cursor [ from>> inc-cursor ] [ to>> inc-cursor ] bi <map-cursor> ; inline
364 INSTANCE: map-cursor output-cursor
366 M: map-cursor set-cursor-value-unsafe to>> set-cursor-value-unsafe ; inline
367 M: map-cursor set-cursor-value to>> set-cursor-value ; inline
369 : -map- ( begin end quot to -- begin' end' quot' )
370 swap [ '[ _ <map-cursor> ] bi@ ] dip '[ from>> @ ] -out- ; inline
372 : -map ( begin end quot to -- begin' end' quot' )
380 { growable read-only } ;
381 C: <pusher-cursor> pusher-cursor
383 INSTANCE: pusher-cursor infinite-stream-cursor
384 INSTANCE: pusher-cursor output-cursor
386 M: pusher-cursor set-cursor-value growable>> push ; inline
389 ! Create cursors into new sequences
392 : new-growable-cursor ( begin end exemplar -- cursor result )
393 [ swap cursor-distance-hint ] dip new-resizable [ <pusher-cursor> ] keep ; inline
395 GENERIC#: new-sequence-cursor 1 ( begin end exemplar -- cursor result )
397 M: random-access-cursor new-sequence-cursor
398 [ swap cursor-distance ] dip new-sequence [ begin-cursor ] keep ; inline
399 M: forward-cursor new-sequence-cursor
400 new-growable-cursor ; inline
402 : -into-sequence- ( begin end quot exemplar -- begin' end' quot' cursor result )
403 [ 2over ] dip new-sequence-cursor ; inline
405 : -into-growable- ( begin end quot exemplar -- begin' end' quot' cursor result )
406 [ 2over ] dip new-growable-cursor ; inline
412 ! XXX generalize exemplar
413 : -map-as ( ... begin end quot: ( ... cursor -- ... value ) exemplar -- ... newseq )
414 [ -into-sequence- [ -map ] dip ] keep like ; inline
416 : map! ( ... container quot: ( ... x -- ... newx ) -- ... container )
417 [ in- -out ] keep ; inline
418 : map-as ( ... container quot: ( ... x -- ... newx ) exemplar -- ... newseq )
419 [ in- ] dip -map-as ; inline
420 : map ( ... container quot: ( ... x -- ... newx ) -- ... newcontainer )
427 : -assoc- ( quot -- quot' )
428 '[ cursor-key-value @ ] ; inline
430 : assoc- ( assoc quot -- begin end quot' )
431 all- -assoc- ; inline
433 : assoc-each ( ... assoc quot: ( ... k v -- ... ) -- ... )
434 assoc- -each ; inline
435 : assoc>map ( ... assoc quot: ( ... k v -- ... newx ) exemplar -- ... newcontainer )
436 [ assoc- ] dip -map-as ; inline
442 TUPLE: hashtable-cursor
443 { hashtable hashtable read-only }
444 { n fixnum read-only } ;
446 C: <hashtable-cursor> hashtable-cursor
449 INSTANCE: hashtable-cursor forward-cursor
451 M: hashtable-cursor cursor-compatible?
453 [ [ hashtable-cursor? ] both? ]
454 [ [ hashtable>> ] bi@ eq? ]
457 M: hashtable-cursor cursor-valid? ( cursor -- ? )
458 [ n>> ] [ hashtable>> array>> ] bi bounds-check? ; inline
460 M: hashtable-cursor cursor= ( cursor cursor -- ? )
461 [ n>> ] bi@ = ; inline
462 M: hashtable-cursor cursor-distance-hint ( cursor cursor -- n )
463 nip hashtable>> assoc-size ; inline
466 : (inc-hashtable-cursor) ( array n -- n' )
467 [ 2dup swap { [ length < ] [ nth-unsafe tombstone? ] } 2&& ] [ 2 + ] while nip ; inline
470 M: hashtable-cursor inc-cursor ( cursor -- cursor' )
471 [ hashtable>> dup array>> ] [ n>> 2 + ] bi
472 (inc-hashtable-cursor) <hashtable-cursor> ; inline
474 INSTANCE: hashtable-cursor input-cursor
476 M: hashtable-cursor cursor-key-value-unsafe
477 [ n>> ] [ hashtable>> array>> ] bi
478 [ nth-unsafe ] [ [ 1 + ] dip nth-unsafe ] 2bi ; inline
480 INSTANCE: hashtable container
482 M: hashtable begin-cursor
483 dup array>> 0 (inc-hashtable-cursor) <hashtable-cursor> ; inline
484 M: hashtable end-cursor
485 dup array>> length <hashtable-cursor> ; inline
493 { values read-only } ;
494 C: <zip-cursor> zip-cursor
496 INSTANCE: zip-cursor forward-cursor
498 M: zip-cursor cursor-compatible? ( cursor cursor -- ? )
500 [ [ zip-cursor? ] both? ]
501 [ [ keys>> ] bi@ cursor-compatible? ]
502 [ [ values>> ] bi@ cursor-compatible? ]
505 M: zip-cursor cursor-valid? ( cursor -- ? )
506 [ keys>> ] [ values>> ] bi [ cursor-valid? ] both? ; inline
507 M: zip-cursor cursor= ( cursor cursor -- ? )
509 [ [ keys>> ] bi@ cursor= ]
510 [ [ values>> ] bi@ cursor= ]
513 M: zip-cursor cursor-distance-hint ( cursor cursor -- n )
514 [ [ keys>> ] bi@ cursor-distance-hint ]
515 [ [ values>> ] bi@ cursor-distance-hint ] 2bi min ; inline
517 M: zip-cursor inc-cursor ( cursor -- cursor' )
518 [ keys>> inc-cursor ] [ values>> inc-cursor ] bi <zip-cursor> ; inline
520 INSTANCE: zip-cursor input-cursor
522 M: zip-cursor cursor-key-value
523 [ keys>> cursor-value-unsafe ] [ values>> cursor-value-unsafe ] bi ; inline
525 : zip-cursors ( a-begin a-end b-begin b-end -- begin end )
526 [ <zip-cursor> ] bi-curry@ bi* ; inline
528 : 2all ( a b -- begin end )
529 [ all ] bi@ zip-cursors ; inline
531 : 2all- ( a b quot -- begin end quot )
532 [ 2all ] dip ; inline
536 : 2in- ( a b quot -- begin end quot' )
539 : 2each ( ... a b quot: ( ... x y -- ... ) -- ... )
542 : 2map-as ( ... a b quot: ( ... x y -- ... z ) exemplar -- ... c )
543 [ 2in- ] dip -map-as ; inline
545 : 2map ( ... a b quot: ( ... x y -- ... z ) -- ... c )
546 pick 2map-as ; inline
552 : -unzip- ( quot -- quot' )
553 '[ [ keys>> cursor-value-unsafe ] [ values>> ] bi @ ] ; inline
555 MACRO: nzip-cursors ( n -- quot ) 1 - [ zip-cursors ] n*quot ;
557 : nall ( seqs... n -- begin end ) [ [ all ] swap napply ] [ nzip-cursors ] bi ; inline
559 : nall- ( seqs... quot n -- begin end quot ) swap [ nall ] dip ; inline
561 MACRO: -nin- ( n -- quot )
562 1 - [ -unzip- ] n*quot [ -in- ] prepend ;
564 : nin- ( seqs... quot n -- begin end quot ) [ nall- ] [ -nin- ] bi ; inline
566 : neach ( seqs... quot n -- ) nin- -each ; inline
567 : nmap-as ( seqs... quot exemplar n -- newseq )
568 swap [ nin- ] dip -map-as ; inline
569 : nmap ( seqs... quot n -- newseq )
570 dup [ npick ] curry [ dip swap ] curry dip nmap-as ; inline
576 : -with- ( invariant begin end quot -- begin end quot' )
577 rotd '[ [ _ ] dip @ ] ; inline
579 : -2with- ( invariant invariant begin end quot -- begin end quot' )
580 -with- -with- ; inline
582 MACRO: -nwith- ( n -- quot )