ERROR: bounds-error index seq ;
-GENERIC# bounds-check? 1 ( n seq -- ? )
+GENERIC#: bounds-check? 1 ( n seq -- ? )
-M: integer bounds-check? ( n seq -- ? )
+M: integer bounds-check?
dupd length < [ 0 >= ] [ drop f ] if ; inline
: bounds-check ( n seq -- n seq )
M: sequence set-nth-unsafe set-nth ; inline
: change-nth-unsafe ( i seq quot -- )
- [ [ nth-unsafe ] dip call ] 3keep drop set-nth-unsafe ; inline
+ [ [ nth-unsafe ] dip call ] 2keepd set-nth-unsafe ; inline
PRIVATE>
INSTANCE: f immutable-sequence
! Integer sequences
-TUPLE: iota-tuple { n integer read-only } ;
+TUPLE: iota { n integer read-only } ;
ERROR: non-negative-integer-expected n ;
-: iota ( n -- iota )
+: <iota> ( n -- iota )
dup 0 < [ non-negative-integer-expected ] when
- iota-tuple boa ; inline
+ iota boa ; inline
-M: iota-tuple length n>> ; inline
-M: iota-tuple nth-unsafe drop ; inline
+M: iota length n>> ; inline
+M: iota nth-unsafe drop ; inline
-INSTANCE: iota-tuple immutable-sequence
+INSTANCE: iota immutable-sequence
<PRIVATE
{ to integer read-only }
{ seq read-only } ;
+: >slice< ( slice -- from to seq )
+ [ from>> ] [ to>> ] [ seq>> ] tri ; inline
+
: collapse-slice ( m n slice -- m' n' seq )
[ from>> ] [ seq>> ] bi [ [ + ] curry bi@ ] dip ; inline
: check-length ( n -- n )
dup integer? [ integer-length-expected ] unless ; inline
-TUPLE: copy-state
- { src-i read-only }
+: >sequence< ( seq -- i n seq )
+ [ drop 0 ] [ length check-length ] [ ] tri ; inline
+
+: length-sequence ( seq -- n seq )
+ [ length check-length ] [ ] bi ; inline
+
+: >underlying< ( slice/seq -- i n slice/seq )
+ dup slice? [ >slice< ] [ >sequence< ] if ; inline
+
+TUPLE: copier
+ { src-i integer read-only }
{ src read-only }
- { dst-i read-only }
+ { dst-i integer read-only }
{ dst read-only } ;
-C: <copy> copy-state
+C: <copier> copier
: copy-nth-unsafe ( n copy -- )
[ [ src-i>> + ] [ src>> ] bi nth-unsafe ]
: subseq>copy ( from to seq -- n copy )
[ over - check-length swap ] dip
- 3dup nip new-sequence 0 swap <copy> ; inline
+ 3dup nip new-sequence 0 swap <copier> ; inline
: bounds-check-head ( n seq -- n seq )
over 0 < [ bounds-error ] when ; inline
[ swap length + ] dip lengthen ; inline
: copy-unsafe ( src i dst -- )
- [ [ length check-length 0 ] keep ] 2dip <copy> (copy) drop ; inline
+ [ [ length check-length 0 ] keep ] 2dip <copier> (copy) drop ; inline
: subseq-unsafe-as ( from to seq exemplar -- subseq )
- [ subseq>copy (copy) ] dip like ;
+ [ subseq>copy (copy) ] dip like ; inline
: subseq-unsafe ( from to seq -- subseq )
dup subseq-unsafe-as ; inline
[ check-slice ] dip subseq-unsafe-as ;
: subseq ( from to seq -- subseq )
- dup subseq-as ; inline
+ dup subseq-as ;
: head ( seq n -- headseq ) (head) subseq ;
[ 2dup [ length ] bi@ + ] dip
[ (append) ] new-like ; inline
+: append ( seq1 seq2 -- newseq ) over append-as ;
+
+: prepend-as ( seq1 seq2 exemplar -- newseq ) swapd append-as ; inline
+
+: prepend ( seq1 seq2 -- newseq ) over prepend-as ;
+
: 3append-as ( seq1 seq2 seq3 exemplar -- newseq )
[ 3dup [ length ] tri@ + + ] dip [
[ [ 2over [ length ] bi@ + ] dip copy-unsafe ]
[ (append) ] bi
] new-like ; inline
-: append ( seq1 seq2 -- newseq ) over append-as ;
+: 3append ( seq1 seq2 seq3 -- newseq ) pick 3append-as ;
-: prepend-as ( seq1 seq2 exemplar -- newseq ) swapd append-as ; inline
+: surround-as ( seq1 seq2 seq3 exemplar -- newseq )
+ [ swap ] 2dip 3append-as ; inline
-: prepend ( seq1 seq2 -- newseq ) over prepend-as ;
+: surround ( seq1 seq2 seq3 -- newseq ) over surround-as ; inline
-: 3append ( seq1 seq2 seq3 -- newseq ) pick 3append-as ;
+: 1surround-as ( seq1 seq2 exemplar -- newseq ) dupd surround-as ; inline
+
+: 1surround ( seq1 seq2 -- newseq ) dup 1surround-as ; inline
-: surround ( seq1 seq2 seq3 -- newseq ) swapd 3append ; inline
+: glue-as ( seq1 seq2 seq3 exemplar -- newseq ) swapd 3append-as ; inline
-: glue ( seq1 seq2 seq3 -- newseq ) swap 3append ; inline
+: glue ( seq1 seq2 seq3 -- newseq ) pick glue-as ; inline
: change-nth ( ..a i seq quot: ( ..a elt -- ..b newelt ) -- ..b )
- [ [ nth ] dip call ] 3keep drop set-nth-unsafe ; inline
+ [ [ nth ] dip call ] 2keepd set-nth-unsafe ; inline
: min-length ( seq1 seq2 -- n ) [ length ] bi@ min ; inline
<PRIVATE
-: (setup-each) ( seq -- n quot )
- [ length check-length ] keep [ nth-unsafe ] curry ; inline
+: sequence-operator ( seq quot -- i n quot' )
+ [ >underlying< [ nth-unsafe ] curry ] dip compose ; inline
-: setup-each ( seq quot -- n quot' )
- [ (setup-each) ] dip compose ; inline
+: length-iterator ( seq quot -- n quot' )
+ length-sequence [ nth-unsafe ] curry ; inline
-: (each-index) ( seq quot -- n quot' )
- [ (setup-each) [ keep ] curry ] dip compose ; inline
+: length-operator ( seq quot -- n quot' )
+ [ length-iterator ] dip compose ; inline
-: (collect) ( quot into -- quot' )
- [ [ keep ] dip set-nth-unsafe ] 2curry ; inline
+: sequence-operator-from ( seq quot i -- i n quot' )
+ -rot length-operator ; inline
: collect ( n quot into -- )
- (collect) each-integer ; inline
+ [ [ keep ] dip set-nth-unsafe ] 2curry each-integer ; inline
+
+: sequence-index-iterator ( seq quot -- n quot' )
+ [ length-iterator [ keep ] curry ] dip compose ; inline
: map-into ( seq quot into -- )
- [ setup-each ] dip collect ; inline
+ [ length-operator ] dip collect ; inline
: 2nth-unsafe ( n seq1 seq2 -- elt1 elt2 )
[ nth-unsafe ] bi-curry@ bi ; inline
: 3nth-unsafe ( n seq1 seq2 seq3 -- elt1 elt2 elt3 )
[ nth-unsafe ] tri-curry@ tri ; inline
+: setup-3each ( seq1 seq2 seq3 -- n quot )
+ [ [ length ] tri@ min min check-length ]
+ [ [ 3nth-unsafe ] 3curry ] 3bi ; inline
+
: (3each) ( seq1 seq2 seq3 quot -- n quot' )
- [
- [ [ length ] tri@ min min check-length ]
- [ [ 3nth-unsafe ] 3curry ] 3bi
- ] dip compose ; inline
+ [ setup-3each ] dip compose ; inline
: finish-find ( i seq -- i elt )
over [ dupd nth-unsafe ] [ drop f ] if ; inline
: (find) ( seq quot quot' -- i elt )
- pick [ [ setup-each ] dip call ] dip finish-find ; inline
+ pick [ [ length-operator ] dip call ] dip finish-find ; inline
: (find-from) ( n seq quot quot' -- i elt )
[ 2dup bounds-check? ] 2dip
- [ (find) ] 2curry
- [ 2drop f f ]
- if ; inline
+ '[ _ _ (find) ] [ 2drop f f ] if ; inline
: (find-index) ( seq quot quot' -- i elt )
- pick [ [ (each-index) ] dip call ] dip finish-find ; inline
+ pick [ [ sequence-index-iterator ] dip call ] dip finish-find ; inline
: (find-index-from) ( n seq quot quot' -- i elt )
[ 2dup bounds-check? ] 2dip
- [ (find-index) ] 2curry
- [ 2drop f f ]
- if ; inline
+ '[ _ _ (find-index) ] [ 2drop f f ] if ; inline
: (accumulate) ( seq identity quot -- identity seq quot )
- swapd [ curry keep ] curry ; inline
+ swapd [ keepd ] curry ; inline
: (accumulate*) ( seq identity quot -- identity seq quot )
swapd [ dup ] compose ; inline
PRIVATE>
: each ( ... seq quot: ( ... x -- ... ) -- ... )
- setup-each each-integer ; inline
+ sequence-operator each-integer-from ; inline
: each-from ( ... seq quot: ( ... x -- ... ) i -- ... )
- -rot setup-each (each-integer) ; inline
+ sequence-operator-from each-integer-from ; inline
: reduce ( ... seq identity quot: ( ... prev elt -- ... next ) -- ... result )
swapd each ; inline
: map-integers ( ... len quot: ( ... i -- ... elt ) exemplar -- ... newseq )
- [ over ] dip [ [ collect ] keep ] new-like ; inline
+ overd [ [ collect ] keep ] new-like ; inline
: map-as ( ... seq quot: ( ... elt -- ... newelt ) exemplar -- ... newseq )
- [ setup-each ] dip map-integers ; inline
+ [ length-operator ] dip map-integers ; inline
: map ( ... seq quot: ( ... elt -- ... newelt ) -- ... newseq )
over map-as ; inline
(2each) each-integer ; inline
: 2each-from ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... ) i -- ... )
- [ (2each) ] dip -rot (each-integer) ; inline
+ [ (2each) ] dip -rot each-integer-from ; inline
: 2reduce ( ... seq1 seq2 identity quot: ( ... prev elt1 elt2 -- ... next ) -- ... result )
- [ -rot ] dip 2each ; inline
+ -rotd 2each ; inline
: 2map-as ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... newelt ) exemplar -- ... newseq )
[ (2each) ] dip map-integers ; inline
: 2all? ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... ? ) -- ... ? )
(2each) all-integers? ; inline
+: 2any? ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... ? ) -- ... ? )
+ [ not ] compose 2all? not ; inline
+
: 3each ( ... seq1 seq2 seq3 quot: ( ... elt1 elt2 elt3 -- ... ) -- ... )
(3each) each-integer ; inline
[ (3each) ] dip map-integers ; inline
: 3map ( ... seq1 seq2 seq3 quot: ( ... elt1 elt2 elt3 -- ... newelt ) -- ... newseq )
- [ pick ] dip swap 3map-as ; inline
+ pickd swap 3map-as ; inline
: find-from ( ... n seq quot: ( ... elt -- ... ? ) -- ... i elt )
- [ (find-integer) ] (find-from) ; inline
+ [ find-integer-from ] (find-from) ; inline
: find ( ... seq quot: ( ... elt -- ... ? ) -- ... i elt )
[ find-integer ] (find) ; inline
[ [ 1 - ] dip find-last-integer ] (find) ; inline
: find-index-from ( ... n seq quot: ( ... elt i -- ... ? ) -- ... i elt )
- [ (find-integer) ] (find-index-from) ; inline
+ [ find-integer-from ] (find-index-from) ; inline
: find-index ( ... seq quot: ( ... elt i -- ... ? ) -- ... i elt )
[ find-integer ] (find-index) ; inline
: all? ( ... seq quot: ( ... elt -- ... ? ) -- ... ? )
- setup-each all-integers? ; inline
+ sequence-operator all-integers-from? ; inline
: push-if ( ..a elt quot: ( ..a elt -- ..b ? ) accum -- ..b )
[ keep ] dip rot [ push ] [ 2drop ] if ; inline
[ dup ] swap [ keep ] curry produce nip ; inline
: each-index ( ... seq quot: ( ... elt index -- ... ) -- ... )
- (each-index) each-integer ; inline
+ sequence-index-iterator each-integer ; inline
: map-index-as ( ... seq quot: ( ... elt index -- ... newelt ) exemplar -- ... newseq )
- [ dup length iota ] 2dip 2map-as ; inline
+ [ dup length <iota> ] 2dip 2map-as ; inline
: map-index ( ... seq quot: ( ... elt index -- ... newelt ) -- ... newseq )
- { } map-index-as ; inline
+ over map-index-as ; inline
: interleave ( ... seq between quot: ( ... elt -- ... ) -- ... )
pick empty? [ 3drop ] [
: any? ( ... seq quot: ( ... elt -- ... ? ) -- ... ? )
find drop >boolean ; inline
+: none? ( ... seq quot: ( ... elt -- ... ? ) -- ... ? )
+ any? not ; inline
+
: member? ( elt seq -- ? )
[ = ] with any? ;
+: member-of? ( seq elt -- ? )
+ [ = ] curry any? ;
+
: member-eq? ( elt seq -- ? )
[ eq? ] with any? ;
+: member-eq-of? ( seq elt -- ? )
+ [ eq? ] curry any? ;
+
: remove ( elt seq -- newseq )
[ = ] with reject ;
+: remove-of ( seq elt -- newseq )
+ [ = ] curry reject ;
+
: remove-eq ( elt seq -- newseq )
[ eq? ] with reject ;
+: remove-eq-of ( seq elt -- newseq )
+ [ eq? ] curry reject ;
+
: sift ( seq -- newseq )
[ ] filter ;
PRIVATE>
: mismatch ( seq1 seq2 -- i )
- [ min-length ] 2keep mismatch-unsafe ; inline
+ [ min-length ] 2keep mismatch-unsafe ;
M: sequence <=>
[ mismatch ] 2keep pick
: assert-sequence= ( a b -- )
2dup sequence= [ 2drop ] [ assert-sequence ] if ;
+M: reversed equal? over reversed? [ sequence= ] [ 2drop f ] if ;
+
+M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
+
<PRIVATE
: sequence-hashcode-step ( oldhash newpart -- newhash )
: sequence-hashcode ( n seq -- x )
[ 0 ] 2dip [ hashcode* sequence-hashcode-step ] with each ; inline
-M: reversed equal? over reversed? [ sequence= ] [ 2drop f ] if ;
+M: sequence hashcode* [ sequence-hashcode ] recursive-hashcode ;
-M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
+M: iota hashcode*
+ over 0 <= [ 2drop 0 ] [
+ nip length 0 swap [ sequence-hashcode-step ] each-integer
+ ] if ;
+
+M: reversed hashcode* [ sequence-hashcode ] recursive-hashcode ;
+
+M: slice hashcode* [ sequence-hashcode ] recursive-hashcode ;
: move ( to from seq -- )
2over =
: (filter!) ( ... quot: ( ... elt -- ... ? ) store scan seq -- ... )
2dup length < [
[ move-unsafe ] 3keep
- [ nth-unsafe pick call [ 1 + ] when ] 2keep
+ [ nth-unsafe -rot [ [ call ] keep ] dip rot [ 1 + ] when ] 2keep
[ 1 + ] dip
(filter!)
] [ nip set-length drop ] if ; inline recursive
2over = [
4drop
] [
- [ [ pick [ dup dup ] dip + swap ] dip move-unsafe 1 - ] keep
+ [ [ [ ] [ nip + ] [ 2nip ] 3tri ] dip move-unsafe 1 - ] keep
move-forward
] if ;
pick 0 = [
3drop
] [
- pick over length + over
+ [ ] [ nip length + ] [ 2nip ] 3tri
[ pick 0 > [ [ length ] keep ] dip (open-slice) ] 2dip
set-length
] if ;
: join ( seq glue -- newseq )
dup join-as ; inline
+<PRIVATE
+
: padding ( ... seq n elt quot: ( ... seq1 seq2 -- ... newseq ) -- ... newseq )
[
[ over length [-] dup 0 = [ drop ] ] dip
[ <repetition> ] curry
] dip compose if ; inline
+PRIVATE>
+
: pad-head ( seq n elt -- padded )
[ swap dup append-as ] padding ;
: cut-slice ( seq n -- before-slice after-slice )
[ head-slice ] [ tail-slice ] 2bi ; inline
+: cut-slice* ( seq n -- before-slice after-slice )
+ [ head-slice* ] [ tail-slice* ] 2bi ;
+
: insert-nth ( elt n seq -- seq' )
swap cut-slice [ swap suffix ] dip append ;
PRIVATE>
: binary-reduce ( seq start quot: ( elt1 elt2 -- newelt ) -- value )
- pick length 0 max 0 swap (binary-reduce) ; inline
+ pick dup slice? [
+ [ seq>> ] 3dip [ from>> 0 max ] [ to>> 0 max over - ] bi
+ ] [
+ length 0 max 0 swap
+ ] if (binary-reduce) ; inline
: cut ( seq n -- before after )
[ head ] [ tail ] 2bi ;
: cut* ( seq n -- before after )
[ head* ] [ tail* ] 2bi ;
-<PRIVATE
+: subseq-starts-at? ( i seq subseq -- ? )
+ [ length swap ] keep
+ '[
+ [ + _ nth-unsafe ] keep _ nth-unsafe =
+ ] with all-integers? ; inline
-: (start) ( subseq seq n length -- subseq seq ? )
- [
- [ 3dup ] dip [ + swap nth-unsafe ] keep rot nth-unsafe =
- ] all-integers? nip ; inline
+: find-subseq-from ( n seq subseq -- i/f )
+ [ [ length ] bi@ - 1 + ] 2keep
+ '[ _ _ subseq-starts-at? ] find-integer-from ; inline
-PRIVATE>
+: subseq-start-from ( subseq seq n -- i/f ) spin find-subseq-from ; inline
-: start* ( subseq seq n -- i )
- pick length [ pick length swap - 1 + ] keep
- [ (start) ] curry (find-integer) 2nip ;
+: find-subseq ( seq subseq -- i/f ) [ 0 ] 2dip find-subseq-from ; inline
-: start ( subseq seq -- i ) 0 start* ; inline
+: find-subseq? ( seq subseq -- ? ) find-subseq >boolean ; inline
-: subseq? ( subseq seq -- ? ) start >boolean ;
+: subseq-start ( subseq seq -- i/f ) swap find-subseq ; inline
+
+: subseq? ( subseq seq -- ? ) subseq-start >boolean ; inline
: drop-prefix ( seq1 seq2 -- slice1 slice2 )
2dup mismatch [ 2dup min-length ] unless*
: unclip-slice ( seq -- rest-slice first )
[ rest-slice ] [ first-unsafe ] bi ; inline
-: map-reduce ( ..a seq map-quot: ( ..a elt -- ..b intermediate ) reduce-quot: ( ..b prev intermediate -- ..a next ) -- ..a result )
- [ [ dup first ] dip [ call ] keep ] dip compose
- swapd 1 each-from ; inline
+: map-reduce ( ..a seq map-quot: ( ..a elt -- ..a intermediate ) reduce-quot: ( ..a prev intermediate -- ..a next ) -- ..a result )
+ [ [ [ first ] keep ] dip [ dip ] keep ] dip
+ '[ swap _ dip swap @ ] 1 each-from ; inline
-: 2map-reduce ( ..a seq1 seq2 map-quot: ( ..a elt1 elt2 -- ..b intermediate ) reduce-quot: ( ..b prev intermediate -- ..a next ) -- ..a result )
- [ [ 2dup [ first ] bi@ ] dip [ call ] keep ] dip compose
- [ -rot ] dip 1 2each-from ; inline
+: 2map-reduce ( ..a seq1 seq2 map-quot: ( ..a elt1 elt2 -- ..a intermediate ) reduce-quot: ( ..a prev intermediate -- ..a next ) -- ..a result )
+ [ [ [ [ first ] bi@ ] 2keep ] dip [ 2dip ] keep ] dip
+ '[ rot _ dip swap @ ] 1 2each-from ; inline
<PRIVATE
: (map-find) ( seq quot find-quot -- result elt )
- [ [ f ] 2dip [ [ nip ] dip call dup ] curry ] dip call
- [ [ drop f ] unless ] dip ; inline
+ [ [ f ] 2dip [ nip ] prepose [ dup ] compose ] dip call nip ; inline
PRIVATE>
GENERIC: sum ( seq -- n )
M: object sum 0 [ + ] binary-reduce ; inline
-M: iota-tuple sum length dup 1 - * 2/ ; inline
+M: iota sum length dup 1 - * 2/ ; inline
M: repetition sum [ elt>> ] [ length>> ] bi * ; inline
: product ( seq -- n ) 1 [ * ] binary-reduce ;
[ with each ] 2curry each ; inline
: cartesian-map ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... newelt ) -- ... newseq )
- [ with map ] 2curry map ; inline
+ [ with { } map-as ] 2curry { } map-as ; inline
+
+: cartesian-product-as ( seq1 seq2 exemplar -- newseq )
+ [ 2sequence ] curry cartesian-map ; inline
: cartesian-product ( seq1 seq2 -- newseq )
- [ { } 2sequence ] cartesian-map ;
+ dup cartesian-product-as ; inline
+
+: cartesian-find ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... ? ) -- ... elt1 elt2 )
+ [ f ] 3dip [ with find swap ] 2curry [ nip ] prepose find nip swap ; inline
<PRIVATE
[ keep swap ] curry [ [ first ] dip call ] 2keep
[ curry 2dip pick over ] curry
] [
- [ [ 2drop ] [ [ 2drop ] 2dip ] if ] compose
+ [ [ 2drop ] [ 2nipd ] if ] compose
] bi* compose 1 each-from drop ; inline
PRIVATE>
<PRIVATE
: generic-flip ( matrix -- newmatrix )
- [
- [ first-unsafe length 1 ] keep
- [ length min ] setup-each (each-integer) iota
- ] keep
- [ [ nth-unsafe ] with { } map-as ] curry { } map-as ; inline
+ [ [ length ] [ min ] map-reduce ] keep
+ '[ _ [ nth-unsafe ] with { } map-as ] { } map-integers ; inline
USE: arrays
-: array-length ( array -- len )
- { array } declare length>> ; inline
-
: array-flip ( matrix -- newmatrix )
{ array } declare
- [
- [ first-unsafe array-length 1 ] keep
- [ array-length min ] setup-each (each-integer) iota
- ] keep
- [ [ { array } declare array-nth ] with { } map-as ] curry { } map-as ;
+ [ [ { array } declare length>> ] [ min ] map-reduce ] keep
+ '[ _ [ { array } declare array-nth ] with { } map-as ] { } map-integers ;
PRIVATE>
projects / factor.git / blobdiff