grouping.extras: having some fun with clumps.

diff --git a/extra/grouping/extras/extras-tests.factor b/extra/grouping/extras/extras-tests.factor
new file mode 100644 (file)
index 0000000..dc719e2
--- /dev/null
+++ b/extra/grouping/extras/extras-tests.factor
@@ -0,0 +1,20 @@
+USING: arrays tools.test ;
+IN: grouping.extras
+
+{ { } } [ { 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

diff --git a/extra/grouping/extras/extras.factor b/extra/grouping/extras/extras.factor
new file mode 100644 (file)
index 0000000..557c3ab
--- /dev/null
+++ b/extra/grouping/extras/extras.factor
@@ -0,0 +1,35 @@
+USING: accessors combinators fry grouping.private kernel macros
+math math.ranges sequences sequences.generalizations
+sequences.private ;
+
+IN: grouping.extras
+
+: 2clump-map ( seq quot: ( elt1 elt2 -- newelt ) -- seq' )
+    [ dup 1 short tail-slice ] dip { } 2map-as ; inline
+
+: 3clump-map ( seq quot: ( elt1 elt2 elt3 -- newelt ) -- seq' )
+    [
+        dup [ 1 short tail-slice ] [ 2 short tail-slice ] bi
+    ] dip { } 3map-as ; inline
+
+MACRO: nclump-map ( seq quot n -- result )
+    [ [1,b) [ [ short tail-slice ] curry ] map swap ] keep
+    '[ _ dup _ cleave _ { } _ nmap-as ] ;
+
+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 ;