1 ! (c)2010 Joe Groff bsd license
2 USING: accessors assocs combinators.short-circuit fry
3 generalizations hash-sets hashtables kernel macros math
4 math.functions math.order sequences sets ;
5 FROM: sequences.private => nth-unsafe set-nth-unsafe ;
6 FROM: hashtables.private => tombstone? ;
10 ! basic cursor protocol
15 GENERIC: cursor-compatible? ( cursor cursor -- ? )
16 GENERIC: cursor-valid? ( cursor -- ? )
17 GENERIC: cursor= ( cursor cursor -- ? )
18 GENERIC: cursor<= ( cursor cursor -- ? )
19 GENERIC: cursor>= ( cursor cursor -- ? )
20 GENERIC: cursor-distance-hint ( cursor cursor -- n )
22 M: cursor cursor<= cursor= ; inline
23 M: cursor cursor>= cursor= ; inline
24 M: cursor cursor-distance-hint 2drop 0 ; inline
31 INSTANCE: forward-cursor cursor
33 GENERIC: inc-cursor ( cursor -- cursor' )
35 MIXIN: bidirectional-cursor
36 INSTANCE: bidirectional-cursor forward-cursor
38 GENERIC: dec-cursor ( cursor -- cursor' )
40 MIXIN: random-access-cursor
41 INSTANCE: random-access-cursor bidirectional-cursor
43 GENERIC# cursor+ 1 ( cursor n -- cursor' )
44 GENERIC# cursor- 1 ( cursor n -- cursor' )
45 GENERIC: cursor-distance ( cursor cursor -- n )
46 GENERIC: cursor< ( cursor cursor -- ? )
47 GENERIC: cursor> ( cursor cursor -- ? )
49 M: random-access-cursor inc-cursor 1 cursor+ ; inline
50 M: random-access-cursor dec-cursor -1 cursor+ ; inline
51 M: random-access-cursor cursor- neg cursor+ ; inline
52 M: random-access-cursor cursor<= { [ cursor= ] [ cursor< ] } 2|| ; inline
53 M: random-access-cursor cursor>= { [ cursor= ] [ cursor> ] } 2|| ; inline
54 M: random-access-cursor cursor-distance-hint cursor-distance ; inline
60 ERROR: invalid-cursor cursor ;
64 GENERIC: cursor-key-value ( cursor -- key value )
66 GENERIC: cursor-key-value-unsafe ( cursor -- key value )
68 M: input-cursor cursor-key-value-unsafe cursor-key-value ; inline
69 M: input-cursor cursor-key-value
71 [ cursor-key-value-unsafe ]
72 [ invalid-cursor ] if ; inline
74 : cursor-key ( cursor -- key ) cursor-key-value drop ;
75 : cursor-value ( cursor -- key ) cursor-key-value nip ;
77 : cursor-key-unsafe ( cursor -- key ) cursor-key-value-unsafe drop ;
78 : cursor-value-unsafe ( cursor -- key ) cursor-key-value-unsafe nip ;
86 GENERIC: set-cursor-value ( value cursor -- )
88 GENERIC: set-cursor-value-unsafe ( value cursor -- )
90 M: output-cursor set-cursor-value-unsafe set-cursor-value ; inline
91 M: output-cursor set-cursor-value
93 [ set-cursor-value-unsafe ]
94 [ invalid-cursor ] if ; inline
101 INSTANCE: stream-cursor forward-cursor
103 M: stream-cursor cursor-compatible? 2drop f ; inline
104 M: stream-cursor cursor-valid? drop t ; inline
105 M: stream-cursor cursor= 2drop f ; inline
107 MIXIN: infinite-stream-cursor
108 INSTANCE: infinite-stream-cursor stream-cursor
110 M: infinite-stream-cursor inc-cursor ; inline
112 MIXIN: finite-stream-cursor
113 INSTANCE: finite-stream-cursor stream-cursor
115 SINGLETON: end-of-stream
117 GENERIC: cursor-stream-ended? ( cursor -- ? )
119 M: finite-stream-cursor inc-cursor
120 dup cursor-stream-ended? [ drop end-of-stream ] when ; inline
122 INSTANCE: end-of-stream finite-stream-cursor
124 M: end-of-stream cursor-compatible? drop finite-stream-cursor? ; inline
125 M: end-of-stream cursor-valid? drop f ; inline
126 M: end-of-stream cursor= eq? ; inline
127 M: end-of-stream inc-cursor ; inline
128 M: end-of-stream cursor-stream-ended? drop t ; inline
134 : -each ( ... begin end quot: ( ... cursor -- ... ) -- ... )
135 [ '[ dup _ cursor>= ] ]
136 [ '[ _ keep inc-cursor ] ] bi* until drop ; inline
138 : -find ( ... begin end quot: ( ... cursor -- ... ? ) -- ... cursor )
139 '[ dup _ cursor>= [ t ] [ dup @ ] if ] [ inc-cursor ] until ; inline
141 : -in- ( quot -- quot' )
142 '[ cursor-value-unsafe @ ] ; inline
144 : -out- ( quot -- quot' )
145 '[ _ keep set-cursor-value-unsafe ] ; inline
147 : -out ( ... begin end quot: ( ... cursor -- ... value ) -- ... )
154 TUPLE: numeric-cursor
155 { value read-only } ;
157 M: numeric-cursor cursor-valid? drop t ; inline
159 M: numeric-cursor cursor= [ value>> ] bi@ = ; inline
161 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
166 INSTANCE: numeric-cursor input-cursor
168 M: numeric-cursor cursor-key-value value>> dup ; inline
174 TUPLE: linear-cursor < numeric-cursor
175 { delta read-only } ;
176 C: <linear-cursor> linear-cursor
178 INSTANCE: linear-cursor random-access-cursor
180 M: linear-cursor cursor-compatible?
181 [ linear-cursor? ] both? ; inline
183 M: linear-cursor inc-cursor
184 [ value>> ] [ delta>> ] bi [ + ] keep <linear-cursor> ; inline
185 M: linear-cursor dec-cursor
186 [ value>> ] [ delta>> ] bi [ - ] keep <linear-cursor> ; inline
187 M: linear-cursor cursor+
188 [ [ value>> ] [ delta>> ] bi ] dip [ * + ] keep <linear-cursor> ; inline
189 M: linear-cursor cursor-
190 [ [ value>> ] [ delta>> ] bi ] dip [ * - ] keep <linear-cursor> ; inline
192 GENERIC: up/i ( distance delta -- distance' )
193 M: integer up/i [ 1 - + ] keep /i ; inline
194 M: real up/i / ceiling >integer ; inline
196 M: linear-cursor cursor-distance
197 [ [ value>> ] bi@ - ] [ nip delta>> ] 2bi up/i ; inline
203 TUPLE: quadratic-cursor < numeric-cursor
205 { delta2 read-only } ;
207 C: <quadratic-cursor> quadratic-cursor
209 INSTANCE: quadratic-cursor bidirectional-cursor
211 M: quadratic-cursor cursor-compatible?
212 [ linear-cursor? ] both? ; inline
214 M: quadratic-cursor inc-cursor
215 [ value>> ] [ delta>> [ + ] keep ] [ delta2>> [ + ] keep ] tri <quadratic-cursor> ; inline
217 M: quadratic-cursor dec-cursor
218 [ value>> ] [ delta>> ] [ delta2>> ] tri [ - [ - ] keep ] keep <quadratic-cursor> ; inline
226 GENERIC: begin-cursor ( collection -- cursor )
227 GENERIC: end-cursor ( collection -- cursor )
229 : all ( collection -- begin end )
230 [ begin-cursor ] [ end-cursor ] bi ; inline
232 : all- ( collection quot -- begin end quot )
240 INSTANCE: container collection
242 : in- ( container quot -- begin end quot' )
245 : each ( ... container quot: ( ... x -- ... ) -- ... ) in- -each ; inline
247 INSTANCE: finite-stream-cursor container
249 M: finite-stream-cursor begin-cursor ; inline
250 M: finite-stream-cursor end-cursor drop end-of-stream ; inline
256 TUPLE: sequence-cursor
258 { n fixnum read-only } ;
259 C: <sequence-cursor> sequence-cursor
261 INSTANCE: sequence container
263 M: sequence begin-cursor 0 <sequence-cursor> ; inline
264 M: sequence end-cursor dup length <sequence-cursor> ; inline
266 INSTANCE: sequence-cursor random-access-cursor
268 M: sequence-cursor cursor-compatible?
270 [ [ sequence-cursor? ] both? ]
271 [ [ seq>> ] bi@ eq? ]
274 M: sequence-cursor cursor-valid?
275 [ n>> ] [ seq>> ] bi bounds-check? ; inline
277 M: sequence-cursor cursor= [ n>> ] bi@ = ; 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 inc-cursor [ seq>> ] [ n>> ] bi 1 + <sequence-cursor> ; inline
283 M: sequence-cursor dec-cursor [ seq>> ] [ n>> ] bi 1 - <sequence-cursor> ; inline
284 M: sequence-cursor cursor+ [ [ seq>> ] [ n>> ] bi ] dip + <sequence-cursor> ; inline
285 M: sequence-cursor cursor- [ [ seq>> ] [ n>> ] bi ] dip - <sequence-cursor> ; inline
286 M: sequence-cursor cursor-distance ( cursor cursor -- n )
287 [ n>> ] bi@ - ; inline
289 INSTANCE: sequence-cursor input-cursor
291 M: sequence-cursor cursor-key-value-unsafe [ n>> dup ] [ seq>> ] bi nth-unsafe ; inline
292 M: sequence-cursor cursor-key-value [ n>> dup ] [ seq>> ] bi nth ; inline
294 INSTANCE: sequence-cursor output-cursor
296 M: sequence-cursor set-cursor-value-unsafe [ n>> ] [ seq>> ] bi set-nth-unsafe ; inline
297 M: sequence-cursor set-cursor-value [ n>> ] [ seq>> ] bi set-nth ; inline
303 TUPLE: hash-set-cursor
304 { hash-set hash-set read-only }
305 { n fixnum read-only } ;
307 C: <hash-set-cursor> hash-set-cursor
310 INSTANCE: hash-set-cursor forward-cursor
312 M: hash-set-cursor cursor-compatible?
314 [ [ hash-set-cursor? ] both? ]
315 [ [ hash-set>> ] bi@ eq? ]
318 M: hash-set-cursor cursor-valid? ( cursor -- ? )
319 [ n>> ] [ hash-set>> array>> ] bi bounds-check? ; inline
321 M: hash-set-cursor cursor= ( cursor cursor -- ? )
322 [ n>> ] bi@ = ; inline
323 M: hash-set-cursor cursor-distance-hint ( cursor cursor -- n )
324 nip hash-set>> cardinality ; inline
327 : (inc-hash-set-cursor) ( array n -- n' )
328 [ 2dup swap { [ length < ] [ nth-unsafe tombstone? ] } 2&& ] [ 1 + ] while nip ; inline
331 M: hash-set-cursor inc-cursor ( cursor -- cursor' )
332 [ hash-set>> dup array>> ] [ n>> 1 + ] bi
333 (inc-hash-set-cursor) <hash-set-cursor> ; inline
335 INSTANCE: hash-set-cursor input-cursor
337 M: hash-set-cursor cursor-key-value-unsafe
338 [ n>> dup ] [ hash-set>> array>> ] bi nth-unsafe ; inline
340 INSTANCE: hash-set container
342 M: hash-set begin-cursor
343 dup array>> 0 (inc-hash-set-cursor) <hash-set-cursor> ; inline
344 M: hash-set end-cursor
345 dup array>> length <hash-set-cursor> ; inline
354 C: <map-cursor> map-cursor
356 INSTANCE: map-cursor forward-cursor
358 M: map-cursor cursor-compatible? [ from>> ] bi@ cursor-compatible? ; inline
359 M: map-cursor cursor-valid? [ from>> ] [ to>> ] bi [ cursor-valid? ] both? ; inline
360 M: map-cursor cursor= [ from>> ] bi@ cursor= ; inline
361 M: map-cursor inc-cursor [ from>> inc-cursor ] [ to>> inc-cursor ] bi <map-cursor> ; inline
363 INSTANCE: map-cursor output-cursor
365 M: map-cursor set-cursor-value-unsafe to>> set-cursor-value-unsafe ; inline
366 M: map-cursor set-cursor-value to>> set-cursor-value ; inline
368 : -map- ( begin end quot to -- begin' end' quot' )
369 swap [ '[ _ <map-cursor> ] bi@ ] dip '[ from>> @ ] -out- ; inline
371 : -map ( begin end quot to -- begin' end' quot' )
379 { growable read-only } ;
380 C: <pusher-cursor> pusher-cursor
382 INSTANCE: pusher-cursor infinite-stream-cursor
383 INSTANCE: pusher-cursor output-cursor
385 M: pusher-cursor set-cursor-value growable>> push ; inline
388 ! Create cursors into new sequences
391 : new-growable-cursor ( begin end exemplar -- cursor result )
392 [ swap cursor-distance-hint ] dip new-resizable [ <pusher-cursor> ] keep ; inline
394 GENERIC# new-sequence-cursor 1 ( begin end exemplar -- cursor result )
396 M: random-access-cursor new-sequence-cursor
397 [ swap cursor-distance ] dip new-sequence [ begin-cursor ] keep ; inline
398 M: forward-cursor new-sequence-cursor
399 new-growable-cursor ; inline
401 : -into-sequence- ( begin end quot exemplar -- begin' end' quot' cursor result )
402 [ 2over ] dip new-sequence-cursor ; inline
404 : -into-growable- ( begin end quot exemplar -- begin' end' quot' cursor result )
405 [ 2over ] dip new-growable-cursor ; inline
411 ! XXX generalize exemplar
412 : -map-as ( ... begin end quot: ( ... cursor -- ... value ) exemplar -- ... newseq )
413 [ -into-sequence- [ -map ] dip ] keep like ; inline
415 : map! ( ... container quot: ( ... x -- ... newx ) -- ... container )
416 [ in- -out ] keep ; inline
417 : map-as ( ... container quot: ( ... x -- ... newx ) exemplar -- ... newseq )
418 [ in- ] dip -map-as ; inline
419 : map ( ... container quot: ( ... x -- ... newx ) -- ... newcontainer )
426 : -assoc- ( quot -- quot' )
427 '[ cursor-key-value @ ] ; inline
429 : assoc- ( assoc quot -- begin end quot' )
430 all- -assoc- ; inline
432 : assoc-each ( ... assoc quot: ( ... k v -- ... ) -- ... )
433 assoc- -each ; inline
434 : assoc>map ( ... assoc quot: ( ... k v -- ... newx ) exemplar -- ... newcontainer )
435 [ assoc- ] dip -map-as ; inline
441 TUPLE: hashtable-cursor
442 { hashtable hashtable read-only }
443 { n fixnum read-only } ;
445 C: <hashtable-cursor> hashtable-cursor
448 INSTANCE: hashtable-cursor forward-cursor
450 M: hashtable-cursor cursor-compatible?
452 [ [ hashtable-cursor? ] both? ]
453 [ [ hashtable>> ] bi@ eq? ]
456 M: hashtable-cursor cursor-valid? ( cursor -- ? )
457 [ n>> ] [ hashtable>> array>> ] bi bounds-check? ; inline
459 M: hashtable-cursor cursor= ( cursor cursor -- ? )
460 [ n>> ] bi@ = ; inline
461 M: hashtable-cursor cursor-distance-hint ( cursor cursor -- n )
462 nip hashtable>> assoc-size ; inline
465 : (inc-hashtable-cursor) ( array n -- n' )
466 [ 2dup swap { [ length < ] [ nth-unsafe tombstone? ] } 2&& ] [ 2 + ] while nip ; inline
469 M: hashtable-cursor inc-cursor ( cursor -- cursor' )
470 [ hashtable>> dup array>> ] [ n>> 2 + ] bi
471 (inc-hashtable-cursor) <hashtable-cursor> ; inline
473 INSTANCE: hashtable-cursor input-cursor
475 M: hashtable-cursor cursor-key-value-unsafe
476 [ n>> ] [ hashtable>> array>> ] bi
477 [ nth-unsafe ] [ [ 1 + ] dip nth-unsafe ] 2bi ; inline
479 INSTANCE: hashtable container
481 M: hashtable begin-cursor
482 dup array>> 0 (inc-hashtable-cursor) <hashtable-cursor> ; inline
483 M: hashtable end-cursor
484 dup array>> length <hashtable-cursor> ; inline
492 { values read-only } ;
493 C: <zip-cursor> zip-cursor
495 INSTANCE: zip-cursor forward-cursor
497 M: zip-cursor cursor-compatible? ( cursor cursor -- ? )
499 [ [ zip-cursor? ] both? ]
500 [ [ keys>> ] bi@ cursor-compatible? ]
501 [ [ values>> ] bi@ cursor-compatible? ]
504 M: zip-cursor cursor-valid? ( cursor -- ? )
505 [ keys>> ] [ values>> ] bi [ cursor-valid? ] both? ; inline
506 M: zip-cursor cursor= ( cursor cursor -- ? )
508 [ [ keys>> ] bi@ cursor= ]
509 [ [ values>> ] bi@ cursor= ]
512 M: zip-cursor cursor-distance-hint ( cursor cursor -- n )
513 [ [ keys>> ] bi@ cursor-distance-hint ]
514 [ [ values>> ] bi@ cursor-distance-hint ] 2bi min ; inline
516 M: zip-cursor inc-cursor ( cursor -- cursor' )
517 [ keys>> inc-cursor ] [ values>> inc-cursor ] bi <zip-cursor> ; inline
519 INSTANCE: zip-cursor input-cursor
521 M: zip-cursor cursor-key-value
522 [ keys>> cursor-value-unsafe ] [ values>> cursor-value-unsafe ] bi ; inline
524 : zip-cursors ( a-begin a-end b-begin b-end -- begin end )
525 [ <zip-cursor> ] bi-curry@ bi* ; inline
527 : 2all ( a b -- begin end )
528 [ all ] bi@ zip-cursors ; inline
530 : 2all- ( a b quot -- begin end quot )
531 [ 2all ] dip ; inline
535 : 2in- ( a b quot -- begin end quot' )
538 : 2each ( ... a b quot: ( ... x y -- ... ) -- ... )
541 : 2map-as ( ... a b quot: ( ... x y -- ... z ) exemplar -- ... c )
542 [ 2in- ] dip -map-as ; inline
544 : 2map ( ... a b quot: ( ... x y -- ... z ) -- ... c )
545 pick 2map-as ; inline
551 : -unzip- ( quot -- quot' )
552 '[ [ keys>> cursor-value-unsafe ] [ values>> ] bi @ ] ; inline
554 MACRO: nzip-cursors ( n -- quot ) 1 - [ zip-cursors ] n*quot ;
556 : nall ( seqs... n -- begin end ) [ [ all ] swap napply ] [ nzip-cursors ] bi ; inline
558 : nall- ( seqs... quot n -- begin end quot ) swap [ nall ] dip ; inline
560 MACRO: -nin- ( n -- quot )
561 1 - [ -unzip- ] n*quot [ -in- ] prepend ;
563 : nin- ( seqs... quot n -- begin end quot ) [ nall- ] [ -nin- ] bi ; inline
565 : neach ( seqs... quot n -- ) nin- -each ; inline
566 : nmap-as ( seqs... quot exemplar n -- newseq )
567 swap [ nin- ] dip -map-as ; inline
568 : nmap ( seqs... quot n -- newseq )
569 dup [ npick ] curry [ dip swap ] curry dip nmap-as ; inline
575 : -with- ( invariant begin end quot -- begin end quot' )
576 [ rot ] dip '[ [ _ ] dip @ ] ; inline
578 : -2with- ( invariant invariant begin end quot -- begin end quot' )
579 -with- -with- ; inline
581 MACRO: -nwith- ( n -- quot )