[ [ nth-unsafe ] curry bi@ ]
[ [ set-nth-unsafe ] curry bi@ ] 3bi ; inline
-: (head) ( seq n -- from to seq ) [ 0 ] 2dip swap ; inline
-
-: (tail) ( seq n -- from to seq ) swap [ length ] keep ; inline
-
-: from-end ( seq n -- seq n' ) [ dup length ] dip - ; inline
-
: (1sequence) ( obj seq -- seq )
[ 0 swap set-nth-unsafe ] keep ; inline
PRIVATE>
+: head-to-index ( seq to -- zero to seq ) [ 0 ] 2dip swap ; inline
+
+: index-to-tail ( seq from -- from length seq ) swap [ length ] keep ; inline
+
+: from-tail ( seq n -- seq n' ) [ dup length ] dip - ; inline
+
: 1sequence ( obj exemplar -- seq )
1 swap [ (1sequence) ] new-like ; inline
: ?set-nth ( elt n seq -- )
2dup bounds-check? [ set-nth-unsafe ] [ 3drop ] if ; inline
+: maybe-nth ( i/f seq -- elt/f )
+ over [ nth ] [ 2drop f ] if ; inline
+
: ?first ( seq -- elt/f ) 0 swap ?nth ; inline
: ?second ( seq -- elt/f ) 1 swap ?nth ; inline
: ?last ( seq -- elt/f )
{ 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
M: slice length [ to>> ] [ from>> ] bi - ; inline
-: short ( seq n -- seq n' ) over length min ; inline
+: bound ( seq n -- seq n' ) over length min ; inline
-: head-slice ( seq n -- slice ) (head) <slice> ; inline
+: head-slice ( seq n -- slice ) head-to-index <slice> ; inline
-: tail-slice ( seq n -- slice ) (tail) <slice> ; inline
+: tail-slice ( seq n -- slice ) index-to-tail <slice> ; inline
: rest-slice ( seq -- slice ) 1 tail-slice ; inline
-: head-slice* ( seq n -- slice ) from-end head-slice ; inline
+: head-slice* ( seq n -- slice ) from-tail head-slice ; inline
-: tail-slice* ( seq n -- slice ) from-end tail-slice ; inline
+: tail-slice* ( seq n -- slice ) from-tail tail-slice ; inline
: but-last-slice ( seq -- slice ) 1 head-slice* ; inline
: check-length ( n -- n )
dup integer? [ integer-length-expected ] unless ; inline
-TUPLE: copy-state
+: >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 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 ;
+: head ( seq n -- headseq ) head-to-index subseq ;
-: tail ( seq n -- tailseq ) (tail) subseq ;
+: tail ( seq n -- tailseq ) index-to-tail subseq ;
: rest ( seq -- tailseq ) 1 tail ;
-: head* ( seq n -- headseq ) from-end head ;
+: head* ( seq n -- headseq ) from-tail head ;
-: tail* ( seq n -- tailseq ) from-end tail ;
+: tail* ( seq n -- tailseq ) from-tail tail ;
: but-last ( seq -- headseq ) 1 head* ;
: surround ( seq1 seq2 seq3 -- newseq ) over surround-as ; inline
+: 1surround-as ( seq1 seq2 exemplar -- newseq ) dupd surround-as ; inline
+
+: 1surround ( seq1 seq2 -- newseq ) dup 1surround-as ; inline
+
: glue-as ( seq1 seq2 seq3 exemplar -- newseq ) swapd 3append-as ; inline
: glue ( seq1 seq2 seq3 -- newseq ) pick glue-as ; 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
+
+: length-iterator ( seq -- n quot' )
+ length-sequence [ nth-unsafe ] curry ; inline
-: (each) ( seq quot -- n quot' )
- [ setup-each ] dip compose ; inline
+: length-operator ( seq quot -- n quot' )
+ [ length-iterator ] dip compose ; inline
-: (each-index) ( seq quot -- n quot' )
- [ setup-each [ keep ] curry ] dip compose ; inline
+: length-operator-last ( seq quot -- n quot' )
+ length-operator [ 1 - ] dip ; 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
+
+: sequence-operator-last-from ( seq quot i -- n quot' )
+ -rot length-operator-last nip ; inline
: collect ( n quot into -- )
- (collect) each-integer ; inline
+ [ [ keep ] dip set-nth-unsafe ] 2curry each-integer ; inline
+
+: sequence-index-operator ( seq quot -- n quot' )
+ [ length-iterator [ keep ] curry ] dip compose ; inline
: map-into ( seq quot into -- )
- [ (each) ] dip collect ; inline
+ [ length-operator ] dip collect ; inline
: 2nth-unsafe ( n seq1 seq2 -- elt1 elt2 )
[ nth-unsafe ] bi-curry@ bi ; inline
: (3each) ( seq1 seq2 seq3 quot -- n quot' )
[ 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 [ [ (each) ] 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
+: element/index ( i/f seq -- elt/f i/f )
+ [ maybe-nth ] [ drop ] 2bi ; inline
-: (find-index) ( seq quot quot' -- i elt )
- pick [ [ (each-index) ] dip call ] dip finish-find ; inline
+: index/element ( i/f seq -- elt/f i/f )
+ [ drop ] [ maybe-nth ] 2bi ; inline
-: (find-index-from) ( n seq quot quot' -- i elt )
- [ 2dup bounds-check? ] 2dip
- [ (find-index) ] 2curry
- [ 2drop f f ]
- if ; inline
-
-: (accumulate) ( seq identity quot -- identity seq quot )
+: (accumulate) ( seq identity quot -- identity seq quot' )
swapd [ keepd ] curry ; inline
-: (accumulate*) ( seq identity quot -- identity seq quot )
+: (accumulate*) ( seq identity quot -- identity seq quot' )
swapd [ dup ] compose ; inline
PRIVATE>
: each ( ... seq quot: ( ... x -- ... ) -- ... )
- (each) each-integer ; inline
+ sequence-operator each-integer-from ; inline
: each-from ( ... seq quot: ( ... x -- ... ) i -- ... )
- -rot (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 )
+: map-integers-as ( ... len quot: ( ... i -- ... elt ) exemplar -- ... newseq )
overd [ [ collect ] keep ] new-like ; inline
+: map-integers ( ... len quot: ( ... i -- ... elt ) -- ... newseq )
+ { } map-integers-as ; inline
+
: map-as ( ... seq quot: ( ... elt -- ... newelt ) exemplar -- ... newseq )
- [ (each) ] dip map-integers ; inline
+ [ length-operator ] dip map-integers-as ; inline
: map ( ... seq quot: ( ... elt -- ... newelt ) -- ... newseq )
over map-as ; inline
: replicate-as ( ... len quot: ( ... -- ... newelt ) exemplar -- ... newseq )
- [ [ drop ] prepose ] dip map-integers ; inline
+ [ [ drop ] prepose ] dip map-integers-as ; inline
: replicate ( ... len quot: ( ... -- ... newelt ) -- ... newseq )
{ } replicate-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 )
-rotd 2each ; inline
: 2map-as ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... newelt ) exemplar -- ... newseq )
- [ (2each) ] dip map-integers ; inline
+ [ (2each) ] dip map-integers-as ; inline
: 2map ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... newelt ) -- ... newseq )
pick 2map-as ; inline
: 2all? ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... ? ) -- ... ? )
(2each) all-integers? ; inline
+: 2any? ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... ? ) -- ... ? )
+ negate 2all? not ; inline
+
: 3each ( ... seq1 seq2 seq3 quot: ( ... elt1 elt2 elt3 -- ... ) -- ... )
(3each) each-integer ; inline
: 3map-as ( ... seq1 seq2 seq3 quot: ( ... elt1 elt2 elt3 -- ... newelt ) exemplar -- ... newseq )
- [ (3each) ] dip map-integers ; inline
+ [ (3each) ] dip map-integers-as ; inline
: 3map ( ... seq1 seq2 seq3 quot: ( ... elt1 elt2 elt3 -- ... newelt ) -- ... newseq )
pickd swap 3map-as ; inline
+: bounds-check-find ( n seq quot -- elt i )
+ 2over bounds-check? [ call ] [ 3drop f f ] if ; inline
+
: find-from ( ... n seq quot: ( ... elt -- ... ? ) -- ... i elt )
- [ (find-integer) ] (find-from) ; inline
+ '[
+ _ [ rot sequence-operator-from find-integer-from ] keepd
+ index/element
+ ] bounds-check-find ; inline
: find ( ... seq quot: ( ... elt -- ... ? ) -- ... i elt )
- [ find-integer ] (find) ; inline
+ [ 0 ] 2dip find-from ; inline
: find-last-from ( ... n seq quot: ( ... elt -- ... ? ) -- ... i elt )
- [ nip find-last-integer ] (find-from) ; inline
+ '[
+ _ [ rot sequence-operator-last-from find-last-integer ] keepd
+ index/element
+ ] bounds-check-find ; inline
: find-last ( ... seq quot: ( ... elt -- ... ? ) -- ... i elt )
- [ [ 1 - ] dip find-last-integer ] (find) ; inline
+ [ [ length 1 - ] keep ] dip find-last-from ; inline
: find-index-from ( ... n seq quot: ( ... elt i -- ... ? ) -- ... i elt )
- [ (find-integer) ] (find-index-from) ; inline
+ '[
+ _ [ sequence-index-operator find-integer-from ] keepd
+ index/element
+ ] bounds-check-find ; inline
: find-index ( ... seq quot: ( ... elt i -- ... ? ) -- ... i elt )
- [ find-integer ] (find-index) ; inline
+ [ 0 ] 2dip find-index-from ; inline
: all? ( ... seq quot: ( ... elt -- ... ? ) -- ... ? )
- (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
over filter-as ; inline
: reject-as ( ... seq quot: ( ... elt -- ... ? ) exemplar -- ... subseq )
- [ [ not ] compose ] [ filter-as ] bi* ; inline
+ [ negate ] [ filter-as ] bi* ; inline
: reject ( ... seq quot: ( ... elt -- ... ? ) -- ... subseq )
over reject-as ; inline
[ dup ] swap [ keep ] curry produce nip ; inline
: each-index ( ... seq quot: ( ... elt index -- ... ) -- ... )
- (each-index) each-integer ; inline
+ sequence-index-operator each-integer ; inline
: map-index-as ( ... seq quot: ( ... elt index -- ... newelt ) exemplar -- ... newseq )
[ 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 ] [
: 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
swap [ [ 0 0 ] dip (filter!) ] keep ; inline
: reject! ( ... seq quot: ( ... elt -- ... ? ) -- ... seq )
- [ not ] compose filter! ; inline
+ negate filter! ; inline
: remove! ( elt seq -- seq )
[ = ] with reject! ;
: 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
-: (subseq-start-from) ( 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
-: subseq-start-from ( subseq seq n -- i )
- pick length [ pick length swap - 1 + ] keep
- [ (subseq-start-from) ] curry (find-integer) 2nip ;
+: find-subseq ( seq subseq -- i/f ) [ 0 ] 2dip find-subseq-from ; inline
-: subseq-start ( subseq seq -- i ) 0 subseq-start-from ; inline
+: find-subseq? ( seq subseq -- ? ) find-subseq >boolean ; inline
-: subseq? ( subseq seq -- ? ) subseq-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 )
- [ [ [ first ] keep ] dip [ dip ] keep ] dip compose 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 )
- [ [ [ [ first ] bi@ ] 2keep ] dip [ 2dip ] keep ] dip compose 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
<PRIVATE
: (trim-head) ( seq quot -- seq n )
- over [ [ not ] compose find drop ] dip swap
+ over [ negate find drop ] dip swap
[ dup length ] unless* ; inline
: (trim-tail) ( seq quot -- seq n )
- over [ [ not ] compose find-last drop ?1+ ] dip
+ over [ negate find-last drop ?1+ ] dip
swap ; inline
PRIVATE>
<PRIVATE
: generic-flip ( matrix -- newmatrix )
- [
- [ first-unsafe length 1 ] keep
- [ length min ] (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 ] (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>