splitting.extras: adding split* and split-find.

diff --git a/extra/splitting/extras/extras-docs.factor b/extra/splitting/extras/extras-docs.factor
new file mode 100644 (file)
index 0000000..96f4971
--- /dev/null
+++ b/extra/splitting/extras/extras-docs.factor
@@ -0,0 +1,16 @@
+USING: help.markup help.syntax sequences splitting strings ;
+IN: splitting.extras
+
+HELP: split*-when
+{ $values { "seq" "a sequence" } { "quot" { $quotation "( ... elt -- ... ? )" } } { "pieces" "a new array" } }
+{ $description "A variant of " { $link split-when } " that includes the elements along which the sequence was split." }
+{ $examples { $example "USING: ascii kernel prettyprint splitting.extras ;" "\"hello,world-how.are:you\" [ letter? not ] split*-when ." "{ \"hello\" \",\" \"world\" \"-\" \"how\" \".\" \"are\" \":\" \"you\" }" } } ;
+
+HELP: split*
+{ $values { "seq" "a sequence" } { "separators" "a sequence" } { "pieces" "a new array" } }
+{ $description "A variant of " { $link split } " that includes the elements along which the sequence was split." }
+{ $examples { $example "USING: prettyprint splitting.extras ;" "\"hello world-how are you?\" \" -\" split* ." "{ \"hello\" \" \" \"world\" \"-\" \"how\" \" \" \"are\" \" \" \"you?\" }" } } ;
+
+HELP: split-find
+{ $values { "seq" "a sequence" } { "quot" { $quotation "( seq -- i )" } } { "pieces" "a new array" } }
+{ $description "Splits a sequence into slices using the provided quotation to find split points." } ;

diff --git a/extra/splitting/extras/extras-tests.factor b/extra/splitting/extras/extras-tests.factor
new file mode 100644 (file)
index 0000000..fd8bd2d
--- /dev/null
+++ b/extra/splitting/extras/extras-tests.factor
@@ -0,0 +1,28 @@
+
+USING: ascii kernel math sequences strings tools.test ;
+
+IN: splitting.extras
+
+{ { } } [ { } { 0 } split* ] unit-test
+{ { { 1 2 3 } } } [ { 1 2 3 } { 0 } split* ] unit-test
+{ { { 0 } } } [ { 0 } { 0 } split* ] unit-test
+{ { { 0 } { 0 } } } [ { 0 0 } { 0 } split* ] unit-test
+{ { { 1 2 } { 0 } { 3 } { 0 } { 0 } } } [ { 1 2 0 3 0 0 } { 0 } split* ] unit-test
+{ { "hello" } } [ "hello" " " split* ] unit-test
+{ { " " " " "hello" } } [ "  hello" " " split* ] unit-test
+{ { "hello" " " " " " " "world" } } [ "hello   world" " " split* ] unit-test
+{ { "hello" " " " " " " "world" " " } } [ "hello   world " " " split* ] unit-test
+
+{ { } } [ { } [ 0 > ] split*-when ] unit-test
+{ { { 0 } } } [ { 0 } [ 0 > ] split*-when ] unit-test
+{ { { 0 0 } } } [ { 0 0 } [ 0 > ] split*-when ] unit-test
+{ { { 1 } { 2 } { 0 } { 3 } { 0 0 } } } [ { 1 2 0 3 0 0 } [ 0 > ] split*-when ] unit-test
+{ { { 1 } { 2 3 } { 1 } { 4 5 } { 1 } { 6 } } } [
+    1 { 1 2 3 1 4 5 1 6 } [ dupd = ] split*-when nip
+] unit-test
+
+{ { "hello" " " " " " " "world" } } [
+    "hello   world"
+    [ [ blank? ] find drop ] split-find
+    [ >string ] map
+] unit-test

diff --git a/extra/splitting/extras/extras.factor b/extra/splitting/extras/extras.factor
new file mode 100644 (file)
index 0000000..e950a60
--- /dev/null
+++ b/extra/splitting/extras/extras.factor
@@ -0,0 +1,34 @@
+USING: kernel math sequences ;
+
+IN: splitting.extras
+
+<PRIVATE
+
+: (split*) ( n seq quot: ( ... elt -- ... ? ) slice-quot -- pieces )
+    pick [
+        swap curry [ [ 1 + ] when ] prepose [ 2keep ] curry
+        [ 2dup = ] prepose [ [ 1 + ] when swap ] compose [
+            [ find-from drop dup ] 2curry [ keep -rot ] curry
+        ] dip produce nip
+    ] 2keep swap [
+        [ length [ swapd dupd < ] keep ] keep
+    ] dip 2curry [ suffix ] compose [ drop ] if ; inline
+
+PRIVATE>
+
+: split*-when ( ... seq quot: ( ... elt -- ... ? ) -- ... pieces )
+    [ 0 ] 2dip [ subseq ] (split*) ; inline
+
+: split*-when-slice ( ... seq quot: ( ... elt -- ... ? ) -- ... pieces )
+    [ 0 ] 2dip [ <slice> ] (split*) ; inline
+
+: split* ( seq separators -- pieces )
+    [ member? ] curry split*-when ; inline
+
+: split*-slice ( seq separators -- pieces )
+    [ member? ] curry split*-when-slice ; inline
+
+: split-find ( seq quot: ( seq -- i ) -- pieces )
+    [ dup empty? not ] swap [ [ dup ] ] dip
+    [ [ [ 1 ] when-zero cut-slice swap ] [ f swap ] if* ] compose
+    compose produce nip ; inline