1 ! Copyright (C) 2005, 2008 Slava Pestov, Daniel Ehrenberg.
2 ! See http://factorcode.org/license.txt for BSD license.
4 USING: kernel kernel.private slots.private math math.private ;
8 GENERIC: length ( seq -- n ) flushable
9 GENERIC: set-length ( n seq -- )
10 GENERIC: nth ( n seq -- elt ) flushable
11 GENERIC: set-nth ( elt n seq -- )
12 GENERIC: new-sequence ( len seq -- newseq ) flushable
13 GENERIC: new-resizable ( len seq -- newseq ) flushable
14 GENERIC: like ( seq exemplar -- newseq ) flushable
15 GENERIC: clone-like ( seq exemplar -- newseq ) flushable
17 : new-like ( len exemplar quot -- seq )
18 over >r >r new-sequence r> call r> like ; inline
20 M: sequence like drop ;
22 GENERIC: lengthen ( n seq -- )
24 M: sequence lengthen 2dup length > [ set-length ] [ 2drop ] if ;
26 : empty? ( seq -- ? ) length zero? ; inline
27 : delete-all ( seq -- ) 0 swap set-length ;
29 : first ( seq -- first ) 0 swap nth ; inline
30 : second ( seq -- second ) 1 swap nth ; inline
31 : third ( seq -- third ) 2 swap nth ; inline
32 : fourth ( seq -- fourth ) 3 swap nth ; inline
34 : set-first ( first seq -- ) 0 swap set-nth ; inline
35 : set-second ( second seq -- ) 1 swap set-nth ; inline
36 : set-third ( third seq -- ) 2 swap set-nth ; inline
37 : set-fourth ( fourth seq -- ) 3 swap set-nth ; inline
39 : push ( elt seq -- ) dup length swap set-nth ;
41 : bounds-check? ( n seq -- ? )
42 length 1- 0 swap between? ; inline
44 ERROR: bounds-error index seq ;
46 : bounds-check ( n seq -- n seq )
47 2dup bounds-check? [ bounds-error ] unless ; inline
49 MIXIN: immutable-sequence
51 ERROR: immutable seq ;
53 M: immutable-sequence set-nth immutable ;
55 INSTANCE: immutable-sequence sequence
59 : max-array-capacity ( -- n )
60 #! A bit of a pain; can't call cell-bits here
61 7 getenv 8 * 5 - 2^ 1- ; foldable
63 PREDICATE: array-capacity < fixnum
64 0 max-array-capacity between? ;
66 : array-capacity ( array -- n )
67 1 slot { array-capacity } declare ; inline
69 : array-nth ( n array -- elt )
70 swap 2 fixnum+fast slot ; inline
72 : set-array-nth ( elt n array -- )
73 swap 2 fixnum+fast set-slot ; inline
75 : dispatch ( n array -- ) array-nth (call) ;
77 GENERIC: resize ( n seq -- newseq ) flushable
79 ! Unsafe sequence protocol for inner loops
80 GENERIC: nth-unsafe ( n seq -- elt ) flushable
81 GENERIC: set-nth-unsafe ( elt n seq -- )
83 M: sequence nth bounds-check nth-unsafe ;
84 M: sequence set-nth bounds-check set-nth-unsafe ;
86 M: sequence nth-unsafe nth ;
87 M: sequence set-nth-unsafe set-nth ;
89 ! The f object supports the sequence protocol trivially
92 M: f like drop dup empty? [ drop f ] when ;
94 INSTANCE: f immutable-sequence
96 ! Integers support the sequence protocol
98 M: integer nth-unsafe drop ;
100 INSTANCE: integer immutable-sequence
103 [ 0 swap nth-unsafe ] keep 1 swap nth-unsafe ; inline
106 [ first2-unsafe ] keep 2 swap nth-unsafe ; inline
109 [ first3-unsafe ] keep 3 swap nth-unsafe ; inline
111 : exchange-unsafe ( m n seq -- )
112 [ tuck nth-unsafe >r nth-unsafe r> ] 3keep tuck
113 >r >r set-nth-unsafe r> r> set-nth-unsafe ; inline
115 : (head) ( seq n -- from to seq ) 0 spin ; inline
117 : (tail) ( seq n -- from to seq ) over length rot ; inline
119 : from-end >r dup length r> - ; inline
122 tuck 1 swap set-nth-unsafe
123 tuck 0 swap set-nth-unsafe ; inline
126 tuck 2 swap set-nth-unsafe
130 tuck 3 swap set-nth-unsafe
135 : 2sequence ( obj1 obj2 exemplar -- seq )
136 2 swap [ (2sequence) ] new-like ; inline
138 : 3sequence ( obj1 obj2 obj3 exemplar -- seq )
139 3 swap [ (3sequence) ] new-like ; inline
141 : 4sequence ( obj1 obj2 obj3 obj4 exemplar -- seq )
142 4 swap [ (4sequence) ] new-like ; inline
144 : first2 ( seq -- first second )
145 1 swap bounds-check nip first2-unsafe ; flushable
147 : first3 ( seq -- first second third )
148 2 swap bounds-check nip first3-unsafe ; flushable
150 : first4 ( seq -- first second third fourth )
151 3 swap bounds-check nip first4-unsafe ; flushable
153 : ?nth ( n seq -- elt/f )
154 2dup bounds-check? [ nth-unsafe ] [ 2drop f ] if ; flushable
156 MIXIN: virtual-sequence
157 GENERIC: virtual-seq ( seq -- seq' )
158 GENERIC: virtual@ ( n seq -- n' seq' )
160 M: virtual-sequence nth virtual@ nth ;
161 M: virtual-sequence set-nth virtual@ set-nth ;
162 M: virtual-sequence nth-unsafe virtual@ nth-unsafe ;
163 M: virtual-sequence set-nth-unsafe virtual@ set-nth-unsafe ;
164 M: virtual-sequence like virtual-seq like ;
165 M: virtual-sequence new-sequence virtual-seq new-sequence ;
167 INSTANCE: virtual-sequence sequence
169 ! A reversal of an underlying sequence.
170 TUPLE: reversed seq ;
172 C: <reversed> reversed
174 M: reversed virtual-seq reversed-seq ;
176 M: reversed virtual@ reversed-seq [ length swap - 1- ] keep ;
178 M: reversed length reversed-seq length ;
180 INSTANCE: reversed virtual-sequence
182 : reverse ( seq -- newseq ) [ <reversed> ] keep like ;
184 ! A slice of another sequence.
185 TUPLE: slice from to seq ;
187 : collapse-slice ( m n slice -- m' n' seq )
188 dup slice-from swap slice-seq >r tuck + >r + r> r> ; inline
190 ERROR: slice-error reason ;
192 : check-slice ( from to seq -- from to seq )
193 pick 0 < [ "start < 0" slice-error ] when
194 dup length pick < [ "end > sequence" slice-error ] when
195 2over > [ "start > end" slice-error ] when ; inline
197 : <slice> ( from to seq -- slice )
198 dup slice? [ collapse-slice ] when
202 M: slice virtual-seq slice-seq ;
204 M: slice virtual@ [ slice-from + ] keep slice-seq ;
206 M: slice length dup slice-to swap slice-from - ;
208 : head-slice ( seq n -- slice ) (head) <slice> ;
210 : tail-slice ( seq n -- slice ) (tail) <slice> ;
212 : head-slice* ( seq n -- slice ) from-end head-slice ;
214 : tail-slice* ( seq n -- slice ) from-end tail-slice ;
216 INSTANCE: slice virtual-sequence
218 ! A column of a matrix
219 TUPLE: column seq col ;
223 M: column virtual-seq column-seq ;
225 dup column-col -rot column-seq nth bounds-check ;
226 M: column length column-seq length ;
228 INSTANCE: column virtual-sequence
230 ! One element repeated many times
231 TUPLE: repetition len elt ;
233 C: <repetition> repetition
235 M: repetition length repetition-len ;
236 M: repetition nth-unsafe nip repetition-elt ;
238 INSTANCE: repetition immutable-sequence
242 : ((copy)) ( dst i src j n -- dst i src j n )
244 + swap nth-unsafe -roll [
245 + swap set-nth-unsafe
249 : (copy) ( dst i src j n -- dst )
250 dup 0 <= [ 2drop 2drop ] [ 1- ((copy)) (copy) ] if ; inline
252 : prepare-subseq ( from to seq -- dst i src j n )
253 [ >r swap - r> new-sequence dup 0 ] 3keep
254 -rot drop roll length ; inline
256 : check-copy ( src n dst -- )
257 over 0 < [ bounds-error ] when
258 >r swap length + r> lengthen ; inline
262 : subseq ( from to seq -- subseq )
263 [ check-slice prepare-subseq (copy) ] keep like ;
265 : head ( seq n -- headseq ) (head) subseq ;
267 : tail ( seq n -- tailseq ) (tail) subseq ;
269 : head* ( seq n -- headseq ) from-end head ;
271 : tail* ( seq n -- tailseq ) from-end tail ;
273 : copy ( src i dst -- )
274 pick length >r 3dup check-copy spin 0 r>
277 M: sequence clone-like
278 >r dup length r> new-sequence [ 0 swap copy ] keep ;
280 M: immutable-sequence clone-like like ;
282 : push-all ( src dest -- ) [ length ] keep copy ;
284 : ((append)) ( seq1 seq2 accum -- accum )
285 [ >r over length r> copy ] keep
286 [ 0 swap copy ] keep ; inline
288 : (append) ( seq1 seq2 exemplar -- newseq )
289 >r over length over length + r>
290 [ ((append)) ] new-like ; inline
292 : (3append) ( seq1 seq2 seq3 exemplar -- newseq )
293 >r pick length pick length pick length + + r> [
294 [ >r pick length pick length + r> copy ] keep
298 : append ( seq1 seq2 -- newseq ) over (append) ;
300 : prepend ( seq1 seq2 -- newseq ) swap append ; inline
302 : 3append ( seq1 seq2 seq3 -- newseq ) pick (3append) ;
304 : change-nth ( i seq quot -- )
305 [ >r nth r> call ] 3keep drop set-nth ; inline
307 : min-length ( seq1 seq2 -- n ) [ length ] bi@ min ; inline
309 : max-length ( seq1 seq2 -- n ) [ length ] bi@ max ; inline
313 : (each) ( seq quot -- n quot' )
314 >r dup length swap [ nth-unsafe ] curry r> compose ; inline
316 : (collect) ( quot into -- quot' )
317 [ >r keep r> set-nth-unsafe ] 2curry ; inline
319 : collect ( n quot into -- )
320 (collect) each-integer ; inline
322 : map-into ( seq quot into -- )
323 >r (each) r> collect ; inline
325 : 2nth-unsafe ( n seq1 seq2 -- elt1 elt2 )
326 >r over r> nth-unsafe >r nth-unsafe r> ; inline
328 : (2each) ( seq1 seq2 quot -- n quot' )
329 >r [ min-length ] 2keep r>
330 [ >r 2nth-unsafe r> call ] 3curry ; inline
332 : finish-find ( i seq -- i elt )
333 over [ dupd nth-unsafe ] [ drop f ] if ; inline
335 : (find) ( seq quot quot' -- i elt )
336 pick >r >r (each) r> call r> finish-find ; inline
338 : (find*) ( n seq quot quot' -- i elt )
339 >r >r 2dup bounds-check? [
342 r> r> 2drop 2drop f f
345 : (monotonic) ( seq quot -- ? )
346 [ 2dup nth-unsafe rot 1+ rot nth-unsafe ]
347 swap compose curry ; inline
349 : (interleave) ( n elt between quot -- )
350 roll zero? [ nip ] [ swapd 2slip ] if call ; inline
354 : each ( seq quot -- )
355 (each) each-integer ; inline
357 : reduce ( seq identity quot -- result )
360 : map-as ( seq quot exemplar -- newseq )
361 >r over length r> [ [ map-into ] keep ] new-like ; inline
363 : map ( seq quot -- newseq )
366 : change-each ( seq quot -- )
367 over map-into ; inline
369 : accumulate ( seq identity quot -- final newseq )
370 swapd [ pick slip ] curry map ; inline
372 : 2each ( seq1 seq2 quot -- )
373 (2each) each-integer ; inline
375 : 2reverse-each ( seq1 seq2 quot -- )
376 >r [ <reversed> ] bi@ r> 2each ; inline
378 : 2reduce ( seq1 seq2 identity quot -- result )
379 >r -rot r> 2each ; inline
381 : 2map ( seq1 seq2 quot -- newseq )
382 pick >r (2each) over r>
383 [ [ collect ] keep ] new-like ; inline
385 : 2all? ( seq1 seq2 quot -- ? )
386 (2each) all-integers? ; inline
388 : find* ( n seq quot -- i elt )
389 [ (find-integer) ] (find*) ; inline
391 : find ( seq quot -- i elt )
392 [ find-integer ] (find) ; inline
394 : find-last* ( n seq quot -- i elt )
395 [ nip find-last-integer ] (find*) ; inline
397 : find-last ( seq quot -- i elt )
398 [ >r 1- r> find-last-integer ] (find) ; inline
400 : all? ( seq quot -- ? )
401 (each) all-integers? ; inline
403 : push-if ( elt quot accum -- )
404 >r keep r> rot [ push ] [ 2drop ] if ; inline
406 : pusher ( quot -- quot accum )
407 V{ } clone [ [ push-if ] 2curry ] keep ; inline
409 : subset ( seq quot -- subseq )
410 over >r pusher >r each r> r> like ; inline
412 : monotonic? ( seq quot -- ? )
413 >r dup length 1- swap r> (monotonic) all? ; inline
415 : interleave ( seq between quot -- )
416 [ (interleave) ] 2curry >r dup length swap r> 2each ; inline
418 : unfold ( pred quot tail -- seq )
420 swap >r [ push ] curry compose r> while
421 ] keep { } like ; inline
423 : follow ( obj quot -- seq )
424 >r [ dup ] r> [ keep ] curry [ ] unfold nip ; inline
426 : index ( obj seq -- n )
427 [ = ] with find drop ;
429 : index* ( obj i seq -- n )
430 rot [ = ] curry find* drop ;
432 : last-index ( obj seq -- n )
433 [ = ] with find-last drop ;
435 : last-index* ( obj i seq -- n )
436 rot [ = ] curry find-last* drop ;
438 : contains? ( seq quot -- ? )
439 find drop >boolean ; inline
441 : member? ( obj seq -- ? )
442 [ = ] with contains? ;
444 : memq? ( obj seq -- ? )
445 [ eq? ] with contains? ;
447 : remove ( obj seq -- newseq )
448 [ = not ] with subset ;
450 : cache-nth ( i seq quot -- elt )
454 drop swap >r over >r call dup r> r> set-nth
457 : mismatch ( seq1 seq2 -- i )
459 [ 2nth-unsafe = not ] 2curry
464 [ -rot 2nth-unsafe <=> ] [ [ length ] compare ] if* ;
466 : sequence= ( seq1 seq2 -- ? )
467 2dup [ length ] bi@ number=
468 [ mismatch not ] [ 2drop f ] if ; inline
470 : sequence-hashcode-step ( oldhash newpart -- newhash )
472 dup -2 fixnum-shift-fast swap 5 fixnum-shift-fast
473 fixnum+fast fixnum+fast
474 ] keep fixnum-bitxor ; inline
476 : sequence-hashcode ( n seq -- x )
478 hashcode* >fixnum sequence-hashcode-step
481 M: reversed equal? over reversed? [ sequence= ] [ 2drop f ] if ;
483 M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
485 : move ( to from seq -- )
487 [ 3drop ] [ [ nth swap ] keep set-nth ] if ; inline
489 : (delete) ( elt store scan seq -- elt store scan seq )
492 [ nth pick = ] 2keep rot
493 [ >r >r 1+ r> r> ] unless >r 1+ r> (delete)
496 : delete ( elt seq -- ) 0 0 rot (delete) nip set-length drop ;
498 : push-new ( elt seq -- ) [ delete ] 2keep push ;
500 : prefix ( seq elt -- newseq )
501 over >r over length 1+ r> [
502 [ 0 swap set-nth-unsafe ] keep
506 : suffix ( seq elt -- newseq )
507 over >r over length 1+ r> [
508 [ >r over length r> set-nth-unsafe ] keep
512 : peek ( seq -- elt ) dup length 1- swap nth ;
514 : pop* ( seq -- ) dup length 1- swap set-length ;
516 : move-backward ( shift from to seq -- )
520 [ >r 2over + pick r> move >r 1+ r> ] keep
524 : move-forward ( shift from to seq -- )
528 [ >r pick >r dup dup r> + swap r> move 1- ] keep
532 : (open-slice) ( shift from to seq ? -- )
534 >r >r 1- r> 1- r> move-forward
536 >r >r over - r> r> move-backward
539 : open-slice ( shift from seq -- )
543 pick over length + over >r >r
544 pick 0 > >r [ length ] keep r> (open-slice)
548 : delete-slice ( from to seq -- )
549 check-slice >r over >r - r> r> open-slice ;
551 : delete-nth ( n seq -- )
552 >r dup 1+ r> delete-slice ;
554 : replace-slice ( new from to seq -- )
555 [ >r >r dup pick length + r> - over r> open-slice ] keep
559 dup length 1- swap [ nth ] 2keep set-length ;
561 : all-equal? ( seq -- ? ) [ = ] monotonic? ;
563 : all-eq? ( seq -- ? ) [ eq? ] monotonic? ;
565 : exchange ( m n seq -- )
566 pick over bounds-check 2drop 2dup bounds-check 2drop
569 : reverse-here ( seq -- )
572 tuck - 1- rot exchange-unsafe
575 : sum-lengths ( seq -- n )
576 0 [ length + ] reduce ;
578 : concat ( seq -- newseq )
583 [ first new-resizable ] keep
584 [ [ over push-all ] each ] keep
588 : joined-length ( seq glue -- n )
589 >r dup sum-lengths swap length 1 [-] r> length * + ;
591 : join ( seq glue -- newseq )
593 2dup joined-length over new-resizable spin
594 [ dup pick push-all ] [ pick push-all ] interleave drop
597 : padding ( seq n elt quot -- newseq )
598 >r >r over length [-] dup zero?
599 [ r> r> 3drop ] [ r> <repetition> r> call ] if ; inline
601 : pad-left ( seq n elt -- padded )
602 [ swap dup (append) ] padding ;
604 : pad-right ( seq n elt -- padded )
607 : shorter? ( seq1 seq2 -- ? ) >r length r> length < ;
609 : head? ( seq begin -- ? )
613 tuck length head-slice sequence=
616 : tail? ( seq end -- ? )
620 tuck length tail-slice* sequence=
623 : cut-slice ( seq n -- before after )
624 [ head-slice ] 2keep tail-slice ;
626 : midpoint@ ( seq -- n ) length 2/ ; inline
628 : halves ( seq -- first second )
629 dup midpoint@ cut-slice ;
631 : binary-reduce ( seq start quot -- value )
632 #! We can't use case here since combinators depends on
634 pick length dup 0 3 between? [
638 [ >r drop first2 r> call ]
639 [ >r drop first3 r> bi@ ]
644 [ [ binary-reduce ] 2curry bi@ ] keep
648 : cut ( seq n -- before after )
649 [ head ] 2keep tail ;
651 : cut* ( seq n -- before after )
652 [ head* ] 2keep tail* ;
656 : (start) ( subseq seq n -- subseq seq ? )
658 >r 3dup r> [ + swap nth-unsafe ] keep rot nth-unsafe =
663 : start* ( subseq seq n -- i )
664 pick length pick length swap - 1+
668 : start ( subseq seq -- i ) 0 start* ; inline
670 : subseq? ( subseq seq -- ? ) start >boolean ;
672 : drop-prefix ( seq1 seq2 -- slice1 slice2 )
673 2dup mismatch [ 2dup min-length ] unless*
674 tuck tail-slice >r tail-slice r> ;
676 : unclip ( seq -- rest first )
677 dup 1 tail swap first ;
679 : unclip-slice ( seq -- rest first )
680 dup 1 tail-slice swap first ;
682 : <flat-slice> ( seq -- slice )
683 dup slice? [ { } like ] when 0 over length rot <slice> ;
686 : left-trim ( seq quot -- newseq )
687 over >r [ not ] compose find drop r> swap
688 [ tail ] [ dup length tail ] if* ; inline
690 : right-trim ( seq quot -- newseq )
691 over >r [ not ] compose find-last drop r> swap
692 [ 1+ head ] [ 0 head ] if* ; inline
694 : trim ( seq quot -- newseq )
695 [ left-trim ] keep right-trim ; inline
697 : sum ( seq -- n ) 0 [ + ] binary-reduce ;
698 : product ( seq -- n ) 1 [ * ] binary-reduce ;
700 : infimum ( seq -- n ) dup first [ min ] reduce ;
701 : supremum ( seq -- n ) dup first [ max ] reduce ;
703 : flip ( matrix -- newmatrix )
705 dup [ length ] map infimum
706 [ <column> dup like ] with map