: ?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
+: 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
M: slice length [ to>> ] [ from>> ] bi - ; inline
-: bound ( seq n -- seq n' ) over length min ; inline
-
: head-slice ( seq n -- slice ) head-to-index <slice> ; inline
: tail-slice ( seq n -- slice ) index-to-tail <slice> ; inline
: length-operator-last ( seq quot -- n quot' )
length-operator [ 1 - ] dip ; inline
-: sequence-operator-from ( seq quot i -- i n quot' )
- -rot length-operator ; inline
+: collect-into ( quot into -- quot' )
+ [ [ keep ] dip set-nth-unsafe ] 2curry ; inline
-: sequence-operator-last-from ( seq quot i -- n quot' )
- -rot length-operator-last nip ; inline
+: collect-from ( i n quot into -- )
+ collect-into each-integer-from ; inline
: collect ( n quot into -- )
- [ [ keep ] dip set-nth-unsafe ] 2curry each-integer ; inline
+ collect-into each-integer ; inline
: sequence-index-operator ( seq quot -- n quot' )
[ length-iterator [ keep ] curry ] dip compose ; inline
[ setup-3each ] dip compose ; inline
: element/index ( i/f seq -- elt/f i/f )
- [ maybe-nth ] [ drop ] 2bi ; inline
+ '[ [ _ nth ] [ f ] if* ] keep ;
-: index/element ( i/f seq -- elt/f i/f )
- [ drop ] [ maybe-nth ] 2bi ; inline
+: index/element ( i/f seq -- i/f elt/f )
+ dupd '[ _ nth ] [ f ] if* ;
: (accumulate) ( seq identity quot -- identity seq quot' )
swapd [ keepd ] curry ; inline
sequence-operator each-integer-from ; inline
: each-from ( ... seq quot: ( ... x -- ... ) i -- ... )
- sequence-operator-from each-integer-from ; inline
+ -rot length-operator each-integer-from ; inline
: reduce ( ... seq identity quot: ( ... prev elt -- ... next ) -- ... result )
swapd each ; inline
+: 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
: 3map ( ... seq1 seq2 seq3 quot: ( ... elt1 elt2 elt3 -- ... newelt ) -- ... newseq )
pickd swap 3map-as ; inline
-: bounds-check-find ( n seq quot -- elt i )
+<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 )
- '[
- _ [ rot sequence-operator-from find-integer-from ] keepd
- index/element
- ] bounds-check-find ; inline
+ '[ _ find-from-unsafe ] bounds-check-call ; inline
: find ( ... seq quot: ( ... elt -- ... ? ) -- ... i elt )
- [ 0 ] 2dip find-from ; inline
+ [ 0 ] 2dip find-from-unsafe ; inline
: find-last-from ( ... n seq quot: ( ... elt -- ... ? ) -- ... i elt )
- '[
- _ [ rot sequence-operator-last-from find-last-integer ] keepd
- index/element
- ] bounds-check-find ; inline
+ '[ _ find-last-from-unsafe ] bounds-check-call ; inline
: find-last ( ... seq quot: ( ... elt -- ... ? ) -- ... i elt )
- [ [ length 1 - ] keep ] dip find-last-from ; inline
+ [ index-of-last ] dip find-last-from ; inline
: find-index-from ( ... n seq quot: ( ... elt i -- ... ? ) -- ... i elt )
'[
_ [ sequence-index-operator find-integer-from ] keepd
index/element
- ] bounds-check-find ; inline
+ ] bounds-check-call ; inline
: find-index ( ... seq quot: ( ... elt i -- ... ? ) -- ... i elt )
[ 0 ] 2dip find-index-from ; 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
+: 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 )
negate filter! ; inline
: 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 ;
[ + _ nth-unsafe ] keep _ nth-unsafe =
] with all-integers? ; inline
-: find-subseq-from ( n seq subseq -- i/f )
+: subseq-index-from ( n seq subseq -- i/f )
[ [ length ] bi@ - 1 + ] 2keep
'[ _ _ subseq-starts-at? ] find-integer-from ; inline
-: subseq-start-from ( subseq seq n -- i/f ) spin find-subseq-from ; inline
+: subseq-index ( seq subseq -- i/f ) [ 0 ] 2dip subseq-index-from ; inline
-: find-subseq ( seq subseq -- i/f ) [ 0 ] 2dip find-subseq-from ; inline
+: subseq-index? ( seq subseq -- ? ) subseq-index >boolean ; inline
-: find-subseq? ( seq subseq -- ? ) find-subseq >boolean ; inline
+: subseq-start-from ( subseq seq n -- i/f )
+ spin subseq-index-from ; inline deprecated
-: subseq-start ( subseq seq -- i/f ) swap find-subseq ; inline
+: subseq-start ( subseq seq -- i/f ) swap subseq-index ; inline deprecated
-: subseq? ( subseq seq -- ? ) subseq-start >boolean ; inline
+: subseq? ( subseq seq -- ? ) subseq-start >boolean ; inline deprecated
: drop-prefix ( seq1 seq2 -- slice1 slice2 )
2dup mismatch [ 2dup min-length ] unless*
projects / factor.git / blobdiff