1 ! Copyright (C) 2005, 2008 Slava Pestov, Daniel Ehrenberg.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors kernel kernel.private slots.private math
4 math.private math.order ;
9 GENERIC: length ( seq -- n ) flushable
10 GENERIC: set-length ( n seq -- )
11 GENERIC: nth ( n seq -- elt ) flushable
12 GENERIC: set-nth ( elt n seq -- )
13 GENERIC: new-sequence ( len seq -- newseq ) flushable
14 GENERIC: new-resizable ( len seq -- newseq ) flushable
15 GENERIC: like ( seq exemplar -- newseq ) flushable
16 GENERIC: clone-like ( seq exemplar -- newseq ) flushable
18 : new-like ( len exemplar quot -- seq )
19 over >r >r new-sequence r> call r> like ; inline
21 M: sequence like drop ;
23 GENERIC: lengthen ( n seq -- )
25 M: sequence lengthen 2dup length > [ set-length ] [ 2drop ] if ;
27 : empty? ( seq -- ? ) length zero? ; inline
28 : delete-all ( seq -- ) 0 swap set-length ;
30 : first ( seq -- first ) 0 swap nth ; inline
31 : second ( seq -- second ) 1 swap nth ; inline
32 : third ( seq -- third ) 2 swap nth ; inline
33 : fourth ( seq -- fourth ) 3 swap nth ; inline
35 : set-first ( first seq -- ) 0 swap set-nth ; inline
36 : set-second ( second seq -- ) 1 swap set-nth ; inline
37 : set-third ( third seq -- ) 2 swap set-nth ; inline
38 : set-fourth ( fourth seq -- ) 3 swap set-nth ; inline
40 : push ( elt seq -- ) [ length ] [ set-nth ] bi ;
42 : bounds-check? ( n seq -- ? )
43 length 1- 0 swap between? ; inline
45 ERROR: bounds-error index seq ;
47 : bounds-check ( n seq -- n seq )
48 2dup bounds-check? [ bounds-error ] unless ; inline
50 MIXIN: immutable-sequence
52 ERROR: immutable seq ;
54 M: immutable-sequence set-nth immutable ;
56 INSTANCE: immutable-sequence sequence
60 : array-capacity ( array -- n )
61 1 slot { array-capacity } declare ; inline
63 : array-nth ( n array -- elt )
64 swap 2 fixnum+fast slot ; inline
66 : set-array-nth ( elt n array -- )
67 swap 2 fixnum+fast set-slot ; inline
69 : dispatch ( n array -- ) array-nth (call) ;
71 GENERIC: resize ( n seq -- newseq ) flushable
73 ! Unsafe sequence protocol for inner loops
74 GENERIC: nth-unsafe ( n seq -- elt ) flushable
75 GENERIC: set-nth-unsafe ( elt n seq -- )
77 M: sequence nth bounds-check nth-unsafe ;
78 M: sequence set-nth bounds-check set-nth-unsafe ;
80 M: sequence nth-unsafe nth ;
81 M: sequence set-nth-unsafe set-nth ;
83 ! The f object supports the sequence protocol trivially
86 M: f like drop dup empty? [ drop f ] when ;
88 INSTANCE: f immutable-sequence
90 ! Integers support the sequence protocol
92 M: integer nth-unsafe drop ;
94 INSTANCE: integer immutable-sequence
97 [ 0 swap nth-unsafe 1 ] [ nth-unsafe ] bi ; inline
100 [ first2-unsafe 2 ] [ nth-unsafe ] bi ; inline
103 [ first3-unsafe 3 ] [ nth-unsafe ] bi ; inline
105 : exchange-unsafe ( m n seq -- )
106 [ tuck nth-unsafe >r nth-unsafe r> ] 3keep tuck
107 >r >r set-nth-unsafe r> r> set-nth-unsafe ; inline
109 : (head) ( seq n -- from to seq ) 0 spin ; inline
111 : (tail) ( seq n -- from to seq ) over length rot ; inline
113 : from-end >r dup length r> - ; inline
116 tuck 1 swap set-nth-unsafe
117 tuck 0 swap set-nth-unsafe ; inline
120 tuck 2 swap set-nth-unsafe
124 tuck 3 swap set-nth-unsafe
129 : 2sequence ( obj1 obj2 exemplar -- seq )
130 2 swap [ (2sequence) ] new-like ; inline
132 : 3sequence ( obj1 obj2 obj3 exemplar -- seq )
133 3 swap [ (3sequence) ] new-like ; inline
135 : 4sequence ( obj1 obj2 obj3 obj4 exemplar -- seq )
136 4 swap [ (4sequence) ] new-like ; inline
138 : first2 ( seq -- first second )
139 1 swap bounds-check nip first2-unsafe ; flushable
141 : first3 ( seq -- first second third )
142 2 swap bounds-check nip first3-unsafe ; flushable
144 : first4 ( seq -- first second third fourth )
145 3 swap bounds-check nip first4-unsafe ; flushable
147 : ?nth ( n seq -- elt/f )
148 2dup bounds-check? [ nth-unsafe ] [ 2drop f ] if ; flushable
150 MIXIN: virtual-sequence
151 GENERIC: virtual-seq ( seq -- seq' )
152 GENERIC: virtual@ ( n seq -- n' seq' )
154 M: virtual-sequence nth virtual@ nth ;
155 M: virtual-sequence set-nth virtual@ set-nth ;
156 M: virtual-sequence nth-unsafe virtual@ nth-unsafe ;
157 M: virtual-sequence set-nth-unsafe virtual@ set-nth-unsafe ;
158 M: virtual-sequence like virtual-seq like ;
159 M: virtual-sequence new-sequence virtual-seq new-sequence ;
161 INSTANCE: virtual-sequence sequence
163 ! A reversal of an underlying sequence.
164 TUPLE: reversed { seq read-only } ;
166 C: <reversed> reversed
168 M: reversed virtual-seq seq>> ;
170 M: reversed virtual@ seq>> [ length swap - 1- ] keep ;
172 M: reversed length seq>> length ;
174 INSTANCE: reversed virtual-sequence
176 : reverse ( seq -- newseq ) [ <reversed> ] [ like ] bi ;
178 ! A slice of another sequence.
184 : collapse-slice ( m n slice -- m' n' seq )
185 [ from>> ] [ seq>> ] bi >r tuck + >r + r> r> ; inline
187 ERROR: slice-error reason ;
189 : check-slice ( from to seq -- from to seq )
190 pick 0 < [ "start < 0" slice-error ] when
191 dup length pick < [ "end > sequence" slice-error ] when
192 2over > [ "start > end" slice-error ] when ; inline
194 : <slice> ( from to seq -- slice )
195 dup slice? [ collapse-slice ] when
199 M: slice virtual-seq seq>> ;
201 M: slice virtual@ [ from>> + ] [ seq>> ] bi ;
203 M: slice length [ to>> ] [ from>> ] bi - ;
205 : short ( seq n -- seq n' ) over length min ; inline
207 : head-slice ( seq n -- slice ) (head) <slice> ;
209 : tail-slice ( seq n -- slice ) (tail) <slice> ;
211 : rest-slice ( seq -- slice ) 1 tail-slice ;
213 : head-slice* ( seq n -- slice ) from-end head-slice ;
215 : tail-slice* ( seq n -- slice ) from-end tail-slice ;
217 : but-last-slice ( seq -- slice ) 1 head-slice* ;
219 INSTANCE: slice virtual-sequence
221 ! One element repeated many times
222 TUPLE: repetition { len read-only } { elt read-only } ;
224 C: <repetition> repetition
226 M: repetition length len>> ;
227 M: repetition nth-unsafe nip elt>> ;
229 INSTANCE: repetition immutable-sequence
233 : ((copy)) ( dst i src j n -- dst i src j n )
235 + swap nth-unsafe -roll [
236 + swap set-nth-unsafe
240 : (copy) ( dst i src j n -- dst )
241 dup 0 <= [ 2drop 2drop ] [ 1- ((copy)) (copy) ] if ; inline
243 : prepare-subseq ( from to seq -- dst i src j n )
244 [ >r swap - r> new-sequence dup 0 ] 3keep
245 -rot drop roll length ; inline
247 : check-copy ( src n dst -- )
248 over 0 < [ bounds-error ] when
249 >r swap length + r> lengthen ; inline
253 : subseq ( from to seq -- subseq )
254 [ check-slice prepare-subseq (copy) ] [ like ] bi ;
256 : head ( seq n -- headseq ) (head) subseq ;
258 : tail ( seq n -- tailseq ) (tail) subseq ;
260 : rest ( seq -- tailseq ) 1 tail ;
262 : head* ( seq n -- headseq ) from-end head ;
264 : tail* ( seq n -- tailseq ) from-end tail ;
266 : but-last ( seq -- headseq ) 1 head* ;
268 : copy ( src i dst -- )
269 pick length >r 3dup check-copy spin 0 r>
272 M: sequence clone-like
273 >r dup length r> new-sequence [ 0 swap copy ] keep ;
275 M: immutable-sequence clone-like like ;
277 : push-all ( src dest -- ) [ length ] [ copy ] bi ;
279 : ((append)) ( seq1 seq2 accum -- accum )
280 [ >r over length r> copy ]
284 : (append) ( seq1 seq2 exemplar -- newseq )
285 >r over length over length + r>
286 [ ((append)) ] new-like ; inline
288 : (3append) ( seq1 seq2 seq3 exemplar -- newseq )
289 >r pick length pick length pick length + + r> [
290 [ >r pick length pick length + r> copy ]
294 : append ( seq1 seq2 -- newseq ) over (append) ;
296 : prepend ( seq1 seq2 -- newseq ) swap append ; inline
298 : 3append ( seq1 seq2 seq3 -- newseq ) pick (3append) ;
300 : change-nth ( i seq quot -- )
301 [ >r nth r> call ] 3keep drop set-nth ; inline
303 : min-length ( seq1 seq2 -- n ) [ length ] bi@ min ; inline
305 : max-length ( seq1 seq2 -- n ) [ length ] bi@ max ; inline
309 : (each) ( seq quot -- n quot' )
310 >r dup length swap [ nth-unsafe ] curry r> compose ; inline
312 : (collect) ( quot into -- quot' )
313 [ >r keep r> set-nth-unsafe ] 2curry ; inline
315 : collect ( n quot into -- )
316 (collect) each-integer ; inline
318 : map-into ( seq quot into -- )
319 >r (each) r> collect ; inline
321 : 2nth-unsafe ( n seq1 seq2 -- elt1 elt2 )
322 >r over r> nth-unsafe >r nth-unsafe r> ; inline
324 : (2each) ( seq1 seq2 quot -- n quot' )
325 >r [ min-length ] 2keep r>
326 [ >r 2nth-unsafe r> call ] 3curry ; inline
328 : finish-find ( i seq -- i elt )
329 over [ dupd nth-unsafe ] [ drop f ] if ; inline
331 : (find) ( seq quot quot' -- i elt )
332 pick >r >r (each) r> call r> finish-find ; inline
334 : (find-from) ( n seq quot quot' -- i elt )
335 >r >r 2dup bounds-check? [
338 r> r> 2drop 2drop f f
341 : (monotonic) ( seq quot -- ? )
342 [ 2dup nth-unsafe rot 1+ rot nth-unsafe ]
343 prepose curry ; inline
345 : (interleave) ( n elt between quot -- )
346 roll zero? [ nip ] [ swapd 2slip ] if call ; inline
350 : each ( seq quot -- )
351 (each) each-integer ; inline
353 : reduce ( seq identity quot -- result )
356 : map-as ( seq quot exemplar -- newseq )
357 >r over length r> [ [ map-into ] keep ] new-like ; inline
359 : map ( seq quot -- newseq )
362 : replicate ( seq quot -- newseq )
363 [ drop ] prepose map ; inline
365 : replicate-as ( seq quot exemplar -- newseq )
366 >r [ drop ] prepose r> map-as ; inline
368 : change-each ( seq quot -- )
369 over map-into ; inline
371 : accumulate ( seq identity quot -- final newseq )
372 swapd [ pick slip ] curry map ; inline
374 : 2each ( seq1 seq2 quot -- )
375 (2each) each-integer ; inline
377 : 2reverse-each ( seq1 seq2 quot -- )
378 >r [ <reversed> ] bi@ r> 2each ; inline
380 : 2reduce ( seq1 seq2 identity quot -- result )
381 >r -rot r> 2each ; inline
383 : 2map ( seq1 seq2 quot -- newseq )
384 pick >r (2each) over r>
385 [ [ collect ] keep ] new-like ; inline
387 : 2all? ( seq1 seq2 quot -- ? )
388 (2each) all-integers? ; inline
390 : find-from ( n seq quot -- i elt )
391 [ (find-integer) ] (find-from) ; inline
393 : find ( seq quot -- i elt )
394 [ find-integer ] (find) ; inline
396 : find-last-from ( n seq quot -- i elt )
397 [ nip find-last-integer ] (find-from) ; inline
399 : find-last ( seq quot -- i elt )
400 [ >r 1- r> find-last-integer ] (find) ; inline
402 : all? ( seq quot -- ? )
403 (each) all-integers? ; inline
405 : push-if ( elt quot accum -- )
406 >r keep r> rot [ push ] [ 2drop ] if ; inline
408 : pusher ( quot -- quot accum )
409 V{ } clone [ [ push-if ] 2curry ] keep ; inline
411 : filter ( seq quot -- subseq )
412 over >r pusher >r each r> r> like ; inline
414 : monotonic? ( seq quot -- ? )
415 >r dup length 1- swap r> (monotonic) all? ; inline
417 : interleave ( seq between quot -- )
418 [ (interleave) ] 2curry >r dup length swap r> 2each ; inline
420 : accumulator ( quot -- quot' vec )
421 V{ } clone [ [ push ] curry compose ] keep ; inline
423 : unfold ( pred quot tail -- seq )
424 swap accumulator >r swap while r> { } like ; inline
426 : follow ( obj quot -- seq )
427 >r [ dup ] r> [ keep ] curry [ ] unfold nip ; inline
429 : index ( obj seq -- n )
430 [ = ] with find drop ;
432 : index-from ( obj i seq -- n )
433 rot [ = ] curry find-from drop ;
435 : last-index ( obj seq -- n )
436 [ = ] with find-last drop ;
438 : last-index-from ( obj i seq -- n )
439 rot [ = ] curry find-last-from drop ;
441 : contains? ( seq quot -- ? )
442 find drop >boolean ; inline
444 : member? ( obj seq -- ? )
445 [ = ] with contains? ;
447 : memq? ( obj seq -- ? )
448 [ eq? ] with contains? ;
450 : remove ( obj seq -- newseq )
451 [ = not ] with filter ;
453 : sift ( seq -- newseq )
456 : harvest ( seq -- newseq )
457 [ empty? not ] filter ;
459 : cache-nth ( i seq quot -- elt )
463 drop swap >r over >r call dup r> r> set-nth
466 : mismatch ( seq1 seq2 -- i )
468 [ 2nth-unsafe = not ] 2curry
473 [ -rot 2nth-unsafe <=> ] [ [ length ] compare ] if* ;
475 : sequence= ( seq1 seq2 -- ? )
476 2dup [ length ] bi@ number=
477 [ mismatch not ] [ 2drop f ] if ; inline
479 : sequence-hashcode-step ( oldhash newpart -- newhash )
481 dup -2 fixnum-shift-fast swap 5 fixnum-shift-fast
482 fixnum+fast fixnum+fast
483 ] keep fixnum-bitxor ; inline
485 : sequence-hashcode ( n seq -- x )
487 hashcode* >fixnum sequence-hashcode-step
490 M: reversed equal? over reversed? [ sequence= ] [ 2drop f ] if ;
492 M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
494 : move ( to from seq -- )
496 [ 3drop ] [ [ nth swap ] [ set-nth ] bi ] if ; inline
498 : (delete) ( elt store scan seq -- elt store scan seq )
501 [ nth pick = ] 2keep rot
502 [ >r >r 1+ r> r> ] unless >r 1+ r> (delete)
505 : delete ( elt seq -- ) 0 0 rot (delete) nip set-length drop ;
507 : prefix ( seq elt -- newseq )
508 over >r over length 1+ r> [
509 [ 0 swap set-nth-unsafe ] keep
513 : suffix ( seq elt -- newseq )
514 over >r over length 1+ r> [
515 [ >r over length r> set-nth-unsafe ] keep
519 : peek ( seq -- elt ) [ length 1- ] [ nth ] bi ;
521 : pop* ( seq -- ) [ length 1- ] [ set-length ] bi ;
523 : move-backward ( shift from to seq -- )
527 [ >r 2over + pick r> move >r 1+ r> ] keep
531 : move-forward ( shift from to seq -- )
535 [ >r pick >r dup dup r> + swap r> move 1- ] keep
539 : (open-slice) ( shift from to seq ? -- )
541 >r [ 1- ] bi@ r> move-forward
543 >r >r over - r> r> move-backward
546 : open-slice ( shift from seq -- )
550 pick over length + over >r >r
551 pick 0 > >r [ length ] keep r> (open-slice)
555 : delete-slice ( from to seq -- )
556 check-slice >r over >r - r> r> open-slice ;
558 : delete-nth ( n seq -- )
559 >r dup 1+ r> delete-slice ;
561 : replace-slice ( new from to seq -- )
562 [ >r >r dup pick length + r> - over r> open-slice ] keep
566 [ length 1- ] [ [ nth ] [ set-length ] 2bi ] bi ;
568 : all-equal? ( seq -- ? ) [ = ] monotonic? ;
570 : all-eq? ( seq -- ? ) [ eq? ] monotonic? ;
572 : exchange ( m n seq -- )
573 pick over bounds-check 2drop 2dup bounds-check 2drop
576 : reverse-here ( seq -- )
579 tuck - 1- rot exchange-unsafe
582 : sum-lengths ( seq -- n )
583 0 [ length + ] reduce ;
585 : concat ( seq -- newseq )
590 [ first new-resizable ] keep
591 [ [ over push-all ] each ] keep
595 : joined-length ( seq glue -- n )
596 >r dup sum-lengths swap length 1 [-] r> length * + ;
598 : join ( seq glue -- newseq )
600 2dup joined-length over new-resizable spin
601 [ dup pick push-all ] [ pick push-all ] interleave drop
604 : padding ( seq n elt quot -- newseq )
605 >r >r over length [-] dup zero?
606 [ r> r> 3drop ] [ r> <repetition> r> call ] if ; inline
608 : pad-left ( seq n elt -- padded )
609 [ swap dup (append) ] padding ;
611 : pad-right ( seq n elt -- padded )
614 : shorter? ( seq1 seq2 -- ? ) >r length r> length < ;
616 : head? ( seq begin -- ? )
620 tuck length head-slice sequence=
623 : tail? ( seq end -- ? )
627 tuck length tail-slice* sequence=
630 : cut-slice ( seq n -- before after )
631 [ head-slice ] [ tail-slice ] 2bi ;
633 : midpoint@ ( seq -- n ) length 2/ ; inline
635 : halves ( seq -- first second )
636 dup midpoint@ cut-slice ;
638 : binary-reduce ( seq start quot -- value )
639 #! We can't use case here since combinators depends on
641 pick length dup 0 3 between? [
645 [ >r drop first2 r> call ]
646 [ >r drop first3 r> bi@ ]
651 [ [ binary-reduce ] 2curry bi@ ] keep
655 : cut ( seq n -- before after )
656 [ head ] [ tail ] 2bi ;
658 : cut* ( seq n -- before after )
659 [ head* ] [ tail* ] 2bi ;
663 : (start) ( subseq seq n -- subseq seq ? )
665 >r 3dup r> [ + swap nth-unsafe ] keep rot nth-unsafe =
670 : start* ( subseq seq n -- i )
671 pick length pick length swap - 1+
672 [ (start) ] find-from
675 : start ( subseq seq -- i ) 0 start* ; inline
677 : subseq? ( subseq seq -- ? ) start >boolean ;
679 : drop-prefix ( seq1 seq2 -- slice1 slice2 )
680 2dup mismatch [ 2dup min-length ] unless*
681 tuck tail-slice >r tail-slice r> ;
683 : unclip ( seq -- rest first )
684 [ rest ] [ first ] bi ;
686 : unclip-last ( seq -- butlast last )
687 [ but-last ] [ peek ] bi ;
689 : unclip-slice ( seq -- rest first )
690 [ rest-slice ] [ first ] bi ;
692 : unclip-last-slice ( seq -- butfirst last )
693 [ but-last-slice ] [ peek ] bi ;
695 : <flat-slice> ( seq -- slice )
696 dup slice? [ { } like ] when 0 over length rot <slice> ;
699 : left-trim ( seq quot -- newseq )
700 over >r [ not ] compose find drop r> swap
701 [ tail ] [ dup length tail ] if* ; inline
703 : right-trim ( seq quot -- newseq )
704 over >r [ not ] compose find-last drop r> swap
705 [ 1+ head ] [ 0 head ] if* ; inline
707 : trim ( seq quot -- newseq )
708 [ left-trim ] [ right-trim ] bi ; inline
710 : sum ( seq -- n ) 0 [ + ] binary-reduce ;
711 : product ( seq -- n ) 1 [ * ] binary-reduce ;
713 : infimum ( seq -- n ) dup first [ min ] reduce ;
714 : supremum ( seq -- n ) dup first [ max ] reduce ;
716 : flip ( matrix -- newmatrix )
718 dup [ length ] map infimum
719 swap [ [ nth-unsafe ] with { } map-as ] curry { } map-as
722 : sigma ( seq quot -- n ) [ + ] compose 0 swap reduce ; inline
724 : count ( seq quot -- n ) [ 1 0 ? ] compose sigma ; inline