I missed these because they were already loaded in my saved image.
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2017 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays concurrency.combinators concurrency.semaphores fry
+io io.directories io.encodings.utf8 io.files.info io.launcher
+io.pathnames kernel math namespaces sequences splitting
+system-info unicode ;
+IN: cli.git
+
+SYMBOL: cli-git-num-parallel
+cli-git-num-parallel [ cpus 2 * ] initialize
+
+: git-command>string ( quot -- string )
+ utf8 <process-reader> stream-contents [ blank? ] trim-tail ;
+
+: git-clone-as ( uri path -- process ) [ { "git" "clone" } ] 2dip 2array append run-process ;
+: git-clone ( uri -- process ) [ { "git" "clone" } ] dip suffix run-process ;
+: git-pull* ( -- process ) { "git" "pull" } run-process ;
+: git-pull ( path -- process ) [ git-pull* ] with-directory ;
+: git-fetch-all* ( -- process ) { "git" "fetch" "--all" } run-process ;
+: git-fetch-all ( path -- process ) [ git-fetch-all* ] with-directory ;
+: git-fetch-tags* ( -- process ) { "git" "fetch" "--tags" } run-process ;
+: git-fetch-tags ( path -- process ) [ git-fetch-tags* ] with-directory ;
+: git-checkout-new-branch* ( branch -- process ) [ { "git" "checkout" "-b" } ] dip suffix run-process ;
+: git-checkout-new-branch ( path branch -- process ) '[ _ git-checkout-new-branch* ] with-directory ;
+: git-checkout-existing-branch* ( branch -- process ) [ { "git" "checkout" } ] dip suffix run-process ;
+: git-checkout-existing-branch ( path branch -- process ) '[ _ git-checkout-existing-branch* ] with-directory ;
+: git-change-remote* ( remote uri -- process ) [ { "git" "remote" "set-url" } ] 2dip 2array append run-process ;
+: git-change-remote ( path remote uri -- process ) '[ _ _ git-change-remote* ] with-directory ;
+: git-remote-add* ( remote uri -- process ) [ { "git" "remote" "add" } ] 2dip 2array append run-process ;
+: git-remote-add ( path remote uri -- process ) '[ _ _ git-remote-add* ] with-directory ;
+: git-remote-get-url* ( remote -- process ) [ { "git" "remote" "get-url" } ] dip suffix run-process ;
+: git-remote-get-url ( path remote -- process ) '[ _ git-remote-get-url* ] with-directory ;
+: git-rev-parse* ( branch -- string ) [ { "git" "rev-parse" } ] dip suffix git-command>string ;
+: git-rev-parse ( path branch -- string ) '[ _ git-rev-parse* ] with-directory ;
+: git-diff-name-only* ( from to -- lines )
+ [ { "git" "diff" "--name-only" } ] 2dip 2array append process-lines ;
+: git-diff-name-only ( path from to -- lines )
+ '[ _ _ git-diff-name-only* ] with-directory ;
+
+: git-repository? ( directory -- ? )
+ ".git" append-path current-directory get prepend-path
+ ?file-info dup [ directory? ] when ;
+
+: git-current-branch* ( -- name )
+ { "git" "rev-parse" "--abbrev-ref" "HEAD" } git-command>string ;
+
+: git-current-branch ( directory -- name )
+ [ git-current-branch* ] with-directory ;
+
+: repository-url>name ( string -- string' )
+ file-name ".git" ?tail drop ;
+
+: update-repository ( url -- process )
+ dup repository-url>name git-repository?
+ [ repository-url>name git-pull ] [ git-clone ] if ;
+
+: sync-repositories ( directory urls -- )
+ '[
+ _ cli-git-num-parallel get <semaphore> '[
+ _ [ update-repository ] with-semaphore
+ ] parallel-each
+ ] with-ensure-directory ;
--- /dev/null
+Doug Coleman
--- /dev/null
+USING: combinators help.markup help.syntax ;
+
+IN: combinators.extras
+
+HELP: cond-case
+{ $values { "assoc" "a sequence of quotation pairs and an optional quotation" } }
+{ $description
+ "Similar to " { $link case } ", this evaluates an " { $snippet "obj" } " according to the first quotation in each pair. If any quotation returns true, calls the second quotation without " { $snippet "obj" } " on the stack."
+ $nl
+ "If there is no quotation that returns true, the default case is taken. If the last element of " { $snippet "assoc" } " is a quotation, the quotation is called with " { $snippet "obj" } " on the stack. Otherwise, a " { $link no-cond } " error is raised."
+}
+{ $examples
+ { $example
+ "USING: combinators.extras io kernel math ;"
+ "0 {"
+ " { [ 0 > ] [ \"positive\" ] }"
+ " { [ 0 < ] [ \"negative\" ] }"
+ " [ drop \"zero\" ]"
+ "} cond-case print"
+ "zero"
+ }
+} ;
--- /dev/null
+! Copyright (C) 2013 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators.extras io.files kernel math sequences
+tools.test ;
+
+{ "a b" }
+[ "a" "b" [ " " glue ] once ] unit-test
+
+{ "a b c" }
+[ "a" "b" "c" [ " " glue ] twice ] unit-test
+
+{ "a b c d" }
+[ "a" "b" "c" "d" [ " " glue ] thrice ] unit-test
+
+{ { "negative" 0 "positive" } } [
+ { -1 0 1 } [
+ {
+ { [ 0 > ] [ "positive" ] }
+ { [ 0 < ] [ "negative" ] }
+ [ ]
+ } cond-case
+ ] map
+] unit-test
+
+{ { 1 2 3 } } [ 1 { [ ] [ 1 + ] [ 2 + ] } cleave-array ] unit-test
+
+{ 2 15 } [ 1 2 3 4 5 6 [ - - ] [ + + ] 3bi* ] unit-test
+
+{ 2 5 } [ 1 2 3 4 5 6 [ - - ] 3bi@ ] unit-test
+
+{ 3 1 } [ 1 2 [ + ] keepd ] unit-test
+
+{ "1" "123" } [ "1" "123" [ length ] [ > ] swap-when ] unit-test
+{ "123" "1" } [ "1" "123" [ length ] [ < ] swap-when ] unit-test
+
+
+{ t } [ "resource:" [ exists? ] ?1arg >boolean ] unit-test
+{ f } [ f [ exists? ] ?1arg ] unit-test
+{ f } [ "/homeasdfasdf123123" [ exists? ] ?1arg ] unit-test
+
+{ "hi " "there" } [
+ "hi there" {
+ { [ "there" over subseq-start ] [ cut ] }
+ [ f ]
+ } cond*
+] unit-test
+
+{ "hi " "there" } [
+ "hi there" {
+ { [ "foo" over subseq-start ] [ head f ] }
+ { [ "there" over subseq-start ] [ cut ] }
+ [ f ]
+ } cond*
+] unit-test
+
+{ "hi there" f } [
+ "hi there" {
+ { [ "foo" over subseq-start ] [ head f ] }
+ { [ "bar" over subseq-start ] [ cut ] }
+ [ f ]
+ } cond*
+] unit-test
--- /dev/null
+! Copyright (C) 2013 Doug Coleman, John Benediktsson.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays assocs combinators combinators.smart fry
+generalizations kernel macros math quotations sequences locals
+math.order sequences.generalizations sequences.private
+stack-checker.transforms system words ;
+IN: combinators.extras
+
+: once ( quot -- ) call ; inline
+: twice ( quot -- ) dup [ call ] dip call ; inline
+: thrice ( quot -- ) dup dup [ call ] 2dip [ call ] dip call ; inline
+: forever ( quot -- ) [ t ] compose loop ; inline
+
+MACRO: cond-case ( assoc -- quot )
+ [
+ dup callable? not [
+ [ first [ dup ] prepose ]
+ [ second [ drop ] prepose ] bi 2array
+ ] when
+ ] map [ cond ] curry ;
+
+MACRO: cleave-array ( quots -- quot )
+ [ '[ _ cleave ] ] [ length '[ _ narray ] ] bi compose ;
+
+: 3bi* ( u v w x y z p q -- )
+ [ 3dip ] dip call ; inline
+
+: 3bi@ ( u v w x y z quot -- )
+ dup 3bi* ; inline
+
+: 4bi ( w x y z p q -- )
+ [ 4keep ] dip call ; inline
+
+: 4bi* ( s t u v w x y z p q -- )
+ [ 4dip ] dip call ; inline
+
+: 4bi@ ( s t u v w x y z quot -- )
+ dup 4bi* ; inline
+
+: 4tri ( w x y z p q r -- )
+ [ [ 4keep ] dip 4keep ] dip call ; inline
+
+: plox ( ... x/f quot: ( ... x -- ... ) -- ... )
+ dupd when ; inline
+
+MACRO: smart-plox ( true -- quot )
+ [ inputs [ 1 - [ and ] n*quot ] keep ] keep swap
+ '[ _ _ [ _ ndrop f ] smart-if ] ;
+
+: throttle ( quot millis -- quot' )
+ 1,000,000 * '[
+ _ nano-count { 0 } 2dup first-unsafe _ + >=
+ [ 0 swap set-nth-unsafe call ] [ 3drop ] if
+ ] ; inline
+
+: swap-when ( x y quot: ( x -- n ) quot: ( n n -- ? ) -- x' y' )
+ '[ _ _ 2dup _ bi@ @ [ swap ] when ] call ; inline
+
+
+! ?1arg-result-falsify
+
+: 1falsify ( obj/f -- obj/f ) ; inline
+: 2falsify ( obj1 obj2 -- obj1/f obj2/f ) 2dup and [ 2drop f f ] unless ; inline
+: 3falsify ( obj1 obj2 obj3 -- obj1/f obj2/f obj3/f ) 3dup and and [ 3drop f f f ] unless ; inline
+
+MACRO: n-and ( n -- quot )
+ 1 [-] [ and ] n*quot ;
+
+MACRO: n*obj ( n obj -- quot )
+ 1quotation n*quot ;
+
+MACRO:: n-falsify ( n -- quot )
+ [ n ndup n n-and [ n ndrop n f n*obj ] unless ] ;
+
+! plox
+: ?1res ( ..a obj/f quot -- ..b )
+ dupd when ; inline
+
+! when both args are true, call quot. otherwise dont
+: ?2res ( ..a obj1 obj2 quot: ( obj1 obj2 -- ? ) -- ..b )
+ [ 2dup and ] dip [ 2drop f ] if ; inline
+
+! try the quot, keep the original arg if quot is true
+: ?1arg ( obj quot: ( obj -- ? ) -- obj/f )
+ [ ?1res ] keepd '[ _ ] [ f ] if ; inline
+
+: ?2arg ( obj1 obj2 quot: ( obj1 obj2 -- ? ) -- obj1/f obj2/f )
+ [ ?2res ] 2keepd '[ _ _ ] [ f f ] if ; inline
+
+<<
+: alist>quot* ( default assoc -- quot )
+ [ rot \ if* 3array append [ ] like ] assoc-each ;
+
+: cond*>quot ( assoc -- quot )
+ [ dup pair? [ [ drop ] prepend [ t ] swap 2array ] unless ] map
+ reverse! [ no-cond ] swap alist>quot* ;
+
+DEFER: cond*
+\ cond* [ cond*>quot ] 1 define-transform
+\ cond* t "no-compile" set-word-prop
+>>
+: cond* ( assoc -- )
+ [ dup callable? [ drop t ] [ first call ] if ] map-find
+ [ dup callable? [ nip call ] [ second call ] if ]
+ [ no-cond ] if* ;
--- /dev/null
+USING: help.markup help.syntax sequences splitting strings ;
+
+IN: grouping.extras
+
+HELP: group-by
+{ $values { "seq" sequence } { "quot" { $quotation ( elt -- key ) } } { "groups" "a new assoc" } }
+{ $description "Groups the elements by the key received by applying quot to each element in the sequence." }
+{ $examples
+ { $example
+ "USING: grouping.extras unicode.data prettyprint sequences strings ;"
+ "\"THis String Has CasE!\" [ category ] group-by [ last >string ] { } map-as ."
+ "{ \"TH\" \"is\" \" \" \"S\" \"tring\" \" \" \"H\" \"as\" \" \" \"C\" \"as\" \"E\" \"!\" }"
+ }
+} ;
--- /dev/null
+USING: arrays grouping.extras kernel math math.functions
+sequences tools.test ;
+
+{ { } } [ { 1 } [ 2array ] 2clump-map ] unit-test
+{ { { 1 2 } } } [ { 1 2 } [ 2array ] 2clump-map ] unit-test
+{ { { 1 2 } { 2 3 } } } [ { 1 2 3 } [ 2array ] 2clump-map ] unit-test
+{ { { 1 2 } { 2 3 } { 3 4 } } } [ { 1 2 3 4 } [ 2array ] 2clump-map ] unit-test
+
+{ { } } [ { 1 } [ 3array ] 3clump-map ] unit-test
+{ { } } [ { 1 2 } [ 3array ] 3clump-map ] unit-test
+{ { { 1 2 3 } } } [ { 1 2 3 } [ 3array ] 3clump-map ] unit-test
+{ { { 1 2 3 } { 2 3 4 } } } [ { 1 2 3 4 } [ 3array ] 3clump-map ] unit-test
+
+{ { } } [ { 1 } [ 4array ] 4 nclump-map ] unit-test
+{ { } } [ { 1 2 } [ 4array ] 4 nclump-map ] unit-test
+{ { { 1 2 3 4 } } } [ { 1 2 3 4 } [ 4array ] 4 nclump-map ] unit-test
+{ { { 1 2 3 4 } { 2 3 4 5 } } } [ { 1 2 3 4 5 } [ 4array ] 4 nclump-map ] unit-test
+
+{ { "tail" "ail" "il" "l" } } [ "tail" tail-clump ] unit-test
+{ { "h" "he" "hea" "head" } } [ "head" head-clump ] unit-test
+
+{ { B{ 97 115 } B{ 100 102 } } } [ "asdf" 2 B{ } group-as ] unit-test
+{ { { 97 115 } { 115 100 } { 100 102 } } } [ "asdf" 2 { } clump-as ] unit-test
+
+{
+ V{
+ { 0 V{ 0 1 2 } }
+ { 1 V{ 3 4 5 } }
+ { 2 V{ 6 7 8 } }
+ { 3 V{ 9 } } }
+} [
+ 10 <iota> [ 3 / floor ] group-by
+] unit-test
+
+{ V{ { t V{ 0 1 2 3 4 5 6 7 8 9 } } } }
+[ 10 <iota> [ drop t ] group-by ] unit-test
+
+{ V{ } } [ { } [ drop t ] group-by ] unit-test
+
+{ { { } { } { } } } [ { } 3 n-group ] unit-test
+{ { { 1 } { } { } } } [ { 1 } 3 n-group ] unit-test
+{ { { 1 } { 2 } { } } } [ { 1 2 } 3 n-group ] unit-test
+{ { { 1 } { 2 } { 3 } } } [ { 1 2 3 } 3 n-group ] unit-test
+{ { { 1 2 } { 3 } { 4 } } } [ { 1 2 3 4 } 3 n-group ] unit-test
--- /dev/null
+USING: accessors arrays combinators fry grouping
+grouping.private kernel locals macros math math.ranges sequences
+sequences.generalizations sequences.private vectors ;
+
+IN: grouping.extras
+
+: 2clump-map-as ( seq quot: ( elt1 elt2 -- newelt ) exemplar -- seq' )
+ [ dup 1 short tail-slice ] 2dip 2map-as ; inline
+
+: 2clump-map ( seq quot: ( elt1 elt2 -- newelt ) -- seq' )
+ { } 2clump-map-as ; inline
+
+: 3clump-map-as ( seq quot: ( elt1 elt2 elt3 -- newelt ) exemplar -- seq' )
+ [
+ dup [ 1 short tail-slice ] [ 2 short tail-slice ] bi
+ ] 2dip 3map-as ; inline
+
+: 3clump-map ( seq quot: ( elt1 elt2 elt3 -- newelt ) -- seq' )
+ { } 3clump-map-as ; inline
+
+MACRO: nclump-map-as ( seq quot exemplar n -- result )
+ [ nip [1,b) [ [ short tail-slice ] curry ] map swap ] 2keep
+ '[ _ dup _ cleave _ _ _ nmap-as ] ;
+
+: nclump-map ( seq quot n -- result )
+ { } swap nclump-map-as ; inline
+
+TUPLE: head-clumps seq ;
+C: <head-clumps> head-clumps
+M: head-clumps length seq>> length ;
+M: head-clumps nth-unsafe seq>> swap 1 + head-slice ;
+INSTANCE: head-clumps immutable-sequence
+
+: head-clump ( seq -- array )
+ [ <head-clumps> ] [ [ like ] curry map ] bi ;
+
+TUPLE: tail-clumps seq ;
+C: <tail-clumps> tail-clumps
+M: tail-clumps length seq>> length ;
+M: tail-clumps nth-unsafe seq>> swap tail-slice ;
+INSTANCE: tail-clumps immutable-sequence
+
+: tail-clump ( seq -- array )
+ [ <tail-clumps> ] [ [ like ] curry map ] bi ;
+
+: clump-as ( seq n exemplar -- array )
+ [ <clumps> ] dip [ like ] curry map ;
+
+: group-as ( seq n exemplar -- array )
+ [ <groups> ] dip [ like ] curry map ;
+
+<PRIVATE
+
+: (group-by) ( groups elt key -- groups )
+ pick [ t ] [ last first dupd = not ] if-empty [
+ swap 1vector 2array over push
+ ] [
+ drop over last last push
+ ] if ; inline
+
+PRIVATE>
+
+: group-by ( seq quot: ( elt -- key ) -- groups )
+ '[ dup _ call( x -- y ) (group-by) ] V{ } clone swap reduce ;
+
+:: <n-groups> ( seq n -- groups )
+ seq length :> len
+ len n /mod :> ( step rem! )
+ 0 n [
+ dup len < [
+ dup step + rem zero? [ 1 + rem 1 - rem! ] unless
+ [ seq <slice> ] keep swap
+ ] [ f ] if
+ ] replicate nip ;
+
+: n-group ( seq n -- groups )
+ [ <n-groups> ] map-like ;
--- /dev/null
+algorithms
--- /dev/null
+USING: help.markup help.syntax kernel math sequences ;
+IN: sequences.extras
+
+HELP: ?supremum
+{ $values
+ { "seq/f" { $maybe sequence } }
+ { "elt/f" { $maybe object } }
+}
+{ $description "Outputs the greatest element of " { $snippet "seq" } ", ignoring any " { $link POSTPONE: f } " elements in it. If " { $snippet "seq" } " is empty or " { $link POSTPONE: f } ", returns " { $link POSTPONE: f } "." }
+{ $examples
+ { $example "USING: prettyprint sequences.extras ;"
+ "{ 1 f 3 2 } ?supremum ."
+ "3" }
+} ;
+
+HELP: ?infimum
+{ $values
+ { "seq/f" { $maybe sequence } }
+ { "elt/f" { $maybe object } }
+}
+{ $description "Outputs the least element of " { $snippet "seq" } ", ignoring any " { $link POSTPONE: f } " elements in it. If " { $snippet "seq" } " is empty or " { $link POSTPONE: f } ", returns " { $link POSTPONE: f } "." }
+{ $examples
+ { $example "USING: prettyprint sequences.extras ;"
+ "{ 1 f 3 2 } ?infimum ."
+ "1" }
+} ;
+
+{ ?supremum ?infimum } related-words
+
+HELP: 2count
+{ $values
+ { "seq1" sequence }
+ { "seq2" sequence }
+ { "quot" { $quotation ( ... elt1 elt2 -- ... ? ) } }
+ { "n" integer } }
+{ $description "Efficiently counts how many pairwise elements of " { $snippet "seq1" } " and " { $snippet "seq2" } " that the predicate quotation matches." }
+{ $examples
+ { $example "USING: kernel prettyprint sequences.extras ;" "{ 1 2 3 } { 3 2 1 } [ = ] 2count ." "1" } }
+{ $see-also count } ;
+
+HELP: 2each-index
+{ $values
+ { "seq1" sequence }
+ { "seq2" sequence }
+ { "quot" { $quotation ( ... elt1 elt2 index -- ... ) } } }
+{ $description "Applies " { $snippet "quot" } " to each pair of elements from " { $snippet "seq1" } " and " { $snippet "seq2" } ", providing the index of the elements at the top of the stack." }
+{ $see-also 2each each-index } ;
+
+HELP: 2map!
+{ $values
+ { "seq1" sequence }
+ { "seq2" sequence }
+ { "quot" { $quotation ( ... elt1 elt2 -- ... newelt ) } } }
+{ $description "Applies the quotation to each pair of elements from " { $snippet "seq1" } " and " { $snippet "seq2" } ", yielding a new element, and storing it back into " { $snippet "seq1" } ". Returns " { $snippet "seq1" } "." }
+{ $see-also 2map map! } ;
+
+HELP: 2map-index
+{ $values
+ { "seq1" sequence }
+ { "seq2" sequence }
+ { "quot" { $quotation ( ... elt1 elt2 index -- ... newelt ) } }
+ { "newseq" sequence } }
+{ $description "Calls the quotation with each pair of elements of the two sequences and their index on the stack, with the index on the top of the stack. Collects the outputs of the quotation and outputs them into a new sequence of the same type as the first sequence." }
+{ $see-also 2map map-index } ;
+
+HELP: count*
+{ $values
+ { "seq" sequence }
+ { "quot" { $quotation ( ... elt -- ... ? ) } }
+ { "%" rational } }
+{ $description "Outputs the fraction of elements in the sequence for which the predicate quotation matches." }
+{ $examples { $example "USING: math math.ranges prettyprint sequences.extras ;" "100 [1,b] [ even? ] count* ." "1/2" } } ;
+
+HELP: collapse
+{ $values
+ { "seq" sequence }
+ { "quot" { $quotation ( ... elt -- ... ? ) } }
+ { "elt" object }
+ { "seq'" sequence } }
+{ $description "Generate a new sequence where all runs of elements for which the predicate returns true are replaced by a single instance of " { $snippet "elt" } "." }
+{ $see-also compact }
+{ $examples
+ "Collapse multiple spaces in a string down to a single space"
+ { $example "USING: kernel prettyprint sequences.extras ;" "\" Hello, crazy world \" [ CHAR: \\s = ] \" \" collapse ." "\" Hello, crazy world \"" } } ;
+
+HELP: compact
+{ $values
+ { "seq" sequence }
+ { "quot" { $quotation ( ... elt -- ... ? ) } }
+ { "elt" object }
+ { "seq'" sequence } }
+{ $description "Generate a new sequence where all runs of elements for which the predicate returns true are replaced by a single instance of " { $snippet "elt" } ". Runs at the beginning or end of the sequence for which the predicate returns true are removed." }
+{ $see-also collapse }
+{ $examples
+ "Collapse multiple spaces in a string down to a single space"
+ { $example "USING: kernel prettyprint sequences.extras ;" "\" Hello, crazy world \" [ CHAR: \\s = ] \" \" compact ." "\"Hello, crazy world\"" } } ;
+
+HELP: <evens>
+{ $values { "seq" sequence } { "evens" evens } }
+{ $description "Create a virtual sequence whose elements consist of the even-indexed elements from the original sequence." }
+{ $notes "Because sequences are zero-indexed, this collection includes the first, third, fifth, etc. elements of the actual sequence which can be counterintuitive." }
+{ $see-also <odds> } ;
+
+HELP: find-all
+{ $values
+ { "seq" sequence }
+ { "quot" { $quotation ( ... elt -- ... ? ) } }
+ { "elts" "the indices of the matching elements" } }
+{ $description "Similar to " { $link find } ", but finds all of the indices and elements that match the provided quotation, not just the first." }
+{ $notes "The result is provided as an array of arrays, whose first value is the index and whose second value is the element." } ;
+
+HELP: first=
+{ $values
+ { "seq" sequence }
+ { "elt" object }
+ { "?" boolean } }
+{ $description "Checks whether the first element of " { $snippet "seq" } " is equal to " { $snippet "elt" } "." } ;
+
+HELP: first?
+{ $values
+ { "seq" sequence }
+ { "quot" { $quotation ( ... elt -- ... ? ) } }
+ { "?" boolean } }
+{ $description "Tests whether the first element of " { $snippet "seq" } " satisfies the provided predicate." } ;
+
+HELP: fourth=
+{ $values
+ { "seq" sequence }
+ { "elt" object }
+ { "?" boolean } }
+{ $description "Checks whether the fourth element of " { $snippet "seq" } " is equal to " { $snippet "elt" } "." } ;
+
+HELP: fourth?
+{ $values
+ { "seq" sequence }
+ { "quot" { $quotation ( ... elt -- ... ? ) } }
+ { "?" boolean } }
+{ $description "Tests whether the fourth element of " { $snippet "seq" } " satisfies the provided predicate." } ;
+
+HELP: <odds>
+{ $values { "seq" sequence } { "odds" odds } }
+{ $description "Create a virtual sequence whose elements consist of the odd-indexed elements from the original sequence." }
+{ $notes "Because sequences are zero-indexed, this collection includes the second, fourth, sixth, etc. elements of the actual sequence which can be counterintuitive." }
+{ $see-also <evens> } ;
+
+HELP: >resizable
+{ $values { "seq" sequence } { "accum" sequence } }
+{ $description "Converts a sequence into the nearest resizable equivalent, preserving its contents." } ;
+
+HELP: second=
+{ $values
+ { "seq" sequence }
+ { "elt" object }
+ { "?" boolean } }
+{ $description "Checks whether the second element of " { $snippet "seq" } " is equal to " { $snippet "elt" } "." } ;
+
+HELP: second?
+{ $values
+ { "seq" sequence }
+ { "quot" { $quotation ( ... elt -- ... ? ) } }
+ { "?" boolean } }
+{ $description "Tests whether the second element of " { $snippet "seq" } " satisfies the provided predicate." } ;
+
+HELP: subseq*
+{ $values
+ { "from" integer } { "to" integer } { "seq" sequence } { "subseq" sequence } }
+{ $description "Outputs a new sequence using positions relative to one or both ends of the sequence. Positive values describes offsets relative to the start of the sequence, negative values relative to the end. Values of " { $link f } " for " { $snippet "from" } " indicate the beginning of the sequence, while an " { $link f } " for " { $snippet "to" } " indicates the end of the sequence." }
+{ $notes "Both " { $snippet "from" } " and " { $snippet "to" } " can be safely set to values outside the length of the sequence. Also, " { $snippet "from" } " can safely reference a smaller or greater index position than " { $snippet "to" } "." }
+{ $examples
+ "Using a negative relative index:"
+ { $example "USING: prettyprint sequences.extras ; 2 -1 \"abcdefg\" subseq* ."
+ "\"cdef\""
+ }
+ "Using optional indices:"
+ { $example "USING: prettyprint sequences.extras ; f -4 \"abcdefg\" subseq* ."
+ "\"abc\""
+ }
+ "Using larger-than-necessary indices:"
+ { $example "USING: prettyprint sequences.extras ; 0 10 \"abcdefg\" subseq* ."
+ "\"abcdefg\""
+ }
+ "Trimming from either end of the sequence."
+ { $example "USING: prettyprint sequences.extras ; 1 -1 \"abcdefg\" subseq* ."
+ "\"bcdef\""
+ }
+} ;
+
+HELP: third=
+{ $values
+ { "seq" sequence }
+ { "elt" object }
+ { "?" boolean } }
+{ $description "Checks whether the third element of " { $snippet "seq" } " is equal to " { $snippet "elt" } "." } ;
+
+HELP: third?
+{ $values
+ { "seq" sequence }
+ { "quot" { $quotation ( ... elt -- ... ? ) } }
+ { "?" boolean } }
+{ $description "Tests whether the third element of " { $snippet "seq" } " satisfies the provided predicate." } ;
+
+HELP: unsurround
+{ $values
+ { "newseq" sequence }
+ { "seq2" sequence }
+ { "seq3" sequence }
+ { "seq1" sequence } }
+{ $description "Reverses the result of a " { $link surround } " call, stripping off the prefix " { $snippet "seq2" } " and suffix " { $snippet "seq3" } " to restore the original sequence " { $snippet "seq" } "." }
+{ $see-also surround } ;
+
+HELP: start-all
+{ $values
+ { "subseq" sequence } { "seq" sequence } { "indices" sequence } }
+{ $description "Outputs the starting indices of the non-overlapping occurrences of " { $snippet "subseq" } " in " { $snippet "seq" } "." }
+{ $examples
+ { $example "USING: prettyprint sequences.extras ; \"ABA\" \"ABABA\" start-all ."
+ "{ 0 }"
+ }
+ { $example "USING: prettyprint sequences.extras ; \"ABA\" \"ABAABA\" start-all ."
+ "{ 0 3 }"
+ }
+ } ;
+
+HELP: start-all*
+{ $values
+ { "subseq" sequence } { "seq" sequence } { "indices" sequence } }
+{ $description "Outputs the starting indices of the possibly overlapping occurrences of " { $snippet "subseq" } " in " { $snippet "seq" } "." }
+{ $examples
+ { $example "USING: prettyprint sequences.extras ; \"ABA\" \"ABABA\" start-all* ."
+ "{ 0 2 }"
+ } } ;
+
+HELP: arg-max
+{ $values { "seq" sequence } { "n" integer } }
+{ $description "Outputs the sequence with the largest item." } ;
+
+HELP: arg-min
+{ $values { "seq" sequence } { "n" integer } }
+{ $description "Outputs the sequence with the smallest item." } ;
+
+{ arg-max arg-min } related-words
+
+HELP: count-subseq
+{ $values
+ { "subseq" sequence } { "seq" sequence } { "n" integer } }
+{ $description "Outputs the number of non-overlapping occurrences of " { $snippet "subseq" } " in " { $snippet "seq" } "." }
+{ $examples
+ { $example "USING: prettyprint sequences.extras ; \"ABA\" \"ABABA\" count-subseq ."
+ "1"
+ } } ;
+
+
+HELP: count-subseq*
+{ $values
+ { "subseq" sequence } { "seq" sequence } { "n" integer } }
+{ $description "Outputs the number of possibly overlapping occurrences of " { $snippet "subseq" } " in " { $snippet "seq" } "." }
+{ $examples
+ { $example "USING: prettyprint sequences.extras ; \"ABA\" \"ABABA\" count-subseq* ."
+ "2"
+ } } ;
+
+{ start-all start-all* count-subseq count-subseq* } related-words
--- /dev/null
+USING: accessors arrays ascii io io.streams.string kernel make
+math math.vectors random sequences sequences.extras strings
+tools.test vectors vocabs ;
+
+{ V{ { 0 104 } { 2 108 } { 3 108 } } } [ "hello" [ even? ] find-all ] unit-test
+
+{ { "a" "b" "c" "d" "ab" "bc" "cd" "abc" "bcd" "abcd" } } [ "abcd" all-subseqs ] unit-test
+
+{ { "a" "ab" "abc" "abcd" "b" "bc" "bcd" "c" "cd" "d" } }
+[ [ "abcd" [ , ] each-subseq ] { } make ] unit-test
+
+{ B{ 115 } } [ 1 2 "asdf" B{ } subseq-as ] unit-test
+
+{ "" } [ "abc" "def" longest-subseq ] unit-test
+{ "abcd" } [ "abcd" "abcde" longest-subseq ] unit-test
+{ "foo" } [ "foo" "foobar" longest-subseq ] unit-test
+{ "foo" } [ "foobar" "foo" longest-subseq ] unit-test
+
+{ "" "" } [ "" "" CHAR: ? pad-longest ] unit-test
+{ "abc" "def" } [ "abc" "def" CHAR: ? pad-longest ] unit-test
+{ " " "abc" } [ "" "abc" CHAR: \s pad-longest ] unit-test
+{ "abc" " " } [ "abc" "" CHAR: \s pad-longest ] unit-test
+{ "abc..." "foobar" } [ "abc" "foobar" CHAR: . pad-longest ] unit-test
+
+{
+ {
+ "ABC"
+ "ABC"
+ "ABC"
+ "ABC"
+ "ABC-"
+ "-ABC-"
+ "-ABC--"
+ "--ABC--"
+ }
+} [
+ "ABC" 8 <iota> [ CHAR: - pad-center ] with map
+] unit-test
+
+{ { 0 1 0 1 } } [
+ { 0 0 0 0 } { 1 3 } over [ 1 + ] change-nths
+] unit-test
+
+{ V{ f t f } } [
+ { 1 2 3 } [ even? ] selector* [ each ] dip
+] unit-test
+
+{ { 1 3 5 } } [ { 1 2 3 4 5 6 } [ nip even? ] filter-index ] unit-test
+
+{ V{ 1 3 5 } } [ { 1 2 3 4 5 6 } [ nip even? ] V{ } filter-index-as ] unit-test
+
+{ { 1 3 5 } } [ { 1 2 3 4 5 6 } even-indices ] unit-test
+
+{ { 2 4 6 } } [ { 1 2 3 4 5 6 } odd-indices ] unit-test
+
+{ "a b c d e" }
+[ "a b \t \n \r c d \n e " [ blank? ] " " compact ] unit-test
+
+{ " a b c d e " }
+[ " a b c d e " [ blank? ] " " collapse ] unit-test
+
+{ { "hello," " " "world!" " " " " } }
+[ "hello, world! " [ blank? ] slice-when [ >string ] map ] unit-test
+
+{ t }
+[ "abc" sequence>slice slice? ] unit-test
+
+{ "abc" }
+[ "abc" sequence>slice >string ] unit-test
+
+{ t } [ "abcdef" [ 0 3 rot <slice> ] [ 2 4 rot <slice> ] bi slices-overlap? ] unit-test
+{ t } [ "abcdef" [ 0 3 rot <slice> ] [ 1 2 rot <slice> ] bi slices-overlap? ] unit-test
+{ f } [ "abcdef" [ 0 3 rot <slice> ] [ 3 6 rot <slice> ] bi slices-overlap? ] unit-test
+{ t } [ "abcdef" [ 0 3 rot <slice> ] [ 2 4 rot <slice> ] bi slices-touch? ] unit-test
+{ t } [ "abcdef" [ 0 3 rot <slice> ] [ 1 2 rot <slice> ] bi slices-touch? ] unit-test
+{ t } [ "abcdef" [ 0 3 rot <slice> ] [ 3 6 rot <slice> ] bi slices-touch? ] unit-test
+{ f } [ "abcdef" [ 0 3 rot <slice> ] [ 4 6 rot <slice> ] bi slices-touch? ] unit-test
+
+{ "abcdef" } [
+ "abcdef" [ 0 3 rot <slice> ] [ 3 6 rot <slice> ] bi merge-slices >string
+] unit-test
+
+{ "abcdef" } [
+ "abcdef" [ 3 6 rot <slice> ] [ 0 3 rot <slice> ] bi merge-slices >string
+] unit-test
+
+{ "abc" } [
+ "abcdef" [ 0 3 rot <slice> ] [ 0 3 rot <slice> ] bi merge-slices >string
+] unit-test
+
+
+{ "hello" "hello" } [ "hello" dup 0 rotate ] unit-test
+{ "hello" "llohe" } [ "hello" dup 2 rotate ] unit-test
+{ "hello" "lohel" } [ "hello" dup 13 rotate ] unit-test
+{ "hello" "ohell" } [ "hello" dup -1 rotate ] unit-test
+{ "hello" "lohel" } [ "hello" dup -12 rotate ] unit-test
+
+{ "hello" } [ "hello" dup 0 rotate! ] unit-test
+{ "llohe" } [ "hello" dup 2 rotate! ] unit-test
+{ "lohel" } [ "hello" dup 13 rotate! ] unit-test
+{ "ohell" } [ "hello" dup -1 rotate! ] unit-test
+{ "lohel" } [ "hello" dup -12 rotate! ] unit-test
+
+{ { } } [ { } [ ] map-concat ] unit-test
+{ V{ 0 0 1 0 1 2 } } [ 4 <iota> [ <iota> ] map-concat ] unit-test
+{ "abc" } [ "abc" [ 1string ] map-concat ] unit-test
+{ "abc" } [ { 97 98 99 } [ 1string ] map-concat ] unit-test
+{ { 97 98 99 } } [ "abc" [ 1string ] { } map-concat-as ] unit-test
+{ "baz" { "foobaz" "barbaz" } }
+[ "baz" { { "foo" } { "bar" } } [ [ over append ] map ] map-concat ] unit-test
+
+{ { } } [ { } [ ] [ even? ] map-filter ] unit-test
+{ "bcde" } [ "abcd" [ 1 + ] [ drop t ] map-filter ] unit-test
+{ { 0 4 16 36 64 } } [ 10 <iota> [ sq ] [ even? ] { } map-filter-as ] unit-test
+
+{ V{ 0 4 16 36 64 } } [ 10 <iota> [ even? ] [ sq ] filter-map ] unit-test
+{ { 2 6 10 14 18 } } [ 10 <iota> [ odd? ] [ 2 * ] { } filter-map-as ] unit-test
+
+{ 8 } [ 3 <iota> dup [ 1 + * ] 2map-sum ] unit-test
+{ 4 } [ "hello" "jello" [ = ] 2count ] unit-test
+
+{ { } } [ { } round-robin ] unit-test
+{ "ADEBFC" } [ { "ABC" "D" "EF" } round-robin >string ] unit-test
+
+{ { } } [ "ABC" [ ] { } trim-as ] unit-test
+{ "ABC" } [ { 32 65 66 67 32 } [ blank? ] "" trim-as ] unit-test
+
+{ t } [ "ABC" dup [ blank? ] ?trim [ identity-hashcode ] same? ] unit-test
+{ "ABC" } [ " ABC " [ blank? ] ?trim ] unit-test
+
+{ t } [ "ABC" dup [ blank? ] ?trim-head [ identity-hashcode ] same? ] unit-test
+{ t } [ "ABC" dup [ blank? ] ?trim-tail [ identity-hashcode ] same? ] unit-test
+{ "ABC " } [ " ABC " [ blank? ] ?trim-head ] unit-test
+{ " ABC" } [ " ABC " [ blank? ] ?trim-tail ] unit-test
+
+{ "" } [ "" "" "" unsurround ] unit-test
+{ "" } [ " " " " " " unsurround ] unit-test
+{ "foo.com" } [ "http://foo.com" "http://" "/" unsurround ] unit-test
+
+{ t } [ { 1 3 5 7 } [ even? ] none? ] unit-test
+{ f } [ { 1 2 3 4 } [ even? ] none? ] unit-test
+{ t } [ { } [ even? ] none? ] unit-test
+
+{ f } [ { 1 2 3 4 } [ even? ] one? ] unit-test
+{ t } [ { 1 2 3 } [ even? ] one? ] unit-test
+{ f } [ { } [ even? ] one? ] unit-test
+
+{ { { 5 8 0 } { 6 9 1 } { 7 10 2 } } } [ { 5 6 7 } { 8 9 10 } [ 3array ] 2map-index ] unit-test
+
+{ { } } [ { } <evens> >array ] unit-test
+{ { 0 2 } } [ 4 <iota> <evens> >array ] unit-test
+{ { 0 2 4 } } [ 5 <iota> <evens> >array ] unit-test
+{ "bbddff" } [ "abcdef" <evens> [ 1 + ] map! seq>> ] unit-test
+
+{ { } } [ { } <odds> >array ] unit-test
+{ { 1 3 } } [ 5 <iota> <odds> >array ] unit-test
+{ { 1 3 5 } } [ 6 <iota> <odds> >array ] unit-test
+{ "acceeg" } [ "abcdef" <odds> [ 1 + ] map! seq>> ] unit-test
+
+{ 1 } [ { 1 7 3 7 6 3 7 } arg-max ] unit-test
+{ 2 } [ { 0 1 99 } arg-max ] unit-test
+{ 0 } [ { 1 7 3 7 6 3 7 } arg-min ] unit-test
+{ V{ 0 4 } } [ { 5 3 2 10 5 } [ 5 = ] arg-where ] unit-test
+{ { 2 1 0 4 3 } } [ { 5 3 2 10 5 } arg-sort ] unit-test
+
+{ t } [ { 1 2 3 4 5 } 1 first= ] unit-test
+{ t } [ { 1 2 3 4 5 } 2 second= ] unit-test
+{ t } [ { 1 2 3 4 5 } 3 third= ] unit-test
+{ t } [ { 1 2 3 4 5 } 4 fourth= ] unit-test
+{ t } [ { 1 2 3 4 5 } 5 last= ] unit-test
+{ t } [ 4 { 1 2 3 4 5 } 5 nth= ] unit-test
+
+{ t } [ { 1 2 3 4 5 } [ 1 = ] first? ] unit-test
+{ t } [ { 1 2 3 4 5 } [ 2 = ] second? ] unit-test
+{ t } [ { 1 2 3 4 5 } [ 3 = ] third? ] unit-test
+{ t } [ { 1 2 3 4 5 } [ 4 = ] fourth? ] unit-test
+{ t } [ { 1 2 3 4 5 } [ 5 = ] last? ] unit-test
+{ t } [ 4 { 1 2 3 4 5 } [ 5 = ] nth? ] unit-test
+
+{ { 97 115 100 102 } } [
+ "asdf" [ [ read1 ] loop>array ] with-string-reader
+] unit-test
+
+{ V{ 97 115 100 102 } } [
+ "asdf" [ [ read1 ] V{ } loop>sequence ] with-string-reader
+] unit-test
+
+{ "" } [ { } "" reverse-as ] unit-test
+{ "ABC" } [ { 67 66 65 } "" reverse-as ] unit-test
+
+{ V{ 1 } } [ 1 0 V{ } [ insert-nth! ] keep ] unit-test
+{ V{ 1 2 3 4 } } [ 2 1 V{ 1 3 4 } [ insert-nth! ] keep ] unit-test
+
+{ "abc" } [ B{ 97 98 99 100 101 102 103 } 3 "" head-as ] unit-test
+{ "abcd" } [ B{ 97 98 99 100 101 102 103 } 3 "" head*-as ] unit-test
+{ "defg" } [ B{ 97 98 99 100 101 102 103 } 3 "" tail-as ] unit-test
+{ "efg" } [ B{ 97 98 99 100 101 102 103 } 3 "" tail*-as ] unit-test
+
+{ { 1 0 0 1 0 0 0 1 0 0 } }
+[ 1 { 0 3 7 } 10 0 <array> [ set-nths ] keep ] unit-test
+
+{ { 1 0 0 1 0 0 0 1 0 0 } }
+[ 1 { 0 3 7 } 10 0 <array> [ set-nths-unsafe ] keep ] unit-test
+
+{ V{ 1 } } [ 1 flatten1 ] unit-test
+{ { 1 2 3 } } [ { 1 2 3 } flatten1 ] unit-test
+{ { 1 2 3 { { 4 } } } } [ { 1 { 2 } { 3 { { 4 } } } } flatten1 ] unit-test
+
+{ t 3 3 } [ 10 <iota> [ [ odd? ] [ 1 > ] bi* and ] map-find-index ] unit-test
+{ f f f } [ 10 <iota> [ [ odd? ] [ 9 > ] bi* and ] map-find-index ] unit-test
+
+{ "abcdef" } [ f f "abcdef" subseq* ] unit-test
+{ "abcdef" } [ 0 f "abcdef" subseq* ] unit-test
+{ "ab" } [ f 2 "abcdef" subseq* ] unit-test
+{ "cdef" } [ 2 f "abcdef" subseq* ] unit-test
+{ "cd" } [ -4 -2 "abcdef" subseq* ] unit-test
+
+{ "foo" "" } [ "foo" [ blank? ] cut-when ] unit-test
+{ "foo" " " } [ "foo " [ blank? ] cut-when ] unit-test
+{ "" " foo" } [ " foo" [ blank? ] cut-when ] unit-test
+{ "foo" " bar" } [ "foo bar" [ blank? ] cut-when ] unit-test
+
+{ { 4 0 3 1 2 } } [ { 0 4 1 3 2 } 5 <iota> [ nth* ] curry map ] unit-test
+
+{ 1 "beef" } [ { "chicken" "beef" "moose" } [ length ] infimum-by* ] unit-test
+{ 0 "chicken" } [ { "chicken" "beef" "moose" } [ length ] supremum-by* ] unit-test
+{ 2 "moose" } [ { "chicken" "beef" "moose" } [ first ] supremum-by* ] unit-test
+{ f } [ f ?supremum ] unit-test
+{ f } [ { } ?supremum ] unit-test
+{ f } [ { f } ?supremum ] unit-test
+{ 3 } [ { 1 f 3 2 } ?supremum ] unit-test
+{ 3 } [ { 1 3 2 } ?supremum ] unit-test
+{ f } [ f ?infimum ] unit-test
+{ f } [ { } ?infimum ] unit-test
+{ f } [ { f } ?infimum ] unit-test
+{ 1 } [ { 1 f 3 2 } ?infimum ] unit-test
+{ 1 } [ { 1 3 2 } ?infimum ] unit-test
+
+{ 3/10 } [ 10 <iota> [ 3 < ] count* ] unit-test
+
+{ { 0 } } [ "ABA" "ABABA" start-all ] unit-test
+{ { 0 2 } } [ "ABA" "ABABA" start-all* ] unit-test
+{ { 0 3 } } [ "ABA" "ABAABA" start-all ] unit-test
+{ 1 } [ "ABA" "ABABA" count-subseq ] unit-test
+{ 2 } [ "ABA" "ABABA" count-subseq* ] unit-test
+
+{ 120000 } [ { 10 20 30 40 50 60 } 1 [ * ] 3 reduce-from ] unit-test
+
+{
+ {
+ { 2 4 }
+ { 3 6 }
+ { 4 8 }
+ }
+} [ { 2 3 4 } [ 2 * ] map-zip ] unit-test
+
+{ }
+[ "test:" all-words [ name>> over prepend ] map-zip 2drop ] unit-test
+
+{ { 0 1 2 3 } } [ 8 <iota> [ 4 < ] take-while >array ] unit-test
+{ { } } [ { 15 16 } [ 4 < ] take-while >array ] unit-test
+{ { 0 1 2 } } [ 3 <iota> [ 4 < ] take-while >array ] unit-test
+
+{ { 4 5 6 7 } } [ 8 <iota> [ 4 < ] drop-while >array ] unit-test
+{ { 15 16 } } [ { 15 16 } [ 4 < ] drop-while >array ] unit-test
+{ { } } [ 3 <iota> [ 4 < ] drop-while >array ] unit-test
+
+{ { } } [ { } ", " interleaved ] unit-test
+{ { 1 } } [ { 1 } ", " interleaved ] unit-test
+{ { 1 ", " 2 } } [ { 1 2 } ", " interleaved ] unit-test
+{ "" } [ "" CHAR: _ interleaved ] unit-test
+{ "a" } [ "a" CHAR: _ interleaved ] unit-test
+{ "a_b" } [ "ab" CHAR: _ interleaved ] unit-test
+{ "a_b_c" } [ "abc" CHAR: _ interleaved ] unit-test
+{ "a_b_c_d" } [ "abcd" CHAR: _ interleaved ] unit-test
+
+{ 0 } [ { 1 2 3 4 } [ 5 > ] count-head ] unit-test
+{ 2 } [ { 1 2 3 4 } [ 3 < ] count-head ] unit-test
+{ 4 } [ { 1 2 3 4 } [ 5 < ] count-head ] unit-test
+
+{ 0 } [ { 1 2 3 4 } [ 5 > ] count-tail ] unit-test
+{ 2 } [ { 1 2 3 4 } [ 2 > ] count-tail ] unit-test
+{ 4 } [ { 1 2 3 4 } [ 5 < ] count-tail ] unit-test
+
+{ SBUF" aco" SBUF" ftr" } [ SBUF" factor" dup [ even? ] extract! ] unit-test
--- /dev/null
+USING: accessors arrays assocs combinators fry generalizations
+grouping growable kernel locals make math math.order math.ranges
+sequences sequences.deep sequences.private sorting splitting
+vectors ;
+IN: sequences.extras
+
+: find-all ( ... seq quot: ( ... elt -- ... ? ) -- ... elts )
+ [ <enumerated> ] dip '[ nip @ ] assoc-filter ; inline
+
+: reduce-from ( ... seq identity quot: ( ... prev elt -- ... next ) i -- ... result )
+ [ swap ] 2dip each-from ; inline
+
+:: 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 ;
+
+: safe-subseq ( from to seq -- subseq )
+ [ length '[ 0 _ clamp ] bi@ ] keep subseq ;
+
+: 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
+
+: map-like ( seq exemplar -- seq' )
+ '[ _ like ] map ; inline
+
+: filter-all-subseqs-range ( ... seq range quot: ( ... subseq -- ... ) -- seq )
+ [
+ '[ <clumps> _ filter ] with map concat
+ ] keepdd map-like ; inline
+
+: filter-all-subseqs ( ... seq quot: ( ... subseq -- ... ) -- seq )
+ [ dup length [1,b] ] dip filter-all-subseqs-range ; inline
+
+:: longest-subseq ( seq1 seq2 -- subseq )
+ seq1 length :> len1
+ seq2 length :> len2
+ 0 :> n!
+ 0 :> end!
+ len1 1 + [ len2 1 + 0 <array> ] replicate :> table
+ len1 [1,b] [| x |
+ len2 [1,b] [| y |
+ x 1 - seq1 nth-unsafe
+ y 1 - seq2 nth-unsafe = [
+ y 1 - x 1 - table nth-unsafe nth-unsafe 1 + :> len
+ len y x table nth-unsafe set-nth-unsafe
+ len n > [ len n! x end! ] when
+ ] [ 0 y x table nth-unsafe set-nth-unsafe ] if
+ ] each
+ ] each end n - end seq1 subseq ;
+
+: pad-longest ( seq1 seq2 elt -- seq1 seq2 )
+ [ 2dup max-length ] dip [ pad-tail ] 2curry bi@ ;
+
+:: pad-center ( seq n elt -- padded )
+ n seq length [-] :> extra
+ extra 2/ :> left
+ extra left - :> right
+ left elt <repetition> seq right elt <repetition>
+ seq 3append-as ;
+
+: change-nths ( ... indices seq quot: ( ... elt -- ... elt' ) -- ... )
+ [ change-nth ] 2curry each ; inline
+
+: push-if-index ( ..a elt i quot: ( ..a elt i -- ..b ? ) accum -- ..b )
+ [ keepd ] dip rot [ push ] [ 2drop ] if ; inline
+
+: push-if* ( ..a elt quot: ( ..a elt -- ..b obj/f ) accum -- ..b )
+ [ call ] dip [ push ] [ drop ] if* ; inline
+
+<PRIVATE
+
+: (index-selector-as) ( quot length exampler -- selector accum )
+ new-resizable [ [ push-if-index ] 2curry ] keep ; inline
+
+: (selector-as*) ( quot length exemplar -- selector accum )
+ new-resizable [ [ push-if* ] 2curry ] keep ; inline
+
+PRIVATE>
+
+: index-selector-as ( quot exemplar -- selector accum )
+ [ length ] keep (index-selector-as) ; inline
+
+: index-selector ( quot -- selector accum )
+ V{ } index-selector-as ; inline
+
+: selector-as* ( quot exemplar -- selector accum )
+ [ length ] keep (selector-as*) ; inline
+
+: selector* ( quot -- selector accum ) V{ } selector-as* ; inline
+
+: filter-index-as ( ... seq quot: ( ... elt i -- ... ? ) exemplar -- ... seq' )
+ pick length over [ (index-selector-as) [ each-index ] dip ] 2curry dip like ; inline
+
+: filter-index ( ... seq quot: ( ... elt i -- ... ? ) -- ... seq' )
+ over filter-index-as ; inline
+
+: even-indices ( seq -- seq' )
+ [ length 1 + 2/ ] keep [
+ [ [ 2 * ] dip nth-unsafe ] curry
+ ] keep map-integers ;
+
+: odd-indices ( seq -- seq' )
+ [ length 2/ ] keep [
+ [ [ 2 * 1 + ] dip nth-unsafe ] curry
+ ] keep map-integers ;
+
+: compact ( ... seq quot: ( ... elt -- ... ? ) elt -- ... seq' )
+ [ split-when harvest ] dip join ; inline
+
+: collapse ( ... seq quot: ( ... elt -- ... ? ) elt -- ... seq' )
+ [ split-when ] dip
+ [ [ harvest ] dip join ]
+ [ [ first empty? ] dip [ prepend ] curry when ]
+ [ [ last empty? ] dip [ append ] curry when ]
+ 2tri ; inline
+
+:: slice-when ( seq quot: ( elt -- ? ) -- seq' )
+ seq length :> len
+ 0 [ len dupd < ] [
+ dup seq quot find-from drop
+ [ 2dup = [ 1 + ] when ] [ len ] if*
+ [ seq <slice> ] keep len or swap
+ ] produce nip ; inline
+
+: cut-slice* ( seq n -- before after )
+ [ head-slice* ] [ tail-slice* ] 2bi ;
+
+: ?<slice> ( from/f to/f sequence -- slice )
+ [ [ 0 ] unless* ] 2dip
+ over [ nip [ length ] [ ] bi ] unless
+ <slice> ; inline
+
+: sequence>slice ( sequence -- slice )
+ [ drop 0 ] [ length ] [ ] tri <slice> ; inline
+
+: slice-order-by-from ( slice1 slice2 -- slice-lt slice-gt )
+ 2dup [ from>> ] bi@ > [ swap ] when ; inline
+
+: ordered-slices-range ( slice-lt slice-gt -- to from )
+ [ to>> ] [ from>> ] bi* ;
+
+: unordered-slices-range ( slice1 slice2 -- to from )
+ slice-order-by-from ordered-slices-range ;
+
+: ordered-slices-overlap? ( slice-lt slice-gt -- ? )
+ ordered-slices-range > ; inline
+
+: unordered-slices-overlap? ( slice1 slice2 -- ? )
+ unordered-slices-range > ; inline
+
+: slices-overlap? ( slice1 slice2 -- ? )
+ unordered-slices-overlap? ;
+
+: ordered-slices-touch? ( slice-lt slice-gt -- ? )
+ ordered-slices-range >= ; inline
+
+: unordered-slices-touch? ( slice1 slice2 -- ? )
+ unordered-slices-range >= ; inline
+
+: slices-touch? ( slice1 slice2 -- ? )
+ unordered-slices-touch? ;
+
+ERROR: slices-don't-touch slice1 slice2 ;
+
+: merge-slices ( slice1 slice2 -- slice/* )
+ slice-order-by-from
+ 2dup ordered-slices-touch? [
+ [ from>> ] [ [ to>> ] [ seq>> ] bi ] bi* <slice>
+ ] [
+ slices-don't-touch
+ ] if ;
+
+: rotate ( seq n -- seq' )
+ over length mod dup 0 >= [ cut ] [ abs cut* ] if prepend ;
+
+ERROR: underlying-mismatch slice1 slice2 ;
+
+: ensure-same-underlying ( slice1 slice2 -- slice1 slice2 )
+ 2dup [ seq>> ] bi@ eq? [ underlying-mismatch ] unless ;
+
+: span-slices ( slice1 slice2 -- slice )
+ ensure-same-underlying
+ [ [ from>> ] bi@ min ]
+ [ [ to>> ] bi@ max ]
+ [ drop seq>> ] 2tri <slice> ;
+
+: ?span-slices ( slice1/f slice2/f -- slice )
+ 2dup and [ span-slices ] [ or ] if ;
+
+:: rotate! ( seq n -- )
+ seq length :> len
+ n len mod dup 0 < [ len + ] when seq bounds-check drop 0 over
+ [ 2dup = ] [
+ [ seq exchange-unsafe ] [ [ 1 + ] bi@ ] 2bi
+ dup len = [ drop over ] when
+ 2over = [ -rot nip over ] when
+ ] until 3drop ;
+
+: all-rotations ( seq -- seq' )
+ dup length <iota> [ rotate ] with map ;
+
+<PRIVATE
+
+: (appender-for) ( quot length exemplar -- appender accum )
+ new-resizable [ [ push-all ] curry compose ] keep ; inline
+
+PRIVATE>
+
+: appender-for ( quot exemplar -- appender accum )
+ [ length ] keep (appender-for) ; inline
+
+: appender ( quot -- appender accum )
+ V{ } appender-for ; inline
+
+: map-concat-as ( ... seq quot: ( ... elt -- ... newelt ) exemplar -- ... newseq )
+ [ appender-for [ each ] dip ] keep like ; inline
+
+: >resizable ( seq -- accum ) ! fixes map-concat "cannot apply call to run-time..."
+ [ length ] keep [ new-resizable ] [ append! ] bi ;
+
+: map-concat ( ... seq quot: ( ... elt -- ... newelt ) -- ... newseq )
+ over empty? [ 2drop { } ] [
+ [ [ first ] dip call ] 2keep rot [
+ >resizable [ '[ @ _ push-all ] 1 each-from ] keep
+ ] keep like
+ ] if ; inline
+
+: map-filter-as ( ... seq map-quot: ( ... elt -- ... newelt ) filter-quot: ( ... newelt -- ... ? ) exemplar -- ... subseq )
+ reach length over
+ [ (selector-as) [ compose each ] dip ] 2curry dip like ; inline
+
+: map-filter ( ... seq map-quot: ( ... elt -- ... newelt ) filter-quot: ( ... newelt -- ... ? ) -- ... subseq )
+ pick map-filter-as ; inline
+
+: map-sift ( ... seq quot: ( ... elt -- ... newelt ) -- ... newseq )
+ [ ] map-filter ; inline
+
+: map-harvest ( ... seq quot: ( ... elt -- ... newelt ) -- ... newseq )
+ [ empty? not ] map-filter ; inline
+
+<PRIVATE
+
+: (setup-each-from) ( i seq -- n quot )
+ [ length over [-] swap ] keep '[ _ + _ nth-unsafe ] ; inline
+
+: setup-each-from ( i seq quot -- n quot' )
+ [ (setup-each-from) ] dip compose ; inline
+
+PRIVATE>
+
+: map-from-as ( ... seq quot: ( ... elt -- ... newelt ) i exemplar -- ... newseq )
+ [ -rot setup-each-from ] dip map-integers ; inline
+
+: map-from ( ... seq quot: ( ... elt -- ... newelt ) i -- ... newseq )
+ pick map-from-as ; inline
+
+<PRIVATE
+
+: push-map-if ( ..a elt filter-quot: ( ..a elt -- ..b ? ) map-quot: ( ..a elt -- ..b newelt ) accum -- ..b )
+ [ keep over ] 2dip [ when ] dip rot [ push ] [ 2drop ] if ; inline
+
+: (filter-mapper-for) ( filter-quot map-quot length exempler -- filter-mapper accum )
+ new-resizable [ [ push-map-if ] 3curry ] keep ; inline
+
+: filter-mapper-for ( filter-quot map-quot exemplar -- filter-mapper accum )
+ [ length ] keep (filter-mapper-for) ; inline
+
+: filter-mapper ( filter-quot map-quot -- filter-mapper accum )
+ V{ } filter-mapper-for ; inline
+
+PRIVATE>
+
+: filter-map-as ( ... seq filter-quot: ( ... elt -- ... ? ) map-quot: ( ... elt -- ... newelt ) exemplar -- ... newseq )
+ reach length over
+ [ (filter-mapper-for) [ each ] dip ] 2curry dip like ; inline
+
+: filter-map ( ... seq filter-quot: ( ... elt -- ... ? ) map-quot: ( ... elt -- ... newelt ) -- ... newseq )
+ pick filter-map-as ; inline
+
+: 2map-sum ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... n ) -- ... n )
+ [ 0 ] 3dip [ dip + ] curry [ rot ] prepose 2each ; inline
+
+: 2count ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... ? ) -- ... n )
+ [ 1 0 ? ] compose 2map-sum ; inline
+
+: 3each-from
+ ( ... seq1 seq2 seq3 quot: ( ... elt1 elt2 elt3 -- ... ) i -- ... )
+ [ (3each) ] dip -rot (each-integer) ; inline
+
+: 3map-reduce
+ ( ..a seq1 seq2 seq3 map-quot: ( ..a elt1 elt2 elt3 -- ..b intermediate ) reduce-quot: ( ..b prev intermediate -- ..a next ) -- ..a result )
+ [ [ [ [ first ] tri@ ] 3keep ] dip [ 3dip ] keep ] dip compose 1 3each-from ; inline
+
+: round-robin ( seq -- newseq )
+ [ { } ] [
+ [ longest length <iota> ] keep
+ [ [ ?nth ] with map ] curry map concat sift
+ ] if-empty ;
+
+: sift-as ( seq exemplar -- newseq )
+ [ ] swap filter-as ;
+
+: sift! ( seq -- newseq )
+ [ ] filter! ;
+
+: harvest-as ( seq exemplar -- newseq )
+ [ empty? not ] swap filter-as ;
+
+: harvest! ( seq -- newseq )
+ [ empty? ] reject! ;
+
+: head-as ( seq n exemplar -- seq' )
+ [ head-slice ] [ like ] bi* ; inline
+
+: head*-as ( seq n exemplar -- seq' )
+ [ head-slice* ] [ like ] bi* ; inline
+
+: tail-as ( seq n exemplar -- seq' )
+ [ tail-slice ] [ like ] bi* ; inline
+
+: tail*-as ( seq n exemplar -- seq' )
+ [ tail-slice* ] [ like ] bi* ; inline
+
+: trim-as ( ... seq quot: ( ... elt -- ... ? ) exemplar -- ... newseq )
+ [ trim-slice ] [ like ] bi* ; inline
+
+: ?trim ( seq quot: ( elt -- ? ) -- seq/newseq )
+ over empty? [ drop ] [
+ over [ first-unsafe ] [ last-unsafe ] bi pick either?
+ [ trim ] [ drop ] if
+ ] if ; inline
+
+: ?trim-head ( seq quot: ( elt -- ? ) -- seq/newseq )
+ over empty? [ drop ] [
+ over first-unsafe over call
+ [ trim-head ] [ drop ] if
+ ] if ; inline
+
+: ?trim-tail ( seq quot: ( elt -- ? ) -- seq/newseq )
+ over empty? [ drop ] [
+ over last-unsafe over call
+ [ trim-tail ] [ drop ] if
+ ] if ; inline
+
+: unsurround ( newseq seq2 seq3 -- seq1 )
+ [ ?head drop ] [ ?tail drop ] bi* ;
+
+: 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
+
+<PRIVATE
+
+: (2each-index) ( seq1 seq2 quot -- n quot' )
+ [ setup-2each [ keep ] curry ] dip compose ; inline
+
+PRIVATE>
+
+: 2each-index ( ... seq1 seq2 quot: ( ... elt1 elt2 index -- ... ) -- ... )
+ (2each-index) each-integer ; inline
+
+: 2map-into ( seq1 seq2 quot into -- )
+ [ (2each) ] dip collect ; inline
+
+: 2map! ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... newelt ) -- ... seq1 )
+ pick [ 2map-into ] keep ; inline
+
+: 2map-index ( ... seq1 seq2 quot: ( ... elt1 elt2 index -- ... newelt ) -- ... newseq )
+ pick [ (2each-index) ] dip map-integers ; inline
+
+TUPLE: evens { seq read-only } ;
+
+C: <evens> evens
+
+M: evens length seq>> length 1 + 2/ ; inline
+
+M: evens virtual@ [ 2 * ] [ seq>> ] bi* ; inline
+
+M: evens virtual-exemplar seq>> ; inline
+
+INSTANCE: evens virtual-sequence
+
+TUPLE: odds { seq read-only } ;
+
+C: <odds> odds
+
+M: odds length seq>> length 2/ ; inline
+
+M: odds virtual@ [ 2 * 1 + ] [ seq>> ] bi* ; inline
+
+M: odds virtual-exemplar seq>> ; inline
+
+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 ;
+
+<PRIVATE
+
+: push-index-if ( ..a elt i quot: ( ..a elt -- ..b ? ) accum -- ..b )
+ [ dip ] dip rot [ push ] [ 2drop ] if ; inline
+
+PRIVATE>
+
+: arg-where ( ... seq quot: ( ... elt -- ... ? ) -- ... indices )
+ over length <vector> [
+ [ push-index-if ] 2curry each-index
+ ] keep ; inline
+
+: arg-sort ( seq -- indices )
+ zip-index sort-keys values ;
+
+: first= ( seq elt -- ? ) [ first ] dip = ; inline
+: second= ( seq elt -- ? ) [ second ] dip = ; inline
+: third= ( seq elt -- ? ) [ third ] dip = ; inline
+: fourth= ( seq elt -- ? ) [ fourth ] dip = ; inline
+: last= ( seq elt -- ? ) [ last ] dip = ; inline
+: nth= ( n seq elt -- ? ) [ nth ] dip = ; inline
+
+: first? ( ... seq quot: ( ... elt -- ... ? ) -- ... ? ) [ first ] dip call ; inline
+: second? ( ... seq quot: ( ... elt -- ... ? ) -- ... ? ) [ second ] dip call ; inline
+: third? ( ... seq quot: ( ... elt -- ... ? ) -- ... ? ) [ third ] dip call ; inline
+: fourth? ( ... seq quot: ( ... elt -- ... ? ) -- ... ? ) [ fourth ] dip call ; inline
+: last? ( ... seq quot: ( ... elt -- ... ? ) -- ... ? ) [ last ] dip call ; inline
+: nth? ( ... n seq quot: ( ... elt -- ... ? ) -- ... ? ) [ nth ] dip call ; inline
+
+: loop>sequence ( quot: ( ..a -- ..a obj/f ) exemplar -- seq )
+ [ '[ [ @ [ [ , ] when* ] keep ] loop ] ] dip make ; inline
+
+: loop>array ( quot: ( ..a -- ..a obj/f ) -- seq )
+ { } loop>sequence ; inline
+
+: loop>sequence* ( quot: ( ..a -- ..a obj ? ) exemplar -- seq )
+ [ '[ [ @ [ [ , ] when* ] [ ] bi* ] loop ] ] dip make ; inline
+
+: loop>array* ( quot: ( ..a -- ..a obj ? ) -- seq )
+ { } loop>sequence* ; inline
+
+<PRIVATE
+
+: (reverse) ( seq -- newseq )
+ dup [ length ] keep new-sequence
+ [ 0 swap copy-unsafe ] keep reverse! ;
+
+PRIVATE>
+
+: reverse-as ( seq exemplar -- newseq )
+ [ (reverse) ] [ like ] bi* ;
+
+: map-product ( ... seq quot: ( ... elt -- ... n ) -- ... n )
+ [ 1 ] 2dip [ dip * ] curry [ swap ] prepose each ; inline
+
+: insert-nth! ( elt n seq -- )
+ [ length ] keep ensure swap pick (a,b]
+ over '[ [ 1 + ] keep _ move-unsafe ] each
+ set-nth-unsafe ;
+
+: set-nths ( value indices seq -- )
+ swapd '[ _ swap _ set-nth ] each ; inline
+
+: set-nths-unsafe ( value indices seq -- )
+ swapd '[ _ swap _ set-nth-unsafe ] each ; inline
+
+: flatten1 ( obj -- seq )
+ [
+ [
+ dup branch? [
+ [ dup branch? [ % ] [ , ] if ] each
+ ] [ , ] if
+ ]
+ ] keep dup branch? [ drop f ] unless make ;
+
+<PRIVATE
+
+: (map-find-index) ( seq quot find-quot -- result i elt )
+ [ [ f ] 2dip [ [ nip ] 2dip call dup ] curry ] dip call
+ [ [ [ drop f ] unless ] keep ] dip ; inline
+
+PRIVATE>
+
+: map-find-index ( ... seq quot: ( ... elt index -- ... result/f ) -- ... result i elt )
+ [ find-index ] (map-find-index) ; inline
+
+: filter-length ( seq n -- seq' ) '[ length _ = ] filter ;
+
+: all-shortest ( seqs -- seqs' ) dup shortest length filter-length ;
+
+: all-longest ( seqs -- seqs' ) dup longest length filter-length ;
+
+: remove-first ( obj seq -- seq' )
+ [ index ] keep over [ remove-nth ] [ nip ] if ;
+
+: remove-first! ( obj seq -- seq )
+ [ index ] keep over [ remove-nth! ] [ nip ] if ;
+
+: remove-last ( obj seq -- seq' )
+ [ last-index ] keep over [ remove-nth ] [ nip ] if ;
+
+: remove-last! ( obj seq -- seq )
+ [ last-index ] keep over [ remove-nth! ] [ nip ] if ;
+
+: ?first2 ( seq -- first/f second/f )
+ dup length {
+ { 0 [ drop f f ] }
+ { 1 [ first-unsafe f ] }
+ [ drop first2-unsafe ]
+ } case ;
+
+: ?first3 ( seq -- first/f second/f third/f )
+ dup length {
+ { 0 [ drop f f f ] }
+ { 1 [ first-unsafe f f ] }
+ { 2 [ first2-unsafe f ] }
+ [ drop first3-unsafe ]
+ } case ;
+
+: ?first4 ( seq -- first/f second/f third/f fourth/f )
+ dup length {
+ { 0 [ drop f f f f ] }
+ { 1 [ first-unsafe f f f ] }
+ { 2 [ first2-unsafe f f ] }
+ { 3 [ first3-unsafe f ] }
+ [ drop first4-unsafe ]
+ } case ;
+
+: cut-when ( ... seq quot: ( ... elt -- ... ? ) -- ... before after )
+ [ find drop ] keepd swap
+ [ cut ] [ f over like ] if* ; inline
+
+: nth* ( n seq -- elt )
+ [ length 1 - swap - ] [ nth ] bi ; inline
+
+: each-index-from ( ... seq quot: ( ... elt index -- ... ) i -- ... )
+ -rot (each-index) (each-integer) ; inline
+
+<PRIVATE
+
+: select-by* ( ... seq quot: ( ... elt -- ... x ) compare: ( obj1 obj2 -- ? ) -- ... i elt )
+ [
+ [ keep swap ] curry [ dip ] curry
+ [ [ first 0 ] dip call ] 2keep
+ [ 2curry 3dip 5 npick pick ] curry
+ ] [
+ [ [ 3drop ] [ [ 3drop ] 3dip ] if ] compose
+ ] bi* compose 1 each-index-from nip swap ; inline
+
+PRIVATE>
+
+: supremum-by* ( ... seq quot: ( ... elt -- ... x ) -- ... i elt )
+ [ after? ] select-by* ; inline
+
+: infimum-by* ( ... seq quot: ( ... elt -- ... x ) -- ... i elt )
+ [ before? ] select-by* ; inline
+
+: ?supremum ( seq/f -- elt/f )
+ [ f ] [
+ [ ] [ 2dup and [ max ] [ dupd ? ] if ] map-reduce
+ ] if-empty ;
+
+: ?infimum ( seq/f -- elt/f )
+ [ f ] [
+ [ ] [ 2dup and [ min ] [ dupd ? ] if ] map-reduce
+ ] if-empty ;
+
+: change-last ( seq quot -- )
+ [ drop length 1 - ] [ change-nth ] 2bi ; inline
+
+: change-last-unsafe ( seq quot -- )
+ [ drop length 1 - ] [ change-nth-unsafe ] 2bi ; inline
+
+: replicate-into ( ... seq quot: ( ... -- ... newelt ) -- ... )
+ over [ length ] 2dip '[ _ dip _ set-nth-unsafe ] each-integer ; inline
+
+: count* ( ... seq quot: ( ... elt -- ... ? ) -- ... % )
+ over [ count ] [ length ] bi* / ; inline
+
+: find-last-index ( ... seq quot: ( ... elt i -- ... ? ) -- ... i elt )
+ [ [ 1 - ] dip find-last-integer ] (find-index) ; inline
+
+: map-find-last-index ( ... seq quot: ( ... elt index -- ... result/f ) -- ... result i elt )
+ [ find-last-index ] (map-find-index) ; inline
+
+:: (start-all) ( subseq seq increment -- indices )
+ 0
+ [ [ subseq seq ] dip subseq-start-from dup ]
+ [ [ increment + ] keep ] produce nip ;
+
+: start-all ( subseq seq -- indices )
+ over length (start-all) ; inline
+
+: start-all* ( subseq seq -- indices )
+ 1 (start-all) ; inline
+
+: count-subseq ( subseq seq -- n )
+ start-all length ; inline
+
+: count-subseq* ( subseq seq -- n )
+ start-all* length ; inline
+
+: map-zip ( quot: ( x -- y ) -- alist )
+ '[ _ keep swap ] map>alist ; inline
+
+: map-keys ( assoc quot: ( key -- key' ) -- assoc )
+ '[ _ dip ] assoc-map ; inline
+
+: map-values ( assoc quot: ( value -- value' ) -- assoc )
+ '[ swap _ dip swap ] assoc-map ; inline
+
+: take-while ( ... seq quot: ( ... elt -- ... ? ) -- head-slice )
+ [ '[ @ not ] find drop ] keepd swap
+ [ dup length ] unless* head-slice ; inline
+
+: drop-while ( ... seq quot: ( ... elt -- ... ? ) -- tail-slice )
+ [ '[ @ not ] find drop ] keepd swap
+ [ dup length ] unless* tail-slice ; inline
+
+: count-head ( seq quot -- n )
+ [ not ] compose [ find drop ] 2keep drop length or ; inline
+
+: count-tail ( seq quot -- n )
+ [ not ] compose [ find-last drop ] 2keep drop
+ length swap [ - 1 - ] when* ; inline
+
+:: interleaved-as ( seq glue exemplar -- newseq )
+ seq length dup 1 - + 0 max exemplar new-sequence :> newseq
+ seq [ 2 * newseq set-nth-unsafe ] each-index
+ seq length 1 - [ 2 * 1 + glue swap newseq set-nth-unsafe ] each-integer
+ newseq ;
+
+: interleaved ( seq glue -- newseq )
+ over interleaved-as ;
+
+: extract! ( ... seq quot: ( ... elt -- ... ? ) -- ... seq )
+ [ dup ] compose over [ length ] keep new-resizable
+ [ [ push-if ] 2curry reject! ] keep swap like ; inline
--- /dev/null
+Contains sequence operations that are not commonly needed. Most of these words are elaborations on functions already available in the main sequences vocabulary.
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2013 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel sequences sets ;
+IN: sets.extras
+
+HELP: setwise-xor
+{ $values
+ { "seq1" sequence } { "seq2" sequence }
+ { "set" set }
+}
+{ $description "Converts the sequences to sets and takes the element-wise " { $link xor } ". Outputs elements that are in either set but not in both." }
+{ $example
+ "USING: sets.extras prettyprint ;"
+ "{ 1 2 3 } { 2 3 4 } setwise-xor ."
+ "{ 1 4 }"
+}
+{ $notes "Known as setxor1d in numpy." } ;
+
+HELP: symmetric-diff
+{ $values { "set1" set } { "set2" set } { "set" set } }
+{ $description "Find the symmetric difference of two sets. Outputs a set containing elements that in either set but not in both." } ;
+
+HELP: proper-subset?
+{ $values { "set1" set } { "set2" set } { "?" boolean } }
+{ $description "Find whether " { $snippet "set1" } " is a proper subset of " { $snippet "set2" } ". Returns true if " { $snippet "set1" } " is a subset of " { $snippet "set2" } " but " { $snippet "set2" } " is not a subset of " { $snippet "set1" } "." } ;
+
+ARTICLE: "sets.extras" "Extra sets words"
+"The " { $vocab-link "sets.extras" } " vocabulary is a collection of words related to sets."
+$nl
+"To take the element-wise xor of two sequences as if they were sets:"
+{ $subsections setwise-xor } ;
+
+ABOUT: "sets.extras"
--- /dev/null
+! Copyright (C) 2013 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: math sequences sets.extras tools.test ;
+
+{ { } } [ { } { } setwise-xor ] unit-test
+{ { 1 } } [ { 1 } { } setwise-xor ] unit-test
+{ { 1 } } [ { } { 1 } setwise-xor ] unit-test
+{ { } } [ { 1 } { 1 } setwise-xor ] unit-test
+{ { 1 4 5 7 } } [ { 1 2 3 2 4 } { 2 3 5 7 5 } setwise-xor ] unit-test
+
+{ { } } [ { } { } symmetric-diff ] unit-test
+{ { 1 2 3 } } [ { 1 2 3 } { } symmetric-diff ] unit-test
+{ { 1 2 3 } } [ { } { 1 2 3 } symmetric-diff ] unit-test
+{ { 1 2 4 5 } } [ { 1 2 3 } { 3 4 5 } symmetric-diff ] unit-test
+
+{ f } [ { } { } proper-subset? ] unit-test
+{ f } [ { 1 2 } { 1 2 } proper-subset? ] unit-test
+{ f } [ { 1 2 3 } { 1 2 } proper-subset? ] unit-test
+{ t } [ { 1 2 } { 1 2 3 } proper-subset? ] unit-test
+
+{ "abc" } [ "abc" non-repeating ] unit-test
+{ "abc" } [ "abcddd" non-repeating ] unit-test
+{ "" } [ "aabbcc" non-repeating ] unit-test
+
+{ HS{ 0 10 20 30 40 } } [ 5 <iota> [ 10 * ] mapped-set ] unit-test
+
+{ { 1 2 4 } } [ { 1 2 3 4 5 } [ 2/ ] unique-by ] unit-test
--- /dev/null
+! Copyright (C) 2013 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs fry hash-sets kernel locals sequences
+sequences.extras sets ;
+IN: sets.extras
+
+: setwise-xor ( seq1 seq2 -- set )
+ [ append members ] [ intersect ] 2bi diff ;
+
+: symmetric-diff ( set1 set2 -- set )
+ [ union ] [ intersect ] 2bi diff ;
+
+: proper-subset? ( set1 set2 -- ? )
+ 2dup subset? [ swap subset? not ] [ 2drop f ] if ;
+
+: superset? ( set1 set2 -- ? )
+ swap subset? ;
+
+: disjoint? ( set1 set2 -- ? )
+ intersects? not ;
+
+:: non-repeating ( seq -- seq' )
+ HS{ } clone :> visited
+ 0 seq new-resizable :> accum
+ seq [
+ accum over visited ?adjoin
+ [ push ] [ remove-first! drop ] if
+ ] each accum seq like ;
+
+: adjoin-at* ( value key assoc -- set )
+ [ [ HS{ } clone ] unless* [ adjoin ] keep dup ] change-at ;
+
+: mapped-set ( ... seq quot: ( ... elt -- ... newelt ) -- ... set )
+ over length <hash-set> [
+ '[ @ _ adjoin ] each
+ ] keep ; inline
+
+: unique-by ( seq quot: ( elt -- key ) -- seq' )
+ over length <hash-set> '[ @ _ ?adjoin ] filter ; inline
--- /dev/null
+collections
--- /dev/null
+John Benediktsson
--- /dev/null
+! Copyright (C) 2013 John Benediktsson.
+! See http://factorcode.org/license.txt for BSD license.
+
+USING: help.markup help.syntax kernel strings ;
+
+IN: tools.which
+
+HELP: which
+{ $values { "command" string } { "file/f" "the first matching path or " { $link f } } }
+{ $description "Returns the full path of the executable that would have been executed if " { $snippet "command" } " had been entered at the shell prompt." } ;
--- /dev/null
+! Copyright (C) 2012 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: arrays assocs combinators.short-circuit command-line
+environment io io.backend io.files io.files.info io.pathnames
+kernel namespaces sequences sets splitting system unicode ;
+
+IN: tools.which
+
+<PRIVATE
+
+: executable? ( path -- ? )
+ {
+ [ exists? ]
+ [ file-executable? ]
+ [ file-info directory? not ]
+ } 1&& ;
+
+: split-path ( paths -- seq )
+ os windows? ";" ":" ? split harvest ;
+
+: path-extensions ( command -- commands )
+ "PATHEXT" os-env [
+ split-path 2dup [ [ >lower ] bi@ tail? ] with any?
+ [ drop 1array ] [ [ append ] with map ] if
+ ] [ 1array ] if* ;
+
+: find-which ( commands paths -- file/f )
+ [ normalize-path ] map members
+ cartesian-product flip concat
+ [ prepend-path ] { } assoc>map
+ [ executable? ] find nip ;
+
+: (which) ( command path -- file/f )
+ split-path os windows? [
+ [ path-extensions ] [ "." prefix ] bi*
+ ] [ [ 1array ] dip ] if find-which ;
+
+PRIVATE>
+
+: which ( command -- file/f )
+ "PATH" os-env (which) ;
+
+: ?which ( command -- file/command )
+ [ which ] [ or ] bi ;
+
+: run-which ( -- )
+ command-line get [ which [ print ] when* ] each ;
+
+MAIN: run-which
+++ /dev/null
-Doug Coleman
+++ /dev/null
-! Copyright (C) 2017 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays concurrency.combinators concurrency.semaphores fry
-io io.directories io.encodings.utf8 io.files.info io.launcher
-io.pathnames kernel math namespaces sequences splitting
-system-info unicode ;
-IN: cli.git
-
-SYMBOL: cli-git-num-parallel
-cli-git-num-parallel [ cpus 2 * ] initialize
-
-: git-command>string ( quot -- string )
- utf8 <process-reader> stream-contents [ blank? ] trim-tail ;
-
-: git-clone-as ( uri path -- process ) [ { "git" "clone" } ] 2dip 2array append run-process ;
-: git-clone ( uri -- process ) [ { "git" "clone" } ] dip suffix run-process ;
-: git-pull* ( -- process ) { "git" "pull" } run-process ;
-: git-pull ( path -- process ) [ git-pull* ] with-directory ;
-: git-fetch-all* ( -- process ) { "git" "fetch" "--all" } run-process ;
-: git-fetch-all ( path -- process ) [ git-fetch-all* ] with-directory ;
-: git-fetch-tags* ( -- process ) { "git" "fetch" "--tags" } run-process ;
-: git-fetch-tags ( path -- process ) [ git-fetch-tags* ] with-directory ;
-: git-checkout-new-branch* ( branch -- process ) [ { "git" "checkout" "-b" } ] dip suffix run-process ;
-: git-checkout-new-branch ( path branch -- process ) '[ _ git-checkout-new-branch* ] with-directory ;
-: git-checkout-existing-branch* ( branch -- process ) [ { "git" "checkout" } ] dip suffix run-process ;
-: git-checkout-existing-branch ( path branch -- process ) '[ _ git-checkout-existing-branch* ] with-directory ;
-: git-change-remote* ( remote uri -- process ) [ { "git" "remote" "set-url" } ] 2dip 2array append run-process ;
-: git-change-remote ( path remote uri -- process ) '[ _ _ git-change-remote* ] with-directory ;
-: git-remote-add* ( remote uri -- process ) [ { "git" "remote" "add" } ] 2dip 2array append run-process ;
-: git-remote-add ( path remote uri -- process ) '[ _ _ git-remote-add* ] with-directory ;
-: git-remote-get-url* ( remote -- process ) [ { "git" "remote" "get-url" } ] dip suffix run-process ;
-: git-remote-get-url ( path remote -- process ) '[ _ git-remote-get-url* ] with-directory ;
-: git-rev-parse* ( branch -- string ) [ { "git" "rev-parse" } ] dip suffix git-command>string ;
-: git-rev-parse ( path branch -- string ) '[ _ git-rev-parse* ] with-directory ;
-: git-diff-name-only* ( from to -- lines )
- [ { "git" "diff" "--name-only" } ] 2dip 2array append process-lines ;
-: git-diff-name-only ( path from to -- lines )
- '[ _ _ git-diff-name-only* ] with-directory ;
-
-: git-repository? ( directory -- ? )
- ".git" append-path current-directory get prepend-path
- ?file-info dup [ directory? ] when ;
-
-: git-current-branch* ( -- name )
- { "git" "rev-parse" "--abbrev-ref" "HEAD" } git-command>string ;
-
-: git-current-branch ( directory -- name )
- [ git-current-branch* ] with-directory ;
-
-: repository-url>name ( string -- string' )
- file-name ".git" ?tail drop ;
-
-: update-repository ( url -- process )
- dup repository-url>name git-repository?
- [ repository-url>name git-pull ] [ git-clone ] if ;
-
-: sync-repositories ( directory urls -- )
- '[
- _ cli-git-num-parallel get <semaphore> '[
- _ [ update-repository ] with-semaphore
- ] parallel-each
- ] with-ensure-directory ;
+++ /dev/null
-Doug Coleman
+++ /dev/null
-USING: combinators help.markup help.syntax ;
-
-IN: combinators.extras
-
-HELP: cond-case
-{ $values { "assoc" "a sequence of quotation pairs and an optional quotation" } }
-{ $description
- "Similar to " { $link case } ", this evaluates an " { $snippet "obj" } " according to the first quotation in each pair. If any quotation returns true, calls the second quotation without " { $snippet "obj" } " on the stack."
- $nl
- "If there is no quotation that returns true, the default case is taken. If the last element of " { $snippet "assoc" } " is a quotation, the quotation is called with " { $snippet "obj" } " on the stack. Otherwise, a " { $link no-cond } " error is raised."
-}
-{ $examples
- { $example
- "USING: combinators.extras io kernel math ;"
- "0 {"
- " { [ 0 > ] [ \"positive\" ] }"
- " { [ 0 < ] [ \"negative\" ] }"
- " [ drop \"zero\" ]"
- "} cond-case print"
- "zero"
- }
-} ;
+++ /dev/null
-! Copyright (C) 2013 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: combinators.extras io.files kernel math sequences
-tools.test ;
-
-{ "a b" }
-[ "a" "b" [ " " glue ] once ] unit-test
-
-{ "a b c" }
-[ "a" "b" "c" [ " " glue ] twice ] unit-test
-
-{ "a b c d" }
-[ "a" "b" "c" "d" [ " " glue ] thrice ] unit-test
-
-{ { "negative" 0 "positive" } } [
- { -1 0 1 } [
- {
- { [ 0 > ] [ "positive" ] }
- { [ 0 < ] [ "negative" ] }
- [ ]
- } cond-case
- ] map
-] unit-test
-
-{ { 1 2 3 } } [ 1 { [ ] [ 1 + ] [ 2 + ] } cleave-array ] unit-test
-
-{ 2 15 } [ 1 2 3 4 5 6 [ - - ] [ + + ] 3bi* ] unit-test
-
-{ 2 5 } [ 1 2 3 4 5 6 [ - - ] 3bi@ ] unit-test
-
-{ 3 1 } [ 1 2 [ + ] keepd ] unit-test
-
-{ "1" "123" } [ "1" "123" [ length ] [ > ] swap-when ] unit-test
-{ "123" "1" } [ "1" "123" [ length ] [ < ] swap-when ] unit-test
-
-
-{ t } [ "resource:" [ exists? ] ?1arg >boolean ] unit-test
-{ f } [ f [ exists? ] ?1arg ] unit-test
-{ f } [ "/homeasdfasdf123123" [ exists? ] ?1arg ] unit-test
-
-{ "hi " "there" } [
- "hi there" {
- { [ "there" over subseq-start ] [ cut ] }
- [ f ]
- } cond*
-] unit-test
-
-{ "hi " "there" } [
- "hi there" {
- { [ "foo" over subseq-start ] [ head f ] }
- { [ "there" over subseq-start ] [ cut ] }
- [ f ]
- } cond*
-] unit-test
-
-{ "hi there" f } [
- "hi there" {
- { [ "foo" over subseq-start ] [ head f ] }
- { [ "bar" over subseq-start ] [ cut ] }
- [ f ]
- } cond*
-] unit-test
+++ /dev/null
-! Copyright (C) 2013 Doug Coleman, John Benediktsson.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs combinators combinators.smart fry
-generalizations kernel macros math quotations sequences locals
-math.order sequences.generalizations sequences.private
-stack-checker.transforms system words ;
-IN: combinators.extras
-
-: once ( quot -- ) call ; inline
-: twice ( quot -- ) dup [ call ] dip call ; inline
-: thrice ( quot -- ) dup dup [ call ] 2dip [ call ] dip call ; inline
-: forever ( quot -- ) [ t ] compose loop ; inline
-
-MACRO: cond-case ( assoc -- quot )
- [
- dup callable? not [
- [ first [ dup ] prepose ]
- [ second [ drop ] prepose ] bi 2array
- ] when
- ] map [ cond ] curry ;
-
-MACRO: cleave-array ( quots -- quot )
- [ '[ _ cleave ] ] [ length '[ _ narray ] ] bi compose ;
-
-: 3bi* ( u v w x y z p q -- )
- [ 3dip ] dip call ; inline
-
-: 3bi@ ( u v w x y z quot -- )
- dup 3bi* ; inline
-
-: 4bi ( w x y z p q -- )
- [ 4keep ] dip call ; inline
-
-: 4bi* ( s t u v w x y z p q -- )
- [ 4dip ] dip call ; inline
-
-: 4bi@ ( s t u v w x y z quot -- )
- dup 4bi* ; inline
-
-: 4tri ( w x y z p q r -- )
- [ [ 4keep ] dip 4keep ] dip call ; inline
-
-: plox ( ... x/f quot: ( ... x -- ... ) -- ... )
- dupd when ; inline
-
-MACRO: smart-plox ( true -- quot )
- [ inputs [ 1 - [ and ] n*quot ] keep ] keep swap
- '[ _ _ [ _ ndrop f ] smart-if ] ;
-
-: throttle ( quot millis -- quot' )
- 1,000,000 * '[
- _ nano-count { 0 } 2dup first-unsafe _ + >=
- [ 0 swap set-nth-unsafe call ] [ 3drop ] if
- ] ; inline
-
-: swap-when ( x y quot: ( x -- n ) quot: ( n n -- ? ) -- x' y' )
- '[ _ _ 2dup _ bi@ @ [ swap ] when ] call ; inline
-
-
-! ?1arg-result-falsify
-
-: 1falsify ( obj/f -- obj/f ) ; inline
-: 2falsify ( obj1 obj2 -- obj1/f obj2/f ) 2dup and [ 2drop f f ] unless ; inline
-: 3falsify ( obj1 obj2 obj3 -- obj1/f obj2/f obj3/f ) 3dup and and [ 3drop f f f ] unless ; inline
-
-MACRO: n-and ( n -- quot )
- 1 [-] [ and ] n*quot ;
-
-MACRO: n*obj ( n obj -- quot )
- 1quotation n*quot ;
-
-MACRO:: n-falsify ( n -- quot )
- [ n ndup n n-and [ n ndrop n f n*obj ] unless ] ;
-
-! plox
-: ?1res ( ..a obj/f quot -- ..b )
- dupd when ; inline
-
-! when both args are true, call quot. otherwise dont
-: ?2res ( ..a obj1 obj2 quot: ( obj1 obj2 -- ? ) -- ..b )
- [ 2dup and ] dip [ 2drop f ] if ; inline
-
-! try the quot, keep the original arg if quot is true
-: ?1arg ( obj quot: ( obj -- ? ) -- obj/f )
- [ ?1res ] keepd '[ _ ] [ f ] if ; inline
-
-: ?2arg ( obj1 obj2 quot: ( obj1 obj2 -- ? ) -- obj1/f obj2/f )
- [ ?2res ] 2keepd '[ _ _ ] [ f f ] if ; inline
-
-<<
-: alist>quot* ( default assoc -- quot )
- [ rot \ if* 3array append [ ] like ] assoc-each ;
-
-: cond*>quot ( assoc -- quot )
- [ dup pair? [ [ drop ] prepend [ t ] swap 2array ] unless ] map
- reverse! [ no-cond ] swap alist>quot* ;
-
-DEFER: cond*
-\ cond* [ cond*>quot ] 1 define-transform
-\ cond* t "no-compile" set-word-prop
->>
-: cond* ( assoc -- )
- [ dup callable? [ drop t ] [ first call ] if ] map-find
- [ dup callable? [ nip call ] [ second call ] if ]
- [ no-cond ] if* ;
+++ /dev/null
-USING: help.markup help.syntax sequences splitting strings ;
-
-IN: grouping.extras
-
-HELP: group-by
-{ $values { "seq" sequence } { "quot" { $quotation ( elt -- key ) } } { "groups" "a new assoc" } }
-{ $description "Groups the elements by the key received by applying quot to each element in the sequence." }
-{ $examples
- { $example
- "USING: grouping.extras unicode.data prettyprint sequences strings ;"
- "\"THis String Has CasE!\" [ category ] group-by [ last >string ] { } map-as ."
- "{ \"TH\" \"is\" \" \" \"S\" \"tring\" \" \" \"H\" \"as\" \" \" \"C\" \"as\" \"E\" \"!\" }"
- }
-} ;
+++ /dev/null
-USING: arrays grouping.extras kernel math math.functions
-sequences tools.test ;
-
-{ { } } [ { 1 } [ 2array ] 2clump-map ] unit-test
-{ { { 1 2 } } } [ { 1 2 } [ 2array ] 2clump-map ] unit-test
-{ { { 1 2 } { 2 3 } } } [ { 1 2 3 } [ 2array ] 2clump-map ] unit-test
-{ { { 1 2 } { 2 3 } { 3 4 } } } [ { 1 2 3 4 } [ 2array ] 2clump-map ] unit-test
-
-{ { } } [ { 1 } [ 3array ] 3clump-map ] unit-test
-{ { } } [ { 1 2 } [ 3array ] 3clump-map ] unit-test
-{ { { 1 2 3 } } } [ { 1 2 3 } [ 3array ] 3clump-map ] unit-test
-{ { { 1 2 3 } { 2 3 4 } } } [ { 1 2 3 4 } [ 3array ] 3clump-map ] unit-test
-
-{ { } } [ { 1 } [ 4array ] 4 nclump-map ] unit-test
-{ { } } [ { 1 2 } [ 4array ] 4 nclump-map ] unit-test
-{ { { 1 2 3 4 } } } [ { 1 2 3 4 } [ 4array ] 4 nclump-map ] unit-test
-{ { { 1 2 3 4 } { 2 3 4 5 } } } [ { 1 2 3 4 5 } [ 4array ] 4 nclump-map ] unit-test
-
-{ { "tail" "ail" "il" "l" } } [ "tail" tail-clump ] unit-test
-{ { "h" "he" "hea" "head" } } [ "head" head-clump ] unit-test
-
-{ { B{ 97 115 } B{ 100 102 } } } [ "asdf" 2 B{ } group-as ] unit-test
-{ { { 97 115 } { 115 100 } { 100 102 } } } [ "asdf" 2 { } clump-as ] unit-test
-
-{
- V{
- { 0 V{ 0 1 2 } }
- { 1 V{ 3 4 5 } }
- { 2 V{ 6 7 8 } }
- { 3 V{ 9 } } }
-} [
- 10 <iota> [ 3 / floor ] group-by
-] unit-test
-
-{ V{ { t V{ 0 1 2 3 4 5 6 7 8 9 } } } }
-[ 10 <iota> [ drop t ] group-by ] unit-test
-
-{ V{ } } [ { } [ drop t ] group-by ] unit-test
-
-{ { { } { } { } } } [ { } 3 n-group ] unit-test
-{ { { 1 } { } { } } } [ { 1 } 3 n-group ] unit-test
-{ { { 1 } { 2 } { } } } [ { 1 2 } 3 n-group ] unit-test
-{ { { 1 } { 2 } { 3 } } } [ { 1 2 3 } 3 n-group ] unit-test
-{ { { 1 2 } { 3 } { 4 } } } [ { 1 2 3 4 } 3 n-group ] unit-test
+++ /dev/null
-USING: accessors arrays combinators fry grouping
-grouping.private kernel locals macros math math.ranges sequences
-sequences.generalizations sequences.private vectors ;
-
-IN: grouping.extras
-
-: 2clump-map-as ( seq quot: ( elt1 elt2 -- newelt ) exemplar -- seq' )
- [ dup 1 short tail-slice ] 2dip 2map-as ; inline
-
-: 2clump-map ( seq quot: ( elt1 elt2 -- newelt ) -- seq' )
- { } 2clump-map-as ; inline
-
-: 3clump-map-as ( seq quot: ( elt1 elt2 elt3 -- newelt ) exemplar -- seq' )
- [
- dup [ 1 short tail-slice ] [ 2 short tail-slice ] bi
- ] 2dip 3map-as ; inline
-
-: 3clump-map ( seq quot: ( elt1 elt2 elt3 -- newelt ) -- seq' )
- { } 3clump-map-as ; inline
-
-MACRO: nclump-map-as ( seq quot exemplar n -- result )
- [ nip [1,b) [ [ short tail-slice ] curry ] map swap ] 2keep
- '[ _ dup _ cleave _ _ _ nmap-as ] ;
-
-: nclump-map ( seq quot n -- result )
- { } swap nclump-map-as ; inline
-
-TUPLE: head-clumps seq ;
-C: <head-clumps> head-clumps
-M: head-clumps length seq>> length ;
-M: head-clumps nth-unsafe seq>> swap 1 + head-slice ;
-INSTANCE: head-clumps immutable-sequence
-
-: head-clump ( seq -- array )
- [ <head-clumps> ] [ [ like ] curry map ] bi ;
-
-TUPLE: tail-clumps seq ;
-C: <tail-clumps> tail-clumps
-M: tail-clumps length seq>> length ;
-M: tail-clumps nth-unsafe seq>> swap tail-slice ;
-INSTANCE: tail-clumps immutable-sequence
-
-: tail-clump ( seq -- array )
- [ <tail-clumps> ] [ [ like ] curry map ] bi ;
-
-: clump-as ( seq n exemplar -- array )
- [ <clumps> ] dip [ like ] curry map ;
-
-: group-as ( seq n exemplar -- array )
- [ <groups> ] dip [ like ] curry map ;
-
-<PRIVATE
-
-: (group-by) ( groups elt key -- groups )
- pick [ t ] [ last first dupd = not ] if-empty [
- swap 1vector 2array over push
- ] [
- drop over last last push
- ] if ; inline
-
-PRIVATE>
-
-: group-by ( seq quot: ( elt -- key ) -- groups )
- '[ dup _ call( x -- y ) (group-by) ] V{ } clone swap reduce ;
-
-:: <n-groups> ( seq n -- groups )
- seq length :> len
- len n /mod :> ( step rem! )
- 0 n [
- dup len < [
- dup step + rem zero? [ 1 + rem 1 - rem! ] unless
- [ seq <slice> ] keep swap
- ] [ f ] if
- ] replicate nip ;
-
-: n-group ( seq n -- groups )
- [ <n-groups> ] map-like ;
+++ /dev/null
-algorithms
+++ /dev/null
-USING: help.markup help.syntax kernel math sequences ;
-IN: sequences.extras
-
-HELP: ?supremum
-{ $values
- { "seq/f" { $maybe sequence } }
- { "elt/f" { $maybe object } }
-}
-{ $description "Outputs the greatest element of " { $snippet "seq" } ", ignoring any " { $link POSTPONE: f } " elements in it. If " { $snippet "seq" } " is empty or " { $link POSTPONE: f } ", returns " { $link POSTPONE: f } "." }
-{ $examples
- { $example "USING: prettyprint sequences.extras ;"
- "{ 1 f 3 2 } ?supremum ."
- "3" }
-} ;
-
-HELP: ?infimum
-{ $values
- { "seq/f" { $maybe sequence } }
- { "elt/f" { $maybe object } }
-}
-{ $description "Outputs the least element of " { $snippet "seq" } ", ignoring any " { $link POSTPONE: f } " elements in it. If " { $snippet "seq" } " is empty or " { $link POSTPONE: f } ", returns " { $link POSTPONE: f } "." }
-{ $examples
- { $example "USING: prettyprint sequences.extras ;"
- "{ 1 f 3 2 } ?infimum ."
- "1" }
-} ;
-
-{ ?supremum ?infimum } related-words
-
-HELP: 2count
-{ $values
- { "seq1" sequence }
- { "seq2" sequence }
- { "quot" { $quotation ( ... elt1 elt2 -- ... ? ) } }
- { "n" integer } }
-{ $description "Efficiently counts how many pairwise elements of " { $snippet "seq1" } " and " { $snippet "seq2" } " that the predicate quotation matches." }
-{ $examples
- { $example "USING: kernel prettyprint sequences.extras ;" "{ 1 2 3 } { 3 2 1 } [ = ] 2count ." "1" } }
-{ $see-also count } ;
-
-HELP: 2each-index
-{ $values
- { "seq1" sequence }
- { "seq2" sequence }
- { "quot" { $quotation ( ... elt1 elt2 index -- ... ) } } }
-{ $description "Applies " { $snippet "quot" } " to each pair of elements from " { $snippet "seq1" } " and " { $snippet "seq2" } ", providing the index of the elements at the top of the stack." }
-{ $see-also 2each each-index } ;
-
-HELP: 2map!
-{ $values
- { "seq1" sequence }
- { "seq2" sequence }
- { "quot" { $quotation ( ... elt1 elt2 -- ... newelt ) } } }
-{ $description "Applies the quotation to each pair of elements from " { $snippet "seq1" } " and " { $snippet "seq2" } ", yielding a new element, and storing it back into " { $snippet "seq1" } ". Returns " { $snippet "seq1" } "." }
-{ $see-also 2map map! } ;
-
-HELP: 2map-index
-{ $values
- { "seq1" sequence }
- { "seq2" sequence }
- { "quot" { $quotation ( ... elt1 elt2 index -- ... newelt ) } }
- { "newseq" sequence } }
-{ $description "Calls the quotation with each pair of elements of the two sequences and their index on the stack, with the index on the top of the stack. Collects the outputs of the quotation and outputs them into a new sequence of the same type as the first sequence." }
-{ $see-also 2map map-index } ;
-
-HELP: count*
-{ $values
- { "seq" sequence }
- { "quot" { $quotation ( ... elt -- ... ? ) } }
- { "%" rational } }
-{ $description "Outputs the fraction of elements in the sequence for which the predicate quotation matches." }
-{ $examples { $example "USING: math math.ranges prettyprint sequences.extras ;" "100 [1,b] [ even? ] count* ." "1/2" } } ;
-
-HELP: collapse
-{ $values
- { "seq" sequence }
- { "quot" { $quotation ( ... elt -- ... ? ) } }
- { "elt" object }
- { "seq'" sequence } }
-{ $description "Generate a new sequence where all runs of elements for which the predicate returns true are replaced by a single instance of " { $snippet "elt" } "." }
-{ $see-also compact }
-{ $examples
- "Collapse multiple spaces in a string down to a single space"
- { $example "USING: kernel prettyprint sequences.extras ;" "\" Hello, crazy world \" [ CHAR: \\s = ] \" \" collapse ." "\" Hello, crazy world \"" } } ;
-
-HELP: compact
-{ $values
- { "seq" sequence }
- { "quot" { $quotation ( ... elt -- ... ? ) } }
- { "elt" object }
- { "seq'" sequence } }
-{ $description "Generate a new sequence where all runs of elements for which the predicate returns true are replaced by a single instance of " { $snippet "elt" } ". Runs at the beginning or end of the sequence for which the predicate returns true are removed." }
-{ $see-also collapse }
-{ $examples
- "Collapse multiple spaces in a string down to a single space"
- { $example "USING: kernel prettyprint sequences.extras ;" "\" Hello, crazy world \" [ CHAR: \\s = ] \" \" compact ." "\"Hello, crazy world\"" } } ;
-
-HELP: <evens>
-{ $values { "seq" sequence } { "evens" evens } }
-{ $description "Create a virtual sequence whose elements consist of the even-indexed elements from the original sequence." }
-{ $notes "Because sequences are zero-indexed, this collection includes the first, third, fifth, etc. elements of the actual sequence which can be counterintuitive." }
-{ $see-also <odds> } ;
-
-HELP: find-all
-{ $values
- { "seq" sequence }
- { "quot" { $quotation ( ... elt -- ... ? ) } }
- { "elts" "the indices of the matching elements" } }
-{ $description "Similar to " { $link find } ", but finds all of the indices and elements that match the provided quotation, not just the first." }
-{ $notes "The result is provided as an array of arrays, whose first value is the index and whose second value is the element." } ;
-
-HELP: first=
-{ $values
- { "seq" sequence }
- { "elt" object }
- { "?" boolean } }
-{ $description "Checks whether the first element of " { $snippet "seq" } " is equal to " { $snippet "elt" } "." } ;
-
-HELP: first?
-{ $values
- { "seq" sequence }
- { "quot" { $quotation ( ... elt -- ... ? ) } }
- { "?" boolean } }
-{ $description "Tests whether the first element of " { $snippet "seq" } " satisfies the provided predicate." } ;
-
-HELP: fourth=
-{ $values
- { "seq" sequence }
- { "elt" object }
- { "?" boolean } }
-{ $description "Checks whether the fourth element of " { $snippet "seq" } " is equal to " { $snippet "elt" } "." } ;
-
-HELP: fourth?
-{ $values
- { "seq" sequence }
- { "quot" { $quotation ( ... elt -- ... ? ) } }
- { "?" boolean } }
-{ $description "Tests whether the fourth element of " { $snippet "seq" } " satisfies the provided predicate." } ;
-
-HELP: <odds>
-{ $values { "seq" sequence } { "odds" odds } }
-{ $description "Create a virtual sequence whose elements consist of the odd-indexed elements from the original sequence." }
-{ $notes "Because sequences are zero-indexed, this collection includes the second, fourth, sixth, etc. elements of the actual sequence which can be counterintuitive." }
-{ $see-also <evens> } ;
-
-HELP: >resizable
-{ $values { "seq" sequence } { "accum" sequence } }
-{ $description "Converts a sequence into the nearest resizable equivalent, preserving its contents." } ;
-
-HELP: second=
-{ $values
- { "seq" sequence }
- { "elt" object }
- { "?" boolean } }
-{ $description "Checks whether the second element of " { $snippet "seq" } " is equal to " { $snippet "elt" } "." } ;
-
-HELP: second?
-{ $values
- { "seq" sequence }
- { "quot" { $quotation ( ... elt -- ... ? ) } }
- { "?" boolean } }
-{ $description "Tests whether the second element of " { $snippet "seq" } " satisfies the provided predicate." } ;
-
-HELP: subseq*
-{ $values
- { "from" integer } { "to" integer } { "seq" sequence } { "subseq" sequence } }
-{ $description "Outputs a new sequence using positions relative to one or both ends of the sequence. Positive values describes offsets relative to the start of the sequence, negative values relative to the end. Values of " { $link f } " for " { $snippet "from" } " indicate the beginning of the sequence, while an " { $link f } " for " { $snippet "to" } " indicates the end of the sequence." }
-{ $notes "Both " { $snippet "from" } " and " { $snippet "to" } " can be safely set to values outside the length of the sequence. Also, " { $snippet "from" } " can safely reference a smaller or greater index position than " { $snippet "to" } "." }
-{ $examples
- "Using a negative relative index:"
- { $example "USING: prettyprint sequences.extras ; 2 -1 \"abcdefg\" subseq* ."
- "\"cdef\""
- }
- "Using optional indices:"
- { $example "USING: prettyprint sequences.extras ; f -4 \"abcdefg\" subseq* ."
- "\"abc\""
- }
- "Using larger-than-necessary indices:"
- { $example "USING: prettyprint sequences.extras ; 0 10 \"abcdefg\" subseq* ."
- "\"abcdefg\""
- }
- "Trimming from either end of the sequence."
- { $example "USING: prettyprint sequences.extras ; 1 -1 \"abcdefg\" subseq* ."
- "\"bcdef\""
- }
-} ;
-
-HELP: third=
-{ $values
- { "seq" sequence }
- { "elt" object }
- { "?" boolean } }
-{ $description "Checks whether the third element of " { $snippet "seq" } " is equal to " { $snippet "elt" } "." } ;
-
-HELP: third?
-{ $values
- { "seq" sequence }
- { "quot" { $quotation ( ... elt -- ... ? ) } }
- { "?" boolean } }
-{ $description "Tests whether the third element of " { $snippet "seq" } " satisfies the provided predicate." } ;
-
-HELP: unsurround
-{ $values
- { "newseq" sequence }
- { "seq2" sequence }
- { "seq3" sequence }
- { "seq1" sequence } }
-{ $description "Reverses the result of a " { $link surround } " call, stripping off the prefix " { $snippet "seq2" } " and suffix " { $snippet "seq3" } " to restore the original sequence " { $snippet "seq" } "." }
-{ $see-also surround } ;
-
-HELP: start-all
-{ $values
- { "subseq" sequence } { "seq" sequence } { "indices" sequence } }
-{ $description "Outputs the starting indices of the non-overlapping occurrences of " { $snippet "subseq" } " in " { $snippet "seq" } "." }
-{ $examples
- { $example "USING: prettyprint sequences.extras ; \"ABA\" \"ABABA\" start-all ."
- "{ 0 }"
- }
- { $example "USING: prettyprint sequences.extras ; \"ABA\" \"ABAABA\" start-all ."
- "{ 0 3 }"
- }
- } ;
-
-HELP: start-all*
-{ $values
- { "subseq" sequence } { "seq" sequence } { "indices" sequence } }
-{ $description "Outputs the starting indices of the possibly overlapping occurrences of " { $snippet "subseq" } " in " { $snippet "seq" } "." }
-{ $examples
- { $example "USING: prettyprint sequences.extras ; \"ABA\" \"ABABA\" start-all* ."
- "{ 0 2 }"
- } } ;
-
-HELP: arg-max
-{ $values { "seq" sequence } { "n" integer } }
-{ $description "Outputs the sequence with the largest item." } ;
-
-HELP: arg-min
-{ $values { "seq" sequence } { "n" integer } }
-{ $description "Outputs the sequence with the smallest item." } ;
-
-{ arg-max arg-min } related-words
-
-HELP: count-subseq
-{ $values
- { "subseq" sequence } { "seq" sequence } { "n" integer } }
-{ $description "Outputs the number of non-overlapping occurrences of " { $snippet "subseq" } " in " { $snippet "seq" } "." }
-{ $examples
- { $example "USING: prettyprint sequences.extras ; \"ABA\" \"ABABA\" count-subseq ."
- "1"
- } } ;
-
-
-HELP: count-subseq*
-{ $values
- { "subseq" sequence } { "seq" sequence } { "n" integer } }
-{ $description "Outputs the number of possibly overlapping occurrences of " { $snippet "subseq" } " in " { $snippet "seq" } "." }
-{ $examples
- { $example "USING: prettyprint sequences.extras ; \"ABA\" \"ABABA\" count-subseq* ."
- "2"
- } } ;
-
-{ start-all start-all* count-subseq count-subseq* } related-words
+++ /dev/null
-USING: accessors arrays ascii io io.streams.string kernel make
-math math.vectors random sequences sequences.extras strings
-tools.test vectors vocabs ;
-
-{ V{ { 0 104 } { 2 108 } { 3 108 } } } [ "hello" [ even? ] find-all ] unit-test
-
-{ { "a" "b" "c" "d" "ab" "bc" "cd" "abc" "bcd" "abcd" } } [ "abcd" all-subseqs ] unit-test
-
-{ { "a" "ab" "abc" "abcd" "b" "bc" "bcd" "c" "cd" "d" } }
-[ [ "abcd" [ , ] each-subseq ] { } make ] unit-test
-
-{ B{ 115 } } [ 1 2 "asdf" B{ } subseq-as ] unit-test
-
-{ "" } [ "abc" "def" longest-subseq ] unit-test
-{ "abcd" } [ "abcd" "abcde" longest-subseq ] unit-test
-{ "foo" } [ "foo" "foobar" longest-subseq ] unit-test
-{ "foo" } [ "foobar" "foo" longest-subseq ] unit-test
-
-{ "" "" } [ "" "" CHAR: ? pad-longest ] unit-test
-{ "abc" "def" } [ "abc" "def" CHAR: ? pad-longest ] unit-test
-{ " " "abc" } [ "" "abc" CHAR: \s pad-longest ] unit-test
-{ "abc" " " } [ "abc" "" CHAR: \s pad-longest ] unit-test
-{ "abc..." "foobar" } [ "abc" "foobar" CHAR: . pad-longest ] unit-test
-
-{
- {
- "ABC"
- "ABC"
- "ABC"
- "ABC"
- "ABC-"
- "-ABC-"
- "-ABC--"
- "--ABC--"
- }
-} [
- "ABC" 8 <iota> [ CHAR: - pad-center ] with map
-] unit-test
-
-{ { 0 1 0 1 } } [
- { 0 0 0 0 } { 1 3 } over [ 1 + ] change-nths
-] unit-test
-
-{ V{ f t f } } [
- { 1 2 3 } [ even? ] selector* [ each ] dip
-] unit-test
-
-{ { 1 3 5 } } [ { 1 2 3 4 5 6 } [ nip even? ] filter-index ] unit-test
-
-{ V{ 1 3 5 } } [ { 1 2 3 4 5 6 } [ nip even? ] V{ } filter-index-as ] unit-test
-
-{ { 1 3 5 } } [ { 1 2 3 4 5 6 } even-indices ] unit-test
-
-{ { 2 4 6 } } [ { 1 2 3 4 5 6 } odd-indices ] unit-test
-
-{ "a b c d e" }
-[ "a b \t \n \r c d \n e " [ blank? ] " " compact ] unit-test
-
-{ " a b c d e " }
-[ " a b c d e " [ blank? ] " " collapse ] unit-test
-
-{ { "hello," " " "world!" " " " " } }
-[ "hello, world! " [ blank? ] slice-when [ >string ] map ] unit-test
-
-{ t }
-[ "abc" sequence>slice slice? ] unit-test
-
-{ "abc" }
-[ "abc" sequence>slice >string ] unit-test
-
-{ t } [ "abcdef" [ 0 3 rot <slice> ] [ 2 4 rot <slice> ] bi slices-overlap? ] unit-test
-{ t } [ "abcdef" [ 0 3 rot <slice> ] [ 1 2 rot <slice> ] bi slices-overlap? ] unit-test
-{ f } [ "abcdef" [ 0 3 rot <slice> ] [ 3 6 rot <slice> ] bi slices-overlap? ] unit-test
-{ t } [ "abcdef" [ 0 3 rot <slice> ] [ 2 4 rot <slice> ] bi slices-touch? ] unit-test
-{ t } [ "abcdef" [ 0 3 rot <slice> ] [ 1 2 rot <slice> ] bi slices-touch? ] unit-test
-{ t } [ "abcdef" [ 0 3 rot <slice> ] [ 3 6 rot <slice> ] bi slices-touch? ] unit-test
-{ f } [ "abcdef" [ 0 3 rot <slice> ] [ 4 6 rot <slice> ] bi slices-touch? ] unit-test
-
-{ "abcdef" } [
- "abcdef" [ 0 3 rot <slice> ] [ 3 6 rot <slice> ] bi merge-slices >string
-] unit-test
-
-{ "abcdef" } [
- "abcdef" [ 3 6 rot <slice> ] [ 0 3 rot <slice> ] bi merge-slices >string
-] unit-test
-
-{ "abc" } [
- "abcdef" [ 0 3 rot <slice> ] [ 0 3 rot <slice> ] bi merge-slices >string
-] unit-test
-
-
-{ "hello" "hello" } [ "hello" dup 0 rotate ] unit-test
-{ "hello" "llohe" } [ "hello" dup 2 rotate ] unit-test
-{ "hello" "lohel" } [ "hello" dup 13 rotate ] unit-test
-{ "hello" "ohell" } [ "hello" dup -1 rotate ] unit-test
-{ "hello" "lohel" } [ "hello" dup -12 rotate ] unit-test
-
-{ "hello" } [ "hello" dup 0 rotate! ] unit-test
-{ "llohe" } [ "hello" dup 2 rotate! ] unit-test
-{ "lohel" } [ "hello" dup 13 rotate! ] unit-test
-{ "ohell" } [ "hello" dup -1 rotate! ] unit-test
-{ "lohel" } [ "hello" dup -12 rotate! ] unit-test
-
-{ { } } [ { } [ ] map-concat ] unit-test
-{ V{ 0 0 1 0 1 2 } } [ 4 <iota> [ <iota> ] map-concat ] unit-test
-{ "abc" } [ "abc" [ 1string ] map-concat ] unit-test
-{ "abc" } [ { 97 98 99 } [ 1string ] map-concat ] unit-test
-{ { 97 98 99 } } [ "abc" [ 1string ] { } map-concat-as ] unit-test
-{ "baz" { "foobaz" "barbaz" } }
-[ "baz" { { "foo" } { "bar" } } [ [ over append ] map ] map-concat ] unit-test
-
-{ { } } [ { } [ ] [ even? ] map-filter ] unit-test
-{ "bcde" } [ "abcd" [ 1 + ] [ drop t ] map-filter ] unit-test
-{ { 0 4 16 36 64 } } [ 10 <iota> [ sq ] [ even? ] { } map-filter-as ] unit-test
-
-{ V{ 0 4 16 36 64 } } [ 10 <iota> [ even? ] [ sq ] filter-map ] unit-test
-{ { 2 6 10 14 18 } } [ 10 <iota> [ odd? ] [ 2 * ] { } filter-map-as ] unit-test
-
-{ 8 } [ 3 <iota> dup [ 1 + * ] 2map-sum ] unit-test
-{ 4 } [ "hello" "jello" [ = ] 2count ] unit-test
-
-{ { } } [ { } round-robin ] unit-test
-{ "ADEBFC" } [ { "ABC" "D" "EF" } round-robin >string ] unit-test
-
-{ { } } [ "ABC" [ ] { } trim-as ] unit-test
-{ "ABC" } [ { 32 65 66 67 32 } [ blank? ] "" trim-as ] unit-test
-
-{ t } [ "ABC" dup [ blank? ] ?trim [ identity-hashcode ] same? ] unit-test
-{ "ABC" } [ " ABC " [ blank? ] ?trim ] unit-test
-
-{ t } [ "ABC" dup [ blank? ] ?trim-head [ identity-hashcode ] same? ] unit-test
-{ t } [ "ABC" dup [ blank? ] ?trim-tail [ identity-hashcode ] same? ] unit-test
-{ "ABC " } [ " ABC " [ blank? ] ?trim-head ] unit-test
-{ " ABC" } [ " ABC " [ blank? ] ?trim-tail ] unit-test
-
-{ "" } [ "" "" "" unsurround ] unit-test
-{ "" } [ " " " " " " unsurround ] unit-test
-{ "foo.com" } [ "http://foo.com" "http://" "/" unsurround ] unit-test
-
-{ t } [ { 1 3 5 7 } [ even? ] none? ] unit-test
-{ f } [ { 1 2 3 4 } [ even? ] none? ] unit-test
-{ t } [ { } [ even? ] none? ] unit-test
-
-{ f } [ { 1 2 3 4 } [ even? ] one? ] unit-test
-{ t } [ { 1 2 3 } [ even? ] one? ] unit-test
-{ f } [ { } [ even? ] one? ] unit-test
-
-{ { { 5 8 0 } { 6 9 1 } { 7 10 2 } } } [ { 5 6 7 } { 8 9 10 } [ 3array ] 2map-index ] unit-test
-
-{ { } } [ { } <evens> >array ] unit-test
-{ { 0 2 } } [ 4 <iota> <evens> >array ] unit-test
-{ { 0 2 4 } } [ 5 <iota> <evens> >array ] unit-test
-{ "bbddff" } [ "abcdef" <evens> [ 1 + ] map! seq>> ] unit-test
-
-{ { } } [ { } <odds> >array ] unit-test
-{ { 1 3 } } [ 5 <iota> <odds> >array ] unit-test
-{ { 1 3 5 } } [ 6 <iota> <odds> >array ] unit-test
-{ "acceeg" } [ "abcdef" <odds> [ 1 + ] map! seq>> ] unit-test
-
-{ 1 } [ { 1 7 3 7 6 3 7 } arg-max ] unit-test
-{ 2 } [ { 0 1 99 } arg-max ] unit-test
-{ 0 } [ { 1 7 3 7 6 3 7 } arg-min ] unit-test
-{ V{ 0 4 } } [ { 5 3 2 10 5 } [ 5 = ] arg-where ] unit-test
-{ { 2 1 0 4 3 } } [ { 5 3 2 10 5 } arg-sort ] unit-test
-
-{ t } [ { 1 2 3 4 5 } 1 first= ] unit-test
-{ t } [ { 1 2 3 4 5 } 2 second= ] unit-test
-{ t } [ { 1 2 3 4 5 } 3 third= ] unit-test
-{ t } [ { 1 2 3 4 5 } 4 fourth= ] unit-test
-{ t } [ { 1 2 3 4 5 } 5 last= ] unit-test
-{ t } [ 4 { 1 2 3 4 5 } 5 nth= ] unit-test
-
-{ t } [ { 1 2 3 4 5 } [ 1 = ] first? ] unit-test
-{ t } [ { 1 2 3 4 5 } [ 2 = ] second? ] unit-test
-{ t } [ { 1 2 3 4 5 } [ 3 = ] third? ] unit-test
-{ t } [ { 1 2 3 4 5 } [ 4 = ] fourth? ] unit-test
-{ t } [ { 1 2 3 4 5 } [ 5 = ] last? ] unit-test
-{ t } [ 4 { 1 2 3 4 5 } [ 5 = ] nth? ] unit-test
-
-{ { 97 115 100 102 } } [
- "asdf" [ [ read1 ] loop>array ] with-string-reader
-] unit-test
-
-{ V{ 97 115 100 102 } } [
- "asdf" [ [ read1 ] V{ } loop>sequence ] with-string-reader
-] unit-test
-
-{ "" } [ { } "" reverse-as ] unit-test
-{ "ABC" } [ { 67 66 65 } "" reverse-as ] unit-test
-
-{ V{ 1 } } [ 1 0 V{ } [ insert-nth! ] keep ] unit-test
-{ V{ 1 2 3 4 } } [ 2 1 V{ 1 3 4 } [ insert-nth! ] keep ] unit-test
-
-{ "abc" } [ B{ 97 98 99 100 101 102 103 } 3 "" head-as ] unit-test
-{ "abcd" } [ B{ 97 98 99 100 101 102 103 } 3 "" head*-as ] unit-test
-{ "defg" } [ B{ 97 98 99 100 101 102 103 } 3 "" tail-as ] unit-test
-{ "efg" } [ B{ 97 98 99 100 101 102 103 } 3 "" tail*-as ] unit-test
-
-{ { 1 0 0 1 0 0 0 1 0 0 } }
-[ 1 { 0 3 7 } 10 0 <array> [ set-nths ] keep ] unit-test
-
-{ { 1 0 0 1 0 0 0 1 0 0 } }
-[ 1 { 0 3 7 } 10 0 <array> [ set-nths-unsafe ] keep ] unit-test
-
-{ V{ 1 } } [ 1 flatten1 ] unit-test
-{ { 1 2 3 } } [ { 1 2 3 } flatten1 ] unit-test
-{ { 1 2 3 { { 4 } } } } [ { 1 { 2 } { 3 { { 4 } } } } flatten1 ] unit-test
-
-{ t 3 3 } [ 10 <iota> [ [ odd? ] [ 1 > ] bi* and ] map-find-index ] unit-test
-{ f f f } [ 10 <iota> [ [ odd? ] [ 9 > ] bi* and ] map-find-index ] unit-test
-
-{ "abcdef" } [ f f "abcdef" subseq* ] unit-test
-{ "abcdef" } [ 0 f "abcdef" subseq* ] unit-test
-{ "ab" } [ f 2 "abcdef" subseq* ] unit-test
-{ "cdef" } [ 2 f "abcdef" subseq* ] unit-test
-{ "cd" } [ -4 -2 "abcdef" subseq* ] unit-test
-
-{ "foo" "" } [ "foo" [ blank? ] cut-when ] unit-test
-{ "foo" " " } [ "foo " [ blank? ] cut-when ] unit-test
-{ "" " foo" } [ " foo" [ blank? ] cut-when ] unit-test
-{ "foo" " bar" } [ "foo bar" [ blank? ] cut-when ] unit-test
-
-{ { 4 0 3 1 2 } } [ { 0 4 1 3 2 } 5 <iota> [ nth* ] curry map ] unit-test
-
-{ 1 "beef" } [ { "chicken" "beef" "moose" } [ length ] infimum-by* ] unit-test
-{ 0 "chicken" } [ { "chicken" "beef" "moose" } [ length ] supremum-by* ] unit-test
-{ 2 "moose" } [ { "chicken" "beef" "moose" } [ first ] supremum-by* ] unit-test
-{ f } [ f ?supremum ] unit-test
-{ f } [ { } ?supremum ] unit-test
-{ f } [ { f } ?supremum ] unit-test
-{ 3 } [ { 1 f 3 2 } ?supremum ] unit-test
-{ 3 } [ { 1 3 2 } ?supremum ] unit-test
-{ f } [ f ?infimum ] unit-test
-{ f } [ { } ?infimum ] unit-test
-{ f } [ { f } ?infimum ] unit-test
-{ 1 } [ { 1 f 3 2 } ?infimum ] unit-test
-{ 1 } [ { 1 3 2 } ?infimum ] unit-test
-
-{ 3/10 } [ 10 <iota> [ 3 < ] count* ] unit-test
-
-{ { 0 } } [ "ABA" "ABABA" start-all ] unit-test
-{ { 0 2 } } [ "ABA" "ABABA" start-all* ] unit-test
-{ { 0 3 } } [ "ABA" "ABAABA" start-all ] unit-test
-{ 1 } [ "ABA" "ABABA" count-subseq ] unit-test
-{ 2 } [ "ABA" "ABABA" count-subseq* ] unit-test
-
-{ 120000 } [ { 10 20 30 40 50 60 } 1 [ * ] 3 reduce-from ] unit-test
-
-{
- {
- { 2 4 }
- { 3 6 }
- { 4 8 }
- }
-} [ { 2 3 4 } [ 2 * ] map-zip ] unit-test
-
-{ }
-[ "test:" all-words [ name>> over prepend ] map-zip 2drop ] unit-test
-
-{ { 0 1 2 3 } } [ 8 <iota> [ 4 < ] take-while >array ] unit-test
-{ { } } [ { 15 16 } [ 4 < ] take-while >array ] unit-test
-{ { 0 1 2 } } [ 3 <iota> [ 4 < ] take-while >array ] unit-test
-
-{ { 4 5 6 7 } } [ 8 <iota> [ 4 < ] drop-while >array ] unit-test
-{ { 15 16 } } [ { 15 16 } [ 4 < ] drop-while >array ] unit-test
-{ { } } [ 3 <iota> [ 4 < ] drop-while >array ] unit-test
-
-{ { } } [ { } ", " interleaved ] unit-test
-{ { 1 } } [ { 1 } ", " interleaved ] unit-test
-{ { 1 ", " 2 } } [ { 1 2 } ", " interleaved ] unit-test
-{ "" } [ "" CHAR: _ interleaved ] unit-test
-{ "a" } [ "a" CHAR: _ interleaved ] unit-test
-{ "a_b" } [ "ab" CHAR: _ interleaved ] unit-test
-{ "a_b_c" } [ "abc" CHAR: _ interleaved ] unit-test
-{ "a_b_c_d" } [ "abcd" CHAR: _ interleaved ] unit-test
-
-{ 0 } [ { 1 2 3 4 } [ 5 > ] count-head ] unit-test
-{ 2 } [ { 1 2 3 4 } [ 3 < ] count-head ] unit-test
-{ 4 } [ { 1 2 3 4 } [ 5 < ] count-head ] unit-test
-
-{ 0 } [ { 1 2 3 4 } [ 5 > ] count-tail ] unit-test
-{ 2 } [ { 1 2 3 4 } [ 2 > ] count-tail ] unit-test
-{ 4 } [ { 1 2 3 4 } [ 5 < ] count-tail ] unit-test
-
-{ SBUF" aco" SBUF" ftr" } [ SBUF" factor" dup [ even? ] extract! ] unit-test
+++ /dev/null
-USING: accessors arrays assocs combinators fry generalizations
-grouping growable kernel locals make math math.order math.ranges
-sequences sequences.deep sequences.private sorting splitting
-vectors ;
-IN: sequences.extras
-
-: find-all ( ... seq quot: ( ... elt -- ... ? ) -- ... elts )
- [ <enumerated> ] dip '[ nip @ ] assoc-filter ; inline
-
-: reduce-from ( ... seq identity quot: ( ... prev elt -- ... next ) i -- ... result )
- [ swap ] 2dip each-from ; inline
-
-:: 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 ;
-
-: safe-subseq ( from to seq -- subseq )
- [ length '[ 0 _ clamp ] bi@ ] keep subseq ;
-
-: 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
-
-: map-like ( seq exemplar -- seq' )
- '[ _ like ] map ; inline
-
-: filter-all-subseqs-range ( ... seq range quot: ( ... subseq -- ... ) -- seq )
- [
- '[ <clumps> _ filter ] with map concat
- ] keepdd map-like ; inline
-
-: filter-all-subseqs ( ... seq quot: ( ... subseq -- ... ) -- seq )
- [ dup length [1,b] ] dip filter-all-subseqs-range ; inline
-
-:: longest-subseq ( seq1 seq2 -- subseq )
- seq1 length :> len1
- seq2 length :> len2
- 0 :> n!
- 0 :> end!
- len1 1 + [ len2 1 + 0 <array> ] replicate :> table
- len1 [1,b] [| x |
- len2 [1,b] [| y |
- x 1 - seq1 nth-unsafe
- y 1 - seq2 nth-unsafe = [
- y 1 - x 1 - table nth-unsafe nth-unsafe 1 + :> len
- len y x table nth-unsafe set-nth-unsafe
- len n > [ len n! x end! ] when
- ] [ 0 y x table nth-unsafe set-nth-unsafe ] if
- ] each
- ] each end n - end seq1 subseq ;
-
-: pad-longest ( seq1 seq2 elt -- seq1 seq2 )
- [ 2dup max-length ] dip [ pad-tail ] 2curry bi@ ;
-
-:: pad-center ( seq n elt -- padded )
- n seq length [-] :> extra
- extra 2/ :> left
- extra left - :> right
- left elt <repetition> seq right elt <repetition>
- seq 3append-as ;
-
-: change-nths ( ... indices seq quot: ( ... elt -- ... elt' ) -- ... )
- [ change-nth ] 2curry each ; inline
-
-: push-if-index ( ..a elt i quot: ( ..a elt i -- ..b ? ) accum -- ..b )
- [ keepd ] dip rot [ push ] [ 2drop ] if ; inline
-
-: push-if* ( ..a elt quot: ( ..a elt -- ..b obj/f ) accum -- ..b )
- [ call ] dip [ push ] [ drop ] if* ; inline
-
-<PRIVATE
-
-: (index-selector-as) ( quot length exampler -- selector accum )
- new-resizable [ [ push-if-index ] 2curry ] keep ; inline
-
-: (selector-as*) ( quot length exemplar -- selector accum )
- new-resizable [ [ push-if* ] 2curry ] keep ; inline
-
-PRIVATE>
-
-: index-selector-as ( quot exemplar -- selector accum )
- [ length ] keep (index-selector-as) ; inline
-
-: index-selector ( quot -- selector accum )
- V{ } index-selector-as ; inline
-
-: selector-as* ( quot exemplar -- selector accum )
- [ length ] keep (selector-as*) ; inline
-
-: selector* ( quot -- selector accum ) V{ } selector-as* ; inline
-
-: filter-index-as ( ... seq quot: ( ... elt i -- ... ? ) exemplar -- ... seq' )
- pick length over [ (index-selector-as) [ each-index ] dip ] 2curry dip like ; inline
-
-: filter-index ( ... seq quot: ( ... elt i -- ... ? ) -- ... seq' )
- over filter-index-as ; inline
-
-: even-indices ( seq -- seq' )
- [ length 1 + 2/ ] keep [
- [ [ 2 * ] dip nth-unsafe ] curry
- ] keep map-integers ;
-
-: odd-indices ( seq -- seq' )
- [ length 2/ ] keep [
- [ [ 2 * 1 + ] dip nth-unsafe ] curry
- ] keep map-integers ;
-
-: compact ( ... seq quot: ( ... elt -- ... ? ) elt -- ... seq' )
- [ split-when harvest ] dip join ; inline
-
-: collapse ( ... seq quot: ( ... elt -- ... ? ) elt -- ... seq' )
- [ split-when ] dip
- [ [ harvest ] dip join ]
- [ [ first empty? ] dip [ prepend ] curry when ]
- [ [ last empty? ] dip [ append ] curry when ]
- 2tri ; inline
-
-:: slice-when ( seq quot: ( elt -- ? ) -- seq' )
- seq length :> len
- 0 [ len dupd < ] [
- dup seq quot find-from drop
- [ 2dup = [ 1 + ] when ] [ len ] if*
- [ seq <slice> ] keep len or swap
- ] produce nip ; inline
-
-: cut-slice* ( seq n -- before after )
- [ head-slice* ] [ tail-slice* ] 2bi ;
-
-: ?<slice> ( from/f to/f sequence -- slice )
- [ [ 0 ] unless* ] 2dip
- over [ nip [ length ] [ ] bi ] unless
- <slice> ; inline
-
-: sequence>slice ( sequence -- slice )
- [ drop 0 ] [ length ] [ ] tri <slice> ; inline
-
-: slice-order-by-from ( slice1 slice2 -- slice-lt slice-gt )
- 2dup [ from>> ] bi@ > [ swap ] when ; inline
-
-: ordered-slices-range ( slice-lt slice-gt -- to from )
- [ to>> ] [ from>> ] bi* ;
-
-: unordered-slices-range ( slice1 slice2 -- to from )
- slice-order-by-from ordered-slices-range ;
-
-: ordered-slices-overlap? ( slice-lt slice-gt -- ? )
- ordered-slices-range > ; inline
-
-: unordered-slices-overlap? ( slice1 slice2 -- ? )
- unordered-slices-range > ; inline
-
-: slices-overlap? ( slice1 slice2 -- ? )
- unordered-slices-overlap? ;
-
-: ordered-slices-touch? ( slice-lt slice-gt -- ? )
- ordered-slices-range >= ; inline
-
-: unordered-slices-touch? ( slice1 slice2 -- ? )
- unordered-slices-range >= ; inline
-
-: slices-touch? ( slice1 slice2 -- ? )
- unordered-slices-touch? ;
-
-ERROR: slices-don't-touch slice1 slice2 ;
-
-: merge-slices ( slice1 slice2 -- slice/* )
- slice-order-by-from
- 2dup ordered-slices-touch? [
- [ from>> ] [ [ to>> ] [ seq>> ] bi ] bi* <slice>
- ] [
- slices-don't-touch
- ] if ;
-
-: rotate ( seq n -- seq' )
- over length mod dup 0 >= [ cut ] [ abs cut* ] if prepend ;
-
-ERROR: underlying-mismatch slice1 slice2 ;
-
-: ensure-same-underlying ( slice1 slice2 -- slice1 slice2 )
- 2dup [ seq>> ] bi@ eq? [ underlying-mismatch ] unless ;
-
-: span-slices ( slice1 slice2 -- slice )
- ensure-same-underlying
- [ [ from>> ] bi@ min ]
- [ [ to>> ] bi@ max ]
- [ drop seq>> ] 2tri <slice> ;
-
-: ?span-slices ( slice1/f slice2/f -- slice )
- 2dup and [ span-slices ] [ or ] if ;
-
-:: rotate! ( seq n -- )
- seq length :> len
- n len mod dup 0 < [ len + ] when seq bounds-check drop 0 over
- [ 2dup = ] [
- [ seq exchange-unsafe ] [ [ 1 + ] bi@ ] 2bi
- dup len = [ drop over ] when
- 2over = [ -rot nip over ] when
- ] until 3drop ;
-
-: all-rotations ( seq -- seq' )
- dup length <iota> [ rotate ] with map ;
-
-<PRIVATE
-
-: (appender-for) ( quot length exemplar -- appender accum )
- new-resizable [ [ push-all ] curry compose ] keep ; inline
-
-PRIVATE>
-
-: appender-for ( quot exemplar -- appender accum )
- [ length ] keep (appender-for) ; inline
-
-: appender ( quot -- appender accum )
- V{ } appender-for ; inline
-
-: map-concat-as ( ... seq quot: ( ... elt -- ... newelt ) exemplar -- ... newseq )
- [ appender-for [ each ] dip ] keep like ; inline
-
-: >resizable ( seq -- accum ) ! fixes map-concat "cannot apply call to run-time..."
- [ length ] keep [ new-resizable ] [ append! ] bi ;
-
-: map-concat ( ... seq quot: ( ... elt -- ... newelt ) -- ... newseq )
- over empty? [ 2drop { } ] [
- [ [ first ] dip call ] 2keep rot [
- >resizable [ '[ @ _ push-all ] 1 each-from ] keep
- ] keep like
- ] if ; inline
-
-: map-filter-as ( ... seq map-quot: ( ... elt -- ... newelt ) filter-quot: ( ... newelt -- ... ? ) exemplar -- ... subseq )
- reach length over
- [ (selector-as) [ compose each ] dip ] 2curry dip like ; inline
-
-: map-filter ( ... seq map-quot: ( ... elt -- ... newelt ) filter-quot: ( ... newelt -- ... ? ) -- ... subseq )
- pick map-filter-as ; inline
-
-: map-sift ( ... seq quot: ( ... elt -- ... newelt ) -- ... newseq )
- [ ] map-filter ; inline
-
-: map-harvest ( ... seq quot: ( ... elt -- ... newelt ) -- ... newseq )
- [ empty? not ] map-filter ; inline
-
-<PRIVATE
-
-: (setup-each-from) ( i seq -- n quot )
- [ length over [-] swap ] keep '[ _ + _ nth-unsafe ] ; inline
-
-: setup-each-from ( i seq quot -- n quot' )
- [ (setup-each-from) ] dip compose ; inline
-
-PRIVATE>
-
-: map-from-as ( ... seq quot: ( ... elt -- ... newelt ) i exemplar -- ... newseq )
- [ -rot setup-each-from ] dip map-integers ; inline
-
-: map-from ( ... seq quot: ( ... elt -- ... newelt ) i -- ... newseq )
- pick map-from-as ; inline
-
-<PRIVATE
-
-: push-map-if ( ..a elt filter-quot: ( ..a elt -- ..b ? ) map-quot: ( ..a elt -- ..b newelt ) accum -- ..b )
- [ keep over ] 2dip [ when ] dip rot [ push ] [ 2drop ] if ; inline
-
-: (filter-mapper-for) ( filter-quot map-quot length exempler -- filter-mapper accum )
- new-resizable [ [ push-map-if ] 3curry ] keep ; inline
-
-: filter-mapper-for ( filter-quot map-quot exemplar -- filter-mapper accum )
- [ length ] keep (filter-mapper-for) ; inline
-
-: filter-mapper ( filter-quot map-quot -- filter-mapper accum )
- V{ } filter-mapper-for ; inline
-
-PRIVATE>
-
-: filter-map-as ( ... seq filter-quot: ( ... elt -- ... ? ) map-quot: ( ... elt -- ... newelt ) exemplar -- ... newseq )
- reach length over
- [ (filter-mapper-for) [ each ] dip ] 2curry dip like ; inline
-
-: filter-map ( ... seq filter-quot: ( ... elt -- ... ? ) map-quot: ( ... elt -- ... newelt ) -- ... newseq )
- pick filter-map-as ; inline
-
-: 2map-sum ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... n ) -- ... n )
- [ 0 ] 3dip [ dip + ] curry [ rot ] prepose 2each ; inline
-
-: 2count ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... ? ) -- ... n )
- [ 1 0 ? ] compose 2map-sum ; inline
-
-: 3each-from
- ( ... seq1 seq2 seq3 quot: ( ... elt1 elt2 elt3 -- ... ) i -- ... )
- [ (3each) ] dip -rot (each-integer) ; inline
-
-: 3map-reduce
- ( ..a seq1 seq2 seq3 map-quot: ( ..a elt1 elt2 elt3 -- ..b intermediate ) reduce-quot: ( ..b prev intermediate -- ..a next ) -- ..a result )
- [ [ [ [ first ] tri@ ] 3keep ] dip [ 3dip ] keep ] dip compose 1 3each-from ; inline
-
-: round-robin ( seq -- newseq )
- [ { } ] [
- [ longest length <iota> ] keep
- [ [ ?nth ] with map ] curry map concat sift
- ] if-empty ;
-
-: sift-as ( seq exemplar -- newseq )
- [ ] swap filter-as ;
-
-: sift! ( seq -- newseq )
- [ ] filter! ;
-
-: harvest-as ( seq exemplar -- newseq )
- [ empty? not ] swap filter-as ;
-
-: harvest! ( seq -- newseq )
- [ empty? ] reject! ;
-
-: head-as ( seq n exemplar -- seq' )
- [ head-slice ] [ like ] bi* ; inline
-
-: head*-as ( seq n exemplar -- seq' )
- [ head-slice* ] [ like ] bi* ; inline
-
-: tail-as ( seq n exemplar -- seq' )
- [ tail-slice ] [ like ] bi* ; inline
-
-: tail*-as ( seq n exemplar -- seq' )
- [ tail-slice* ] [ like ] bi* ; inline
-
-: trim-as ( ... seq quot: ( ... elt -- ... ? ) exemplar -- ... newseq )
- [ trim-slice ] [ like ] bi* ; inline
-
-: ?trim ( seq quot: ( elt -- ? ) -- seq/newseq )
- over empty? [ drop ] [
- over [ first-unsafe ] [ last-unsafe ] bi pick either?
- [ trim ] [ drop ] if
- ] if ; inline
-
-: ?trim-head ( seq quot: ( elt -- ? ) -- seq/newseq )
- over empty? [ drop ] [
- over first-unsafe over call
- [ trim-head ] [ drop ] if
- ] if ; inline
-
-: ?trim-tail ( seq quot: ( elt -- ? ) -- seq/newseq )
- over empty? [ drop ] [
- over last-unsafe over call
- [ trim-tail ] [ drop ] if
- ] if ; inline
-
-: unsurround ( newseq seq2 seq3 -- seq1 )
- [ ?head drop ] [ ?tail drop ] bi* ;
-
-: 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
-
-<PRIVATE
-
-: (2each-index) ( seq1 seq2 quot -- n quot' )
- [ setup-2each [ keep ] curry ] dip compose ; inline
-
-PRIVATE>
-
-: 2each-index ( ... seq1 seq2 quot: ( ... elt1 elt2 index -- ... ) -- ... )
- (2each-index) each-integer ; inline
-
-: 2map-into ( seq1 seq2 quot into -- )
- [ (2each) ] dip collect ; inline
-
-: 2map! ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... newelt ) -- ... seq1 )
- pick [ 2map-into ] keep ; inline
-
-: 2map-index ( ... seq1 seq2 quot: ( ... elt1 elt2 index -- ... newelt ) -- ... newseq )
- pick [ (2each-index) ] dip map-integers ; inline
-
-TUPLE: evens { seq read-only } ;
-
-C: <evens> evens
-
-M: evens length seq>> length 1 + 2/ ; inline
-
-M: evens virtual@ [ 2 * ] [ seq>> ] bi* ; inline
-
-M: evens virtual-exemplar seq>> ; inline
-
-INSTANCE: evens virtual-sequence
-
-TUPLE: odds { seq read-only } ;
-
-C: <odds> odds
-
-M: odds length seq>> length 2/ ; inline
-
-M: odds virtual@ [ 2 * 1 + ] [ seq>> ] bi* ; inline
-
-M: odds virtual-exemplar seq>> ; inline
-
-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 ;
-
-<PRIVATE
-
-: push-index-if ( ..a elt i quot: ( ..a elt -- ..b ? ) accum -- ..b )
- [ dip ] dip rot [ push ] [ 2drop ] if ; inline
-
-PRIVATE>
-
-: arg-where ( ... seq quot: ( ... elt -- ... ? ) -- ... indices )
- over length <vector> [
- [ push-index-if ] 2curry each-index
- ] keep ; inline
-
-: arg-sort ( seq -- indices )
- zip-index sort-keys values ;
-
-: first= ( seq elt -- ? ) [ first ] dip = ; inline
-: second= ( seq elt -- ? ) [ second ] dip = ; inline
-: third= ( seq elt -- ? ) [ third ] dip = ; inline
-: fourth= ( seq elt -- ? ) [ fourth ] dip = ; inline
-: last= ( seq elt -- ? ) [ last ] dip = ; inline
-: nth= ( n seq elt -- ? ) [ nth ] dip = ; inline
-
-: first? ( ... seq quot: ( ... elt -- ... ? ) -- ... ? ) [ first ] dip call ; inline
-: second? ( ... seq quot: ( ... elt -- ... ? ) -- ... ? ) [ second ] dip call ; inline
-: third? ( ... seq quot: ( ... elt -- ... ? ) -- ... ? ) [ third ] dip call ; inline
-: fourth? ( ... seq quot: ( ... elt -- ... ? ) -- ... ? ) [ fourth ] dip call ; inline
-: last? ( ... seq quot: ( ... elt -- ... ? ) -- ... ? ) [ last ] dip call ; inline
-: nth? ( ... n seq quot: ( ... elt -- ... ? ) -- ... ? ) [ nth ] dip call ; inline
-
-: loop>sequence ( quot: ( ..a -- ..a obj/f ) exemplar -- seq )
- [ '[ [ @ [ [ , ] when* ] keep ] loop ] ] dip make ; inline
-
-: loop>array ( quot: ( ..a -- ..a obj/f ) -- seq )
- { } loop>sequence ; inline
-
-: loop>sequence* ( quot: ( ..a -- ..a obj ? ) exemplar -- seq )
- [ '[ [ @ [ [ , ] when* ] [ ] bi* ] loop ] ] dip make ; inline
-
-: loop>array* ( quot: ( ..a -- ..a obj ? ) -- seq )
- { } loop>sequence* ; inline
-
-<PRIVATE
-
-: (reverse) ( seq -- newseq )
- dup [ length ] keep new-sequence
- [ 0 swap copy-unsafe ] keep reverse! ;
-
-PRIVATE>
-
-: reverse-as ( seq exemplar -- newseq )
- [ (reverse) ] [ like ] bi* ;
-
-: map-product ( ... seq quot: ( ... elt -- ... n ) -- ... n )
- [ 1 ] 2dip [ dip * ] curry [ swap ] prepose each ; inline
-
-: insert-nth! ( elt n seq -- )
- [ length ] keep ensure swap pick (a,b]
- over '[ [ 1 + ] keep _ move-unsafe ] each
- set-nth-unsafe ;
-
-: set-nths ( value indices seq -- )
- swapd '[ _ swap _ set-nth ] each ; inline
-
-: set-nths-unsafe ( value indices seq -- )
- swapd '[ _ swap _ set-nth-unsafe ] each ; inline
-
-: flatten1 ( obj -- seq )
- [
- [
- dup branch? [
- [ dup branch? [ % ] [ , ] if ] each
- ] [ , ] if
- ]
- ] keep dup branch? [ drop f ] unless make ;
-
-<PRIVATE
-
-: (map-find-index) ( seq quot find-quot -- result i elt )
- [ [ f ] 2dip [ [ nip ] 2dip call dup ] curry ] dip call
- [ [ [ drop f ] unless ] keep ] dip ; inline
-
-PRIVATE>
-
-: map-find-index ( ... seq quot: ( ... elt index -- ... result/f ) -- ... result i elt )
- [ find-index ] (map-find-index) ; inline
-
-: filter-length ( seq n -- seq' ) '[ length _ = ] filter ;
-
-: all-shortest ( seqs -- seqs' ) dup shortest length filter-length ;
-
-: all-longest ( seqs -- seqs' ) dup longest length filter-length ;
-
-: remove-first ( obj seq -- seq' )
- [ index ] keep over [ remove-nth ] [ nip ] if ;
-
-: remove-first! ( obj seq -- seq )
- [ index ] keep over [ remove-nth! ] [ nip ] if ;
-
-: remove-last ( obj seq -- seq' )
- [ last-index ] keep over [ remove-nth ] [ nip ] if ;
-
-: remove-last! ( obj seq -- seq )
- [ last-index ] keep over [ remove-nth! ] [ nip ] if ;
-
-: ?first2 ( seq -- first/f second/f )
- dup length {
- { 0 [ drop f f ] }
- { 1 [ first-unsafe f ] }
- [ drop first2-unsafe ]
- } case ;
-
-: ?first3 ( seq -- first/f second/f third/f )
- dup length {
- { 0 [ drop f f f ] }
- { 1 [ first-unsafe f f ] }
- { 2 [ first2-unsafe f ] }
- [ drop first3-unsafe ]
- } case ;
-
-: ?first4 ( seq -- first/f second/f third/f fourth/f )
- dup length {
- { 0 [ drop f f f f ] }
- { 1 [ first-unsafe f f f ] }
- { 2 [ first2-unsafe f f ] }
- { 3 [ first3-unsafe f ] }
- [ drop first4-unsafe ]
- } case ;
-
-: cut-when ( ... seq quot: ( ... elt -- ... ? ) -- ... before after )
- [ find drop ] keepd swap
- [ cut ] [ f over like ] if* ; inline
-
-: nth* ( n seq -- elt )
- [ length 1 - swap - ] [ nth ] bi ; inline
-
-: each-index-from ( ... seq quot: ( ... elt index -- ... ) i -- ... )
- -rot (each-index) (each-integer) ; inline
-
-<PRIVATE
-
-: select-by* ( ... seq quot: ( ... elt -- ... x ) compare: ( obj1 obj2 -- ? ) -- ... i elt )
- [
- [ keep swap ] curry [ dip ] curry
- [ [ first 0 ] dip call ] 2keep
- [ 2curry 3dip 5 npick pick ] curry
- ] [
- [ [ 3drop ] [ [ 3drop ] 3dip ] if ] compose
- ] bi* compose 1 each-index-from nip swap ; inline
-
-PRIVATE>
-
-: supremum-by* ( ... seq quot: ( ... elt -- ... x ) -- ... i elt )
- [ after? ] select-by* ; inline
-
-: infimum-by* ( ... seq quot: ( ... elt -- ... x ) -- ... i elt )
- [ before? ] select-by* ; inline
-
-: ?supremum ( seq/f -- elt/f )
- [ f ] [
- [ ] [ 2dup and [ max ] [ dupd ? ] if ] map-reduce
- ] if-empty ;
-
-: ?infimum ( seq/f -- elt/f )
- [ f ] [
- [ ] [ 2dup and [ min ] [ dupd ? ] if ] map-reduce
- ] if-empty ;
-
-: change-last ( seq quot -- )
- [ drop length 1 - ] [ change-nth ] 2bi ; inline
-
-: change-last-unsafe ( seq quot -- )
- [ drop length 1 - ] [ change-nth-unsafe ] 2bi ; inline
-
-: replicate-into ( ... seq quot: ( ... -- ... newelt ) -- ... )
- over [ length ] 2dip '[ _ dip _ set-nth-unsafe ] each-integer ; inline
-
-: count* ( ... seq quot: ( ... elt -- ... ? ) -- ... % )
- over [ count ] [ length ] bi* / ; inline
-
-: find-last-index ( ... seq quot: ( ... elt i -- ... ? ) -- ... i elt )
- [ [ 1 - ] dip find-last-integer ] (find-index) ; inline
-
-: map-find-last-index ( ... seq quot: ( ... elt index -- ... result/f ) -- ... result i elt )
- [ find-last-index ] (map-find-index) ; inline
-
-:: (start-all) ( subseq seq increment -- indices )
- 0
- [ [ subseq seq ] dip subseq-start-from dup ]
- [ [ increment + ] keep ] produce nip ;
-
-: start-all ( subseq seq -- indices )
- over length (start-all) ; inline
-
-: start-all* ( subseq seq -- indices )
- 1 (start-all) ; inline
-
-: count-subseq ( subseq seq -- n )
- start-all length ; inline
-
-: count-subseq* ( subseq seq -- n )
- start-all* length ; inline
-
-: map-zip ( quot: ( x -- y ) -- alist )
- '[ _ keep swap ] map>alist ; inline
-
-: map-keys ( assoc quot: ( key -- key' ) -- assoc )
- '[ _ dip ] assoc-map ; inline
-
-: map-values ( assoc quot: ( value -- value' ) -- assoc )
- '[ swap _ dip swap ] assoc-map ; inline
-
-: take-while ( ... seq quot: ( ... elt -- ... ? ) -- head-slice )
- [ '[ @ not ] find drop ] keepd swap
- [ dup length ] unless* head-slice ; inline
-
-: drop-while ( ... seq quot: ( ... elt -- ... ? ) -- tail-slice )
- [ '[ @ not ] find drop ] keepd swap
- [ dup length ] unless* tail-slice ; inline
-
-: count-head ( seq quot -- n )
- [ not ] compose [ find drop ] 2keep drop length or ; inline
-
-: count-tail ( seq quot -- n )
- [ not ] compose [ find-last drop ] 2keep drop
- length swap [ - 1 - ] when* ; inline
-
-:: interleaved-as ( seq glue exemplar -- newseq )
- seq length dup 1 - + 0 max exemplar new-sequence :> newseq
- seq [ 2 * newseq set-nth-unsafe ] each-index
- seq length 1 - [ 2 * 1 + glue swap newseq set-nth-unsafe ] each-integer
- newseq ;
-
-: interleaved ( seq glue -- newseq )
- over interleaved-as ;
-
-: extract! ( ... seq quot: ( ... elt -- ... ? ) -- ... seq )
- [ dup ] compose over [ length ] keep new-resizable
- [ [ push-if ] 2curry reject! ] keep swap like ; inline
+++ /dev/null
-Contains sequence operations that are not commonly needed. Most of these words are elaborations on functions already available in the main sequences vocabulary.
+++ /dev/null
-Doug Coleman
+++ /dev/null
-! Copyright (C) 2013 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax kernel sequences sets ;
-IN: sets.extras
-
-HELP: setwise-xor
-{ $values
- { "seq1" sequence } { "seq2" sequence }
- { "set" set }
-}
-{ $description "Converts the sequences to sets and takes the element-wise " { $link xor } ". Outputs elements that are in either set but not in both." }
-{ $example
- "USING: sets.extras prettyprint ;"
- "{ 1 2 3 } { 2 3 4 } setwise-xor ."
- "{ 1 4 }"
-}
-{ $notes "Known as setxor1d in numpy." } ;
-
-HELP: symmetric-diff
-{ $values { "set1" set } { "set2" set } { "set" set } }
-{ $description "Find the symmetric difference of two sets. Outputs a set containing elements that in either set but not in both." } ;
-
-HELP: proper-subset?
-{ $values { "set1" set } { "set2" set } { "?" boolean } }
-{ $description "Find whether " { $snippet "set1" } " is a proper subset of " { $snippet "set2" } ". Returns true if " { $snippet "set1" } " is a subset of " { $snippet "set2" } " but " { $snippet "set2" } " is not a subset of " { $snippet "set1" } "." } ;
-
-ARTICLE: "sets.extras" "Extra sets words"
-"The " { $vocab-link "sets.extras" } " vocabulary is a collection of words related to sets."
-$nl
-"To take the element-wise xor of two sequences as if they were sets:"
-{ $subsections setwise-xor } ;
-
-ABOUT: "sets.extras"
+++ /dev/null
-! Copyright (C) 2013 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: math sequences sets.extras tools.test ;
-
-{ { } } [ { } { } setwise-xor ] unit-test
-{ { 1 } } [ { 1 } { } setwise-xor ] unit-test
-{ { 1 } } [ { } { 1 } setwise-xor ] unit-test
-{ { } } [ { 1 } { 1 } setwise-xor ] unit-test
-{ { 1 4 5 7 } } [ { 1 2 3 2 4 } { 2 3 5 7 5 } setwise-xor ] unit-test
-
-{ { } } [ { } { } symmetric-diff ] unit-test
-{ { 1 2 3 } } [ { 1 2 3 } { } symmetric-diff ] unit-test
-{ { 1 2 3 } } [ { } { 1 2 3 } symmetric-diff ] unit-test
-{ { 1 2 4 5 } } [ { 1 2 3 } { 3 4 5 } symmetric-diff ] unit-test
-
-{ f } [ { } { } proper-subset? ] unit-test
-{ f } [ { 1 2 } { 1 2 } proper-subset? ] unit-test
-{ f } [ { 1 2 3 } { 1 2 } proper-subset? ] unit-test
-{ t } [ { 1 2 } { 1 2 3 } proper-subset? ] unit-test
-
-{ "abc" } [ "abc" non-repeating ] unit-test
-{ "abc" } [ "abcddd" non-repeating ] unit-test
-{ "" } [ "aabbcc" non-repeating ] unit-test
-
-{ HS{ 0 10 20 30 40 } } [ 5 <iota> [ 10 * ] mapped-set ] unit-test
-
-{ { 1 2 4 } } [ { 1 2 3 4 5 } [ 2/ ] unique-by ] unit-test
+++ /dev/null
-! Copyright (C) 2013 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: assocs fry hash-sets kernel locals sequences
-sequences.extras sets ;
-IN: sets.extras
-
-: setwise-xor ( seq1 seq2 -- set )
- [ append members ] [ intersect ] 2bi diff ;
-
-: symmetric-diff ( set1 set2 -- set )
- [ union ] [ intersect ] 2bi diff ;
-
-: proper-subset? ( set1 set2 -- ? )
- 2dup subset? [ swap subset? not ] [ 2drop f ] if ;
-
-: superset? ( set1 set2 -- ? )
- swap subset? ;
-
-: disjoint? ( set1 set2 -- ? )
- intersects? not ;
-
-:: non-repeating ( seq -- seq' )
- HS{ } clone :> visited
- 0 seq new-resizable :> accum
- seq [
- accum over visited ?adjoin
- [ push ] [ remove-first! drop ] if
- ] each accum seq like ;
-
-: adjoin-at* ( value key assoc -- set )
- [ [ HS{ } clone ] unless* [ adjoin ] keep dup ] change-at ;
-
-: mapped-set ( ... seq quot: ( ... elt -- ... newelt ) -- ... set )
- over length <hash-set> [
- '[ @ _ adjoin ] each
- ] keep ; inline
-
-: unique-by ( seq quot: ( elt -- key ) -- seq' )
- over length <hash-set> '[ @ _ ?adjoin ] filter ; inline
+++ /dev/null
-collections
+++ /dev/null
-John Benediktsson
+++ /dev/null
-! Copyright (C) 2013 John Benediktsson.
-! See http://factorcode.org/license.txt for BSD license.
-
-USING: help.markup help.syntax kernel strings ;
-
-IN: tools.which
-
-HELP: which
-{ $values { "command" string } { "file/f" "the first matching path or " { $link f } } }
-{ $description "Returns the full path of the executable that would have been executed if " { $snippet "command" } " had been entered at the shell prompt." } ;
+++ /dev/null
-! Copyright (C) 2012 John Benediktsson
-! See http://factorcode.org/license.txt for BSD license
-
-USING: arrays assocs combinators.short-circuit command-line
-environment io io.backend io.files io.files.info io.pathnames
-kernel namespaces sequences sets splitting system unicode ;
-
-IN: tools.which
-
-<PRIVATE
-
-: executable? ( path -- ? )
- {
- [ exists? ]
- [ file-executable? ]
- [ file-info directory? not ]
- } 1&& ;
-
-: split-path ( paths -- seq )
- os windows? ";" ":" ? split harvest ;
-
-: path-extensions ( command -- commands )
- "PATHEXT" os-env [
- split-path 2dup [ [ >lower ] bi@ tail? ] with any?
- [ drop 1array ] [ [ append ] with map ] if
- ] [ 1array ] if* ;
-
-: find-which ( commands paths -- file/f )
- [ normalize-path ] map members
- cartesian-product flip concat
- [ prepend-path ] { } assoc>map
- [ executable? ] find nip ;
-
-: (which) ( command path -- file/f )
- split-path os windows? [
- [ path-extensions ] [ "." prefix ] bi*
- ] [ [ 1array ] dip ] if find-which ;
-
-PRIVATE>
-
-: which ( command -- file/f )
- "PATH" os-env (which) ;
-
-: ?which ( command -- file/command )
- [ which ] [ or ] bi ;
-
-: run-which ( -- )
- command-line get [ which [ print ] when* ] each ;
-
-MAIN: run-which
projects / factor.git / commitdiff