X-Git-Url: https://gitweb.factorcode.org/gitweb.cgi?p=factor.git;a=blobdiff_plain;f=extra%2Fsequences%2Fextras%2Fextras.factor;h=0d37e3e14d118f96a3c9de09c4258144c6c767b2;hp=ae0de0ae73607fb56fd0747b53a9820b41ccfd8f;hb=1bf4194271bc619cbeaeda2f60bf11081a95282f;hpb=67e40374416394609c1132bd6c26e4333e735fff diff --git a/extra/sequences/extras/extras.factor b/extra/sequences/extras/extras.factor index ae0de0ae73..0d37e3e14d 100644 --- a/extra/sequences/extras/extras.factor +++ b/extra/sequences/extras/extras.factor @@ -12,7 +12,8 @@ IN: sequences.extras :: subseq* ( from to seq -- subseq ) seq length :> len from [ dup 0 < [ len + ] when ] [ 0 ] if* - to [ dup 0 < [ len + ] when ] [ len ] if* [ 0 len clamp ] bi@ dupd max seq subseq ; + to [ dup 0 < [ len + ] when ] [ len ] if* + [ 0 len clamp ] bi@ dupd max seq subseq ; : safe-subseq ( from to seq -- subseq ) [ length '[ 0 _ clamp ] bi@ ] keep subseq ; @@ -20,13 +21,10 @@ IN: sequences.extras : all-subseqs ( seq -- seqs ) dup length [1..b] [ clump ] with map concat ; -:: each-subseq ( ... seq quot: ( ... subseq -- ... ) -- ... ) - seq length :> len - len [0..b] [| from | - from len (a..b] [| to | - from to seq subseq quot call - ] each - ] each ; inline +: each-subseq ( ... seq quot: ( ... subseq -- ... ) -- ... ) + [ dup length [ [0..b] ] [ ] bi ] dip '[ + dup _ (a..b] [ rot [ subseq _ call ] keep ] with each + ] each drop ; inline : map-like ( seq exemplar -- seq' ) '[ _ like ] map ; inline @@ -104,12 +102,12 @@ PRIVATE> : even-indices ( seq -- seq' ) [ length 1 + 2/ ] keep [ [ [ 2 * ] dip nth-unsafe ] curry - ] keep map-integers ; + ] keep map-integers-as ; : odd-indices ( seq -- seq' ) [ length 2/ ] keep [ [ [ 2 * 1 + ] dip nth-unsafe ] curry - ] keep map-integers ; + ] keep map-integers-as ; : compact ( ... seq quot: ( ... elt -- ... ? ) elt -- ... seq' ) [ split-when harvest ] dip join ; inline @@ -263,7 +261,7 @@ PRIVATE> overd [ [ collect-with-previous ] keep ] new-like ; inline : map-with-previous-as ( ... seq quot: ( ... elt prev/f -- ... newelt ) exemplar -- ... newseq ) - [ (1each) ] dip map-integers-with ; inline + [ length-operator ] dip map-integers-with ; inline : map-with-previous ( ... seq quot: ( ... elt prev/f -- ... newelt ) -- ... newseq ) over map-with-previous-as ; inline @@ -279,11 +277,14 @@ PRIVATE> PRIVATE> : map-from-as ( ... seq quot: ( ... elt -- ... newelt ) i exemplar -- ... newseq ) - [ -rot setup-each-from ] dip map-integers ; inline + [ -rot setup-each-from ] dip map-integers-as ; inline : map-from ( ... seq quot: ( ... elt -- ... newelt ) i -- ... newseq ) pick map-from-as ; inline +: map-if ( ... seq if-quot: ( ... elt -- ... ? ) map-quot: ( ... elt -- ... newelt ) -- ... newseq ) + '[ dup @ _ when ] map ; inline + : 3each-from ( ... seq1 seq2 seq3 quot: ( ... elt1 elt2 elt3 -- ... ) i -- ... ) - [ (3each) ] dip -rot (each-integer) ; inline + [ (3each) ] dip -rot each-integer-from ; inline : 3map-reduce ( ..a seq1 seq2 seq3 map-quot: ( ..a elt1 elt2 elt3 -- ..b intermediate ) reduce-quot: ( ..b prev intermediate -- ..a next ) -- ..a result ) @@ -378,13 +379,19 @@ PRIVATE> : >string-list ( seq -- seq' ) [ "\"" 1surround ] map "," join ; +: with-string-lines ( str quot -- str' ) + [ string-lines ] dip map "\n" join ; inline + +: prepend-lines-with-spaces ( str -- str' ) + [ " " prepend ] with-string-lines ; + : one? ( ... seq quot: ( ... elt -- ... ? ) -- ... ? ) [ find ] 2keep rot [ [ 1 + ] 2dip find-from drop not ] [ 3drop f ] if ; inline : map-index! ( ... seq quot: ( ... elt index -- ... newelt ) -- ... seq ) - over [ [ (each-index) ] dip collect ] keep ; inline + over [ [ sequence-index-operator ] dip collect ] keep ; inline pick [ 2map-into ] keep ; inline : 2map-index ( ... seq1 seq2 quot: ( ... elt1 elt2 index -- ... newelt ) -- ... newseq ) - pick [ (2each-index) ] dip map-integers ; inline + pick [ (2each-index) ] dip map-integers-as ; inline TUPLE: evens { seq read-only } ; @@ -432,12 +439,6 @@ INSTANCE: odds virtual-sequence : until-empty ( seq quot -- ) [ dup empty? ] swap until drop ; inline -: arg-max ( seq -- n ) - [ supremum ] keep index ; - -: arg-min ( seq -- n ) - [ infimum ] keep index ; - [ length 1 - swap - ] [ nth ] bi ; inline : each-index-from ( ... seq quot: ( ... elt index -- ... ) i -- ... ) - -rot (each-index) (each-integer) ; inline + -rot sequence-index-operator each-integer-from ; inline : infimum-by* ( ... seq quot: ( ... elt -- ... x ) -- ... i elt ) [ before? ] select-by* ; inline +: arg-max ( seq -- n ) + [ ] supremum-by* drop ; + +: arg-min ( seq -- n ) + [ ] infimum-by* drop ; + : ?supremum ( seq/f -- elt/f ) [ f ] [ [ ] [ 2dup and [ max ] [ dupd ? ] if ] map-reduce @@ -636,10 +643,10 @@ PRIVATE> ] if-empty ; : change-last ( seq quot -- ) - [ drop length 1 - ] [ change-nth ] 2bi ; inline + [ index-of-last ] [ change-nth ] bi* ; inline : change-last-unsafe ( seq quot -- ) - [ drop length 1 - ] [ change-nth-unsafe ] 2bi ; inline + [ index-of-last ] [ change-nth-unsafe ] bi* ; inline : replicate-into ( ... seq quot: ( ... -- ... newelt ) -- ... ) over [ length ] 2dip '[ _ dip _ set-nth-unsafe ] each-integer ; inline @@ -647,15 +654,24 @@ PRIVATE> : count* ( ... seq quot: ( ... elt -- ... ? ) -- ... % ) over [ count ] [ length ] bi* / ; inline +: sequence-index-operator-last ( n seq quot -- n quot' ) + [ [ nth-unsafe ] curry [ keep ] curry ] dip compose ; inline + +: find-last-index-from ( ... n seq quot: ( ... elt i -- ... ? ) -- ... i elt ) + '[ + _ [ sequence-index-operator-last find-last-integer ] keepd + index/element + ] bounds-check-call ; inline + : find-last-index ( ... seq quot: ( ... elt i -- ... ? ) -- ... i elt ) - [ [ 1 - ] dip find-last-integer ] (find-index) ; inline + [ index-of-last ] dip find-last-index-from ; inline : map-find-last-index ( ... seq quot: ( ... elt index -- ... result/f ) -- ... result i elt ) [ find-last-index ] (map-find-index) ; inline :: (start-all) ( seq subseq increment -- indices ) 0 - [ [ subseq seq ] dip subseq-start-from dup ] + [ seq subseq subseq-index-from dup ] [ [ increment + ] keep ] produce nip ; : start-all ( seq subseq -- indices ) @@ -688,6 +704,10 @@ PRIVATE> [ not ] compose [ find-last drop ] keepd length swap [ - 1 - ] when* ; inline +:: shorten* ( vector n -- seq ) + vector n tail + n vector shorten ; + :: interleaved-as ( seq glue exemplar -- newseq ) seq length dup 1 - + 0 max exemplar new-sequence :> newseq seq [ 2 * newseq set-nth-unsafe ] each-index @@ -704,7 +724,7 @@ PRIVATE> : find-pred-loop ( ... i n seq quot: ( ... elt -- ... calc ? ) -- ... calc/f i/f elt/f ) 2pick < [ [ nipd call ] 4keep - 7 nrot 7 nrot 7 nrot + 3 7 0 nrotated [ [ 3drop ] 2dip rot ] [ 2drop [ 1 + ] 3dip find-pred-loop ] if ] [