sequences: collect-from, remove sequence-operator-from, cleanups

[factor.git] / core / sequences / sequences.factor

diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor
index a7b77133794482d7d14a7489fe8b1543325de5ea..3d22801ef4a6d07ecab8ef9e23238d6de7c577aa 100644 (file)
--- a/core/sequences/sequences.factor
+++ b/core/sequences/sequences.factor
@@ -135,12 +135,6 @@ INSTANCE: iota immutable-sequence
     [ [ 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
 
@@ -155,6 +149,12 @@ INSTANCE: iota immutable-sequence
 
 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
 
@@ -182,10 +182,14 @@ PRIVATE>
 : ?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
@@ -247,17 +251,15 @@ M: slice virtual@ [ from>> + ] [ seq>> ] bi ; 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
 
@@ -291,7 +293,7 @@ ERROR: integer-length-expected obj ;
 : length-sequence ( seq -- n seq )
     [ length check-length ] [ ] bi ; inline
 
-: >range-iterator< ( slice/seq -- i n slice/seq )
+: >underlying< ( slice/seq -- i n slice/seq )
     dup slice? [ >slice< ] [ >sequence< ] if ; inline
 
 TUPLE: copier
@@ -339,15 +341,15 @@ PRIVATE>
 : subseq ( from to seq -- subseq )
     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* ;
 
@@ -409,24 +411,28 @@ PRIVATE>
 
 <PRIVATE
 
-: sequence-iterator ( seq quot -- i n quot' )
-    [ >range-iterator< [ nth-unsafe ] curry ] dip compose ; inline
+: sequence-operator ( seq quot -- i n quot' )
+    [ >underlying< [ nth-unsafe ] curry ] dip compose ; inline
 
-! setup-1each
-: length-iterator ( seq quot -- n quot' )
+: length-iterator ( seq -- n quot' )
     length-sequence [ nth-unsafe ] curry ; inline
 
-! (1each)
 : length-operator ( seq quot -- n quot' )
     [ length-iterator ] dip compose ; inline
 
-: sequence-iterator-from ( seq quot i -- i n quot' )
-    -rot length-operator ; inline
+: 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 -- )
-    [ [ keep ] dip set-nth-unsafe ] 2curry each-integer ; inline
+    collect-into each-integer ; inline
 
-: sequence-index-iterator ( seq quot -- n quot' )
+: sequence-index-operator ( seq quot -- n quot' )
     [ length-iterator [ keep ] curry ] dip compose ; inline
 
 : map-into ( seq quot into -- )
@@ -451,51 +457,46 @@ PRIVATE>
 : (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 [ [ length-operator ] dip call ] dip finish-find ; inline
+: element/index ( i/f seq -- elt/f i/f )
+    '[ [ _ nth ] [ f ] if* ] keep ;
 
-: (find-from) ( n seq quot quot' -- i elt )
-    [ 2dup bounds-check? ] 2dip
-    '[ _ _ (find) ] [ 2drop f f ] if ; inline
+: index/element ( i/f seq -- i/f elt/f )
+    dupd '[ _ nth ] [ f ] if* ;
 
-: (find-index) ( seq quot quot' -- i elt )
-    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) ] [ 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 -- ... ) -- ... )
-    sequence-iterator each-integer-from ; inline
+    sequence-operator each-integer-from ; inline
 
 : each-from ( ... seq quot: ( ... x -- ... ) i -- ... )
-    sequence-iterator-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 ( ... 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 )
-    [ length-operator ] 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
@@ -531,7 +532,7 @@ PRIVATE>
     -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
@@ -540,37 +541,55 @@ PRIVATE>
     (2each) all-integers? ; inline
 
 : 2any? ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... ? ) -- ... ? )
-    [ not ] compose 2all? not ; inline
+    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-from ] (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-from ] (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 -- ... ? ) -- ... ? )
-    sequence-iterator all-integers-from? ; inline
+    sequence-operator all-integers-from? ; inline
 
 : push-if ( ..a elt quot: ( ..a elt -- ..b ? ) accum -- ..b )
     [ keep ] dip rot [ push ] [ 2drop ] if ; inline
@@ -595,7 +614,7 @@ PRIVATE>
     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
@@ -631,7 +650,7 @@ PRIVATE>
     [ dup ] swap [ keep ] curry produce nip ; inline
 
 : each-index ( ... seq quot: ( ... elt index -- ... ) -- ... )
-    sequence-index-iterator 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
@@ -685,27 +704,15 @@ PRIVATE>
 : 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 ;
 
@@ -769,25 +776,29 @@ M: slice hashcode* [ sequence-hashcode ] recursive-hashcode ;
 
 <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! ;
@@ -811,21 +822,21 @@ PRIVATE>
 : 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
 
@@ -882,7 +893,7 @@ 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 ;
 
@@ -1039,19 +1050,20 @@ PRIVATE>
         [ + _ 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*
@@ -1093,11 +1105,11 @@ 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>
@@ -1182,14 +1194,14 @@ PRIVATE>
 
 : generic-flip ( matrix -- newmatrix )
     [ [ length ] [ min ] map-reduce ] keep
-    '[ _ [ nth-unsafe ] with { } map-as ] { } map-integers ; inline
+    '[ _ [ nth-unsafe ] with { } map-as ] map-integers ; inline
 
 USE: arrays
 
 : array-flip ( matrix -- newmatrix )
     { array } declare
     [ [ { array } declare length>> ] [ min ] map-reduce ] keep
-    '[ _ [ { array } declare array-nth ] with { } map-as ] { } map-integers ;
+    '[ _ [ { array } declare array-nth ] with { } map-as ] map-integers ;
 
 PRIVATE>