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 )
[ [ 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
+: index-or-length ( seq n -- seq n' ) over length min ; inline
+
+: index-of-last ( seq -- n seq ) [ length 1 - ] keep ; inline
+
: ?first ( seq -- elt/f ) 0 swap ?nth ; inline
: ?second ( seq -- elt/f ) 1 swap ?nth ; inline
: ?last ( seq -- elt/f )
- [ length 1 - ] keep over 0 <
+ index-of-last over 0 <
[ 2drop f ] [ nth-unsafe ] if ; inline
MIXIN: virtual-sequence
{ 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
+: head-slice ( seq n -- slice ) head-to-index <slice> ; inline
-: head-slice ( seq n -- slice ) (head) <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
- { 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 ;
+: 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* ;
[ 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 ] 2keepd set-nth-unsafe ; 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
-: (each) ( seq quot -- n quot' )
- [ setup-each ] dip compose ; inline
+: length-iterator ( seq -- 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' )
+: length-operator-last ( seq quot -- n quot' )
+ length-operator [ 1 - ] dip ; inline
+
+: collect-into ( quot into -- quot' )
[ [ keep ] dip set-nth-unsafe ] 2curry ; inline
+: collect-from ( i n quot into -- )
+ collect-into each-integer-from ; inline
+
: collect ( n quot into -- )
- (collect) each-integer ; inline
+ collect-into 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
-
-: (find-index) ( seq quot quot' -- i elt )
- pick [ [ (each-index) ] dip call ] dip finish-find ; inline
+: element/index ( i/f seq -- elt/f i/f )
+ '[ [ _ nth ] [ f ] if* ] keep ;
-: (find-index-from) ( n seq quot quot' -- i elt )
- [ 2dup bounds-check? ] 2dip
- [ (find-index) ] 2curry
- [ 2drop f f ]
- if ; inline
+: index/element ( i/f seq -- i/f elt/f )
+ dupd '[ _ nth ] [ f ] if* ;
-: (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
+ -rot length-operator 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-from-as ( ... from len quot: ( ... i -- ... elt ) exemplar -- ... newseq )
+ overd [ [ collect-from ] keep ] new-like ; inline
+
+: 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
+<PRIVATE
+
+: bounds-check-call ( n seq quot -- elt i )
+ 2over bounds-check? [ call ] [ 3drop f f ] if ; inline
+
+: find-from-unsafe ( ... n seq quot: ( ... elt -- ... ? ) -- ... i elt )
+ [ length-operator find-integer-from ] keepd
+ index/element ; inline
+
+: find-last-from-unsafe ( ... n seq quot: ( ... elt -- ... ? ) -- ... i elt )
+ [ length-operator-last nip find-last-integer ] keepd
+ index/element ; inline
+
+PRIVATE>
+
: find-from ( ... n seq quot: ( ... elt -- ... ? ) -- ... i elt )
- [ (find-integer) ] (find-from) ; inline
+ '[ _ find-from-unsafe ] bounds-check-call ; inline
: find ( ... seq quot: ( ... elt -- ... ? ) -- ... i elt )
- [ find-integer ] (find) ; inline
+ [ 0 ] 2dip find-from-unsafe ; inline
: find-last-from ( ... n seq quot: ( ... elt -- ... ? ) -- ... i elt )
- [ nip find-last-integer ] (find-from) ; inline
+ '[ _ find-last-from-unsafe ] bounds-check-call ; inline
: find-last ( ... seq quot: ( ... elt -- ... ? ) -- ... i elt )
- [ [ 1 - ] dip find-last-integer ] (find) ; inline
+ [ index-of-last ] 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-call ; 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 ] [
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 =
<PRIVATE
+: move-unsafe* ( to from seq -- from-nth )
+ 2over =
+ [ nth-unsafe nip ]
+ [ [ nth-unsafe tuck swap ] [ set-nth-unsafe ] bi ] if ; inline
+
+: filter-from! ( store from seq quot: ( ... elt -- ... ? ) -- seq )
+ 2over length < [
+ [ [ move-unsafe* ] dip call ] 4keep
+ [ swap [ 1 + ] when ] 3dip
+ [ 1 + ] 2dip filter-from!
+ ] [ drop [ nip set-length ] keep ] if ; inline recursive
+
: move-unsafe ( to from seq -- )
2over =
[ 3drop ] [ [ nth-unsafe swap ] [ set-nth-unsafe ] bi ] if ; inline
-: (filter!) ( ... quot: ( ... elt -- ... ? ) store scan seq -- ... )
- 2dup length < [
- [ move-unsafe ] 3keep
- [ nth-unsafe -rot [ [ call ] keep ] dip rot [ 1 + ] when ] 2keep
- [ 1 + ] dip
- (filter!)
- ] [ nip set-length drop ] if ; inline recursive
-
PRIVATE>
: filter! ( ... seq quot: ( ... elt -- ... ? ) -- ... seq )
- swap [ [ 0 0 ] dip (filter!) ] keep ; inline
+ [ 0 0 ] 2dip filter-from! ; inline
: reject! ( ... seq quot: ( ... elt -- ... ? ) -- ... seq )
- [ not ] compose filter! ; inline
+ negate filter! ; inline
: remove! ( elt seq -- seq )
[ = ] with reject! ;
: append! ( seq1 seq2 -- seq1 ) over push-all ; inline
: last ( seq -- elt )
- [ length 1 - ] keep
+ index-of-last
over 0 < [ bounds-error ] [ nth-unsafe ] if ; inline
<PRIVATE
: last-unsafe ( seq -- elt )
- [ length 1 - ] [ nth-unsafe ] bi ; inline
+ index-of-last nth-unsafe ; inline
PRIVATE>
: set-last ( elt seq -- )
- [ length 1 - ] keep
+ index-of-last
over 0 < [ bounds-error ] [ set-nth-unsafe ] if ; inline
-: pop* ( seq -- ) [ length 1 - ] [ shorten ] bi ;
+: pop* ( seq -- ) index-of-last shorten ;
<PRIVATE
[ [ dup 1 + ] dip snip-slice ] keep append-as ;
: pop ( seq -- elt )
- [ length 1 - ] keep over 0 >=
+ index-of-last over 0 >=
[ [ nth-unsafe ] [ shorten ] 2bi ]
[ bounds-error ] 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
-: (subseq-start-from) ( subseq seq n length -- subseq seq ? )
- [
- [ 3dup ] dip [ + swap nth-unsafe ] keep rot nth-unsafe =
- ] all-integers? nip ; inline
+: subseq-index-from ( n seq subseq -- i/f )
+ [ [ length ] bi@ - 1 + ] 2keep
+ '[ _ _ subseq-starts-at? ] find-integer-from ; inline
-PRIVATE>
+: subseq-index ( seq subseq -- i/f ) [ 0 ] 2dip subseq-index-from ; inline
-: subseq-start-from ( subseq seq n -- i )
- pick length [ pick length swap - 1 + ] keep
- [ (subseq-start-from) ] curry (find-integer) 2nip ;
+: subseq-index? ( seq subseq -- ? ) subseq-index >boolean ; inline
-: subseq-start ( subseq seq -- i ) 0 subseq-start-from ; inline
+: subseq-start-from ( subseq seq n -- i/f )
+ spin subseq-index-from ; inline deprecated
-: subseq? ( subseq seq -- ? ) subseq-start >boolean ;
+: subseq-start ( subseq seq -- i/f ) swap subseq-index ; inline deprecated
+
+: subseq? ( subseq seq -- ? ) subseq-start >boolean ; inline deprecated
: 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>
[ 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
<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>
projects / factor.git / blobdiff