1 ! Copyright (C) 2005, 2007 Slava Pestov.
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 ( 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 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 TUPLE: bounds-error index seq ;
46 : bounds-error ( n seq -- * )
47 \ bounds-error construct-boa throw ;
49 : bounds-check ( n seq -- n seq )
50 2dup bounds-check? [ bounds-error ] unless ; inline
52 MIXIN: immutable-sequence
54 TUPLE: immutable seq ;
56 : immutable ( seq -- * ) \ immutable construct-boa throw ;
58 M: immutable-sequence set-nth immutable ;
60 INSTANCE: immutable-sequence sequence
64 : max-array-capacity ( -- n )
65 #! A bit of a pain; can't call cell-bits here
66 7 getenv 8 * 5 - 2^ 1- ; foldable
68 PREDICATE: fixnum array-capacity
69 0 max-array-capacity between? ;
71 : array-capacity ( array -- n )
72 1 slot { array-capacity } declare ; inline
74 : array-nth ( n array -- elt )
75 swap 2 fixnum+fast slot ; inline
77 : set-array-nth ( elt n array -- )
78 swap 2 fixnum+fast set-slot ; inline
80 GENERIC: resize ( n seq -- newseq ) flushable
82 ! Unsafe sequence protocol for inner loops
83 GENERIC: nth-unsafe ( n seq -- elt ) flushable
84 GENERIC: set-nth-unsafe ( elt n seq -- )
86 M: sequence nth bounds-check nth-unsafe ;
87 M: sequence set-nth bounds-check set-nth-unsafe ;
89 M: sequence nth-unsafe nth ;
90 M: sequence set-nth-unsafe set-nth ;
92 ! The f object supports the sequence protocol trivially
95 M: f like drop dup empty? [ drop f ] when ;
97 INSTANCE: f immutable-sequence
99 ! Integers support the sequence protocol
101 M: integer nth-unsafe drop ;
103 INSTANCE: integer immutable-sequence
106 [ 0 swap nth-unsafe ] keep 1 swap nth-unsafe ; inline
109 [ first2-unsafe ] keep 2 swap nth-unsafe ; inline
112 [ first3-unsafe ] keep 3 swap nth-unsafe ; inline
114 : exchange-unsafe ( m n seq -- )
115 [ tuck nth-unsafe >r nth-unsafe r> ] 3keep tuck
116 >r >r set-nth-unsafe r> r> set-nth-unsafe ; inline
118 : (head) ( seq n -- from to seq ) 0 spin ; inline
120 : (tail) ( seq n -- from to seq ) over length rot ; inline
122 : from-end >r dup length r> - ; inline
125 tuck 1 swap set-nth-unsafe
126 tuck 0 swap set-nth-unsafe ; inline
129 tuck 2 swap set-nth-unsafe
133 tuck 3 swap set-nth-unsafe
138 : 2sequence ( obj1 obj2 exemplar -- seq )
139 2 swap [ (2sequence) ] new-like ; inline
141 : 3sequence ( obj1 obj2 obj3 exemplar -- seq )
142 3 swap [ (3sequence) ] new-like ; inline
144 : 4sequence ( obj1 obj2 obj3 obj4 exemplar -- seq )
145 4 swap [ (4sequence) ] new-like ; inline
147 : first2 ( seq -- first second )
148 1 swap bounds-check nip first2-unsafe ; flushable
150 : first3 ( seq -- first second third )
151 2 swap bounds-check nip first3-unsafe ; flushable
153 : first4 ( seq -- first second third fourth )
154 3 swap bounds-check nip first4-unsafe ; flushable
156 : ?nth ( n seq -- elt/f )
157 2dup bounds-check? [ nth-unsafe ] [ 2drop f ] if ; flushable
159 MIXIN: virtual-sequence
160 GENERIC: virtual-seq ( seq -- seq' )
161 GENERIC: virtual@ ( n seq -- n' seq' )
163 M: virtual-sequence nth virtual@ nth ;
164 M: virtual-sequence set-nth virtual@ set-nth ;
165 M: virtual-sequence nth-unsafe virtual@ nth-unsafe ;
166 M: virtual-sequence set-nth-unsafe virtual@ set-nth-unsafe ;
167 M: virtual-sequence like virtual-seq like ;
168 M: virtual-sequence new virtual-seq new ;
170 INSTANCE: virtual-sequence sequence
172 ! A reversal of an underlying sequence.
173 TUPLE: reversed seq ;
175 C: <reversed> reversed
177 M: reversed virtual-seq reversed-seq ;
178 M: reversed virtual@ reversed-seq [ length swap - 1- ] keep ;
179 M: reversed length reversed-seq length ;
181 INSTANCE: reversed virtual-sequence
183 : reverse ( seq -- newseq ) [ <reversed> ] keep like ;
185 ! A slice of another sequence.
186 TUPLE: slice from to seq ;
188 : collapse-slice ( m n slice -- m' n' seq )
189 dup slice-from swap slice-seq >r tuck + >r + r> r> ; inline
191 TUPLE: slice-error reason ;
192 : slice-error ( str -- * ) \ slice-error construct-boa throw ;
194 : check-slice ( from to seq -- from to seq )
195 pick 0 < [ "start < 0" slice-error ] when
196 dup length pick < [ "end > sequence" slice-error ] when
197 pick pick > [ "start > end" slice-error ] when ; inline
199 : <slice> ( from to seq -- slice )
200 dup slice? [ collapse-slice ] when
202 slice construct-boa ;
204 M: slice virtual-seq slice-seq ;
205 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 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 ;
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 [ 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 : 3append ( seq1 seq2 seq3 -- newseq ) pick (3append) ;
302 : change-nth ( i seq quot -- )
303 [ >r nth r> call ] 3keep drop set-nth ; inline
305 : min-length ( seq1 seq2 -- n ) [ length ] 2apply min ; inline
307 : max-length ( seq1 seq2 -- n ) [ length ] 2apply max ; inline
311 : iterate-seq >r dup length swap r> ; inline
313 : (each) ( seq quot -- n quot' )
314 iterate-seq [ >r nth-unsafe r> call ] 2curry ; inline
316 : (collect) ( quot into -- quot' )
317 [ >r over slip 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> ] 2apply 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 iterate-seq 2each ; inline
418 : unfold ( pred quot tail -- seq )
420 swap >r [ push ] curry compose r> while
421 ] keep { } like ; inline
423 : index ( obj seq -- n )
424 [ = ] curry* find drop ;
426 : index* ( obj i seq -- n )
427 rot [ = ] curry find* drop ;
429 : last-index ( obj seq -- n )
430 [ = ] curry* find-last drop ;
432 : last-index* ( obj i seq -- n )
433 rot [ = ] curry find-last* drop ;
435 : contains? ( seq quot -- ? )
436 find drop >boolean ; inline
438 : member? ( obj seq -- ? )
439 [ = ] curry* contains? ;
441 : memq? ( obj seq -- ? )
442 [ eq? ] curry* contains? ;
444 : remove ( obj seq -- newseq )
445 [ = not ] curry* subset ;
447 : cache-nth ( i seq quot -- elt )
451 drop swap >r over >r call dup r> r> set-nth
454 : mismatch ( seq1 seq2 -- i )
456 [ 2nth-unsafe = not ] 2curry
461 [ -rot 2nth-unsafe <=> ] [ [ length ] compare ] if* ;
463 : sequence= ( seq1 seq2 -- ? )
464 2dup [ length ] 2apply number=
465 [ mismatch not ] [ 2drop f ] if ; inline
467 : move ( to from seq -- )
469 [ 3drop ] [ [ nth swap ] keep set-nth ] if ; inline
471 : (delete) ( elt store scan seq -- elt store scan seq )
474 [ nth pick = ] 2keep rot
475 [ >r >r 1+ r> r> ] unless >r 1+ r> (delete)
478 : delete ( elt seq -- ) 0 0 rot (delete) nip set-length drop ;
480 : push-new ( elt seq -- ) [ delete ] 2keep push ;
482 : add ( seq elt -- newseq )
483 over >r over length 1+ r> [
484 [ >r over length r> set-nth-unsafe ] keep
488 : add* ( seq elt -- newseq )
489 over >r over length 1+ r> [
490 [ 0 swap set-nth-unsafe ] keep
494 : seq-diff ( seq1 seq2 -- newseq )
495 swap [ member? not ] curry subset ;
497 : peek ( seq -- elt ) dup length 1- swap nth ;
499 : pop* ( seq -- ) dup length 1- swap set-length ;
501 : move-backward ( shift from to seq -- )
505 [ >r pick pick + pick r> move >r 1+ r> ] keep
509 : move-forward ( shift from to seq -- )
513 [ >r pick >r dup dup r> + swap r> move 1- ] keep
517 : (open-slice) ( shift from to seq ? -- )
519 >r >r 1- r> 1- r> move-forward
521 >r >r over - r> r> move-backward
524 : open-slice ( shift from seq -- )
528 pick over length + over >r >r
529 pick 0 > >r [ length ] keep r> (open-slice)
533 : delete-slice ( from to seq -- )
534 check-slice >r over >r - r> r> open-slice ;
536 : delete-nth ( n seq -- )
537 >r dup 1+ r> delete-slice ;
539 : replace-slice ( new from to seq -- )
540 [ >r >r dup pick length + r> - over r> open-slice ] keep
544 dup length 1- swap [ nth ] 2keep set-length ;
546 : all-equal? ( seq -- ? ) [ = ] monotonic? ;
548 : all-eq? ( seq -- ? ) [ eq? ] monotonic? ;
550 : exchange ( m n seq -- )
551 pick over bounds-check 2drop 2dup bounds-check 2drop
554 : reverse-here ( seq -- )
557 tuck - 1- rot exchange-unsafe
560 : sum-lengths ( seq -- n )
561 0 [ length + ] reduce ;
563 : concat ( seq -- newseq )
568 [ first new-resizable ] keep
569 [ [ over push-all ] each ] keep
573 : joined-length ( seq glue -- n )
574 >r dup sum-lengths swap length 1 [-] r> length * + ;
576 : join ( seq glue -- newseq )
578 2dup joined-length over new-resizable spin
579 [ dup pick push-all ] [ pick push-all ] interleave drop
582 : padding ( seq n elt quot -- newseq )
583 >r >r over length [-] dup zero?
584 [ r> r> 3drop ] [ r> <repetition> r> call ] if ; inline
586 : pad-left ( seq n elt -- padded )
587 [ swap dup (append) ] padding ;
589 : pad-right ( seq n elt -- padded )
592 : shorter? ( seq1 seq2 -- ? ) >r length r> length < ;
594 : head? ( seq begin -- ? )
598 tuck length head-slice sequence=
601 : tail? ( seq end -- ? )
605 tuck length tail-slice* sequence=
608 : cut-slice ( seq n -- before after )
609 [ head ] 2keep tail-slice ;
611 : cut ( seq n -- before after )
612 [ head ] 2keep tail ;
614 : cut* ( seq n -- before after )
615 [ head* ] 2keep tail* ;
619 : (start) ( subseq seq n -- subseq seq ? )
621 >r 3dup r> [ + swap nth-unsafe ] keep rot nth-unsafe =
626 : start* ( subseq seq n -- i )
627 pick length pick length swap - 1+
631 : start ( subseq seq -- i ) 0 start* ; inline
633 : subseq? ( subseq seq -- ? ) start >boolean ;
635 : drop-prefix ( seq1 seq2 -- slice1 slice2 )
636 2dup mismatch [ 2dup min-length ] unless*
637 tuck tail-slice >r tail-slice r> ;
639 : unclip ( seq -- rest first )
640 dup 1 tail swap first ;
642 : unclip-slice ( seq -- rest first )
643 dup 1 tail-slice swap first ;
645 : <flat-slice> ( seq -- slice )
646 dup slice? [ { } like ] when 0 over length rot <slice> ;
649 : left-trim ( seq quot -- newseq )
650 over >r [ not ] compose find drop r> swap
651 [ tail ] [ dup length tail ] if* ; inline
653 : right-trim ( seq quot -- newseq )
654 over >r [ not ] compose find-last drop r> swap
655 [ 1+ head ] [ 0 head ] if* ; inline
657 : trim ( seq quot -- newseq )
658 [ left-trim ] keep right-trim ; inline
660 : sum ( seq -- n ) 0 [ + ] reduce ;
661 : product ( seq -- n ) 1 [ * ] reduce ;
663 : infimum ( seq -- n ) dup first [ min ] reduce ;
664 : supremum ( seq -- n ) dup first [ max ] reduce ;
666 : flip ( matrix -- newmatrix )
668 dup [ length ] map infimum
669 [ <column> dup like ] curry* map
672 : sequence-hashcode-step ( oldhash newpart -- newhash )
674 dup -2 fixnum-shift >fixnum swap 5 fixnum-shift >fixnum
675 fixnum+fast fixnum+fast
676 ] keep bitxor ; inline
678 : sequence-hashcode ( n seq -- x )
680 hashcode* >fixnum sequence-hashcode-step
681 ] curry* each ; inline