grouping: add circular clumps (e.g. { 1 2 3 4 } 3 circular-clump => { { 1 2 3 } ...

diff --git a/basis/grouping/grouping-docs.factor b/basis/grouping/grouping-docs.factor
index 2c2fee1d70e79233249c8803478f3652bcb2f97f..0c9db38f4bc8d29009d94fe08519af04d8736eb6 100644 (file)
--- a/basis/grouping/grouping-docs.factor
+++ b/basis/grouping/grouping-docs.factor
@@ -8,22 +8,48 @@ ARTICLE: "grouping" "Groups and clumps"
 { $subsections groups <groups> <sliced-groups> }
 "Splitting a sequence into overlapping, fixed-length subsequences:"
 { $subsections clump }
+"Splitting a sequence into overlapping, fixed-length subsequences, wrapping around the end of the sequence:"
+{ $subsections circular-clump }
 "A virtual sequence for splitting a sequence into overlapping, fixed-length subsequences:"
 { $subsections clumps <clumps> <sliced-clumps> }
+"A virtual sequence for splitting a sequence into overlapping, fixed-length subsequences:"
+{ $subsections circular-clumps <circular-clumps> <sliced-circular-clumps> }
 "The difference can be summarized as the following:"
 { $list
     { "With groups, the subsequences form the original sequence when concatenated:"
+        { $unchecked-example
+            "USING: grouping ;"
+            "{ 1 2 3 4 } 2 group ." "{ { 1 2 } { 3 4 } }"
+        }
         { $unchecked-example
             "USING: grouping ;"
             "{ 1 2 3 4 } dup" "2 <groups> concat sequence= ." "t"
         }
     }
     { "With clumps, collecting the first element of each subsequence but the last one, together with the last subseqence, yields the original sequence:"
+        { $unchecked-example
+            "USING: grouping ;"
+            "{ 1 2 3 4 } 2 clump ." "{ { 1 2 } { 2 3 } { 3 4 } }"
+        }
         { $unchecked-example
             "USING: grouping ;"
             "{ 1 2 3 4 } dup" "2 <clumps> unclip-last [ [ first ] map ] dip append sequence= ." "t"
         }
     }
+    { "With circular clumps, collecting the first element of each subsequence yields the original sequence. Collecting the " { $snippet "n" } "th element of each subsequence would rotate the original sequence " { $snippet "n" } " elements rightward:"
+        { $unchecked-example
+            "USING: grouping ;"
+            "{ 1 2 3 4 } 2 circular-clump ." "{ { 1 2 } { 2 3 } { 3 4 } { 4 1 } }"
+        }
+        { $unchecked-example
+            "USING: grouping ;"
+            "{ 1 2 3 4 } dup" "2 <circular-clumps> [ first ] map sequence= ." "t"
+        }
+        { $unchecked-example
+            "USING: grouping ;"
+            "{ 1 2 3 4 } dup" "2 <circular-clumps> [ second ] { } map-as ." "{ 2 3 4 1 }"
+        }
+    }
 }
 $nl
 "A combinator built using clumps:"
@@ -79,18 +105,31 @@ HELP: <sliced-groups>
 } ;
 
 HELP: clumps
-{ $class-description "Instances are virtual sequences whose elements are overlapping fixed-length subsequences o an underlying sequence. Clumps are mutable and resizable if the underlying sequence is mutable and resizable, respectively."
+{ $class-description "Instances are virtual sequences whose elements are overlapping fixed-length subsequences of an underlying sequence. Clumps are mutable and resizable if the underlying sequence is mutable and resizable, respectively."
 $nl
 "New clumps are created by calling " { $link <clumps> } " and " { $link <sliced-clumps> } "." } ;
 
+HELP: circular-clumps
+{ $class-description "Instances are virtual sequences whose elements are overlapping fixed-length subsequences of an underlying sequence, beginning with every element in the original sequence and wrapping around its end. Circular clumps are mutable and resizable if the underlying sequence is mutable and resizable, respectively."
+$nl
+"New clumps are created by calling " { $link <circular-clumps> } " and " { $link <sliced-circular-clumps> } "." } ;
+
 HELP: clump
 { $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "array" "a sequence of sequences" } }
 { $description "Splits the sequence into overlapping clumps of " { $snippet "n" } " elements and collects the clumps into a new array." }
-{ $errors "Throws an error if " { $snippet "n" } " is smaller than the length of the sequence." }
+{ $errors "Throws an error if " { $snippet "n" } " is larger than the length of the sequence." }
 { $examples
     { $example "USING: grouping prettyprint ;" "{ 3 1 3 3 7 } 2 clump ." "{ { 3 1 } { 1 3 } { 3 3 } { 3 7 } }" }
 } ;
 
+HELP: circular-clump
+{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "array" "a sequence of sequences" } }
+{ $description "Splits the sequence into overlapping clumps of " { $snippet "n" } " elements, wrapping around the end of the sequence, and collects the clumps into a new array." }
+{ $errors "Throws an error if " { $snippet "n" } " is larger than the length of the sequence." }
+{ $examples
+    { $example "USING: grouping prettyprint ;" "{ 3 1 3 3 7 } 2 circular-clump ." "{ { 3 1 } { 1 3 } { 3 3 } { 3 7 } { 7 3 } }" }
+} ;
+
 HELP: <clumps>
 { $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "clumps" clumps } }
 { $description "Outputs a virtual sequence whose elements are overlapping subsequences of " { $snippet "n" } " elements from the underlying sequence." }
@@ -111,24 +150,35 @@ HELP: <clumps>
     }
 } ;
 
-HELP: <sliced-clumps>
+HELP: <circular-clumps>
 { $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "clumps" clumps } }
-{ $description "Outputs a virtual sequence whose elements are overlapping slices of " { $snippet "n" } " elements from the underlying sequence." }
+{ $description "Outputs a virtual sequence whose elements are overlapping subsequences of " { $snippet "n" } " elements from the underlying sequence, starting with each of its elements and wrapping around the end of the sequence." }
 { $examples
     { $example
         "USING: kernel sequences grouping prettyprint ;"
-        "{ 1 2 3 4 5 6 } 3 <sliced-clumps> second ."
-        "T{ slice { from 1 } { to 4 } { seq { 1 2 3 4 5 6 } } }"
+        "{ 1 2 3 4 } 3 <circular-clumps> third ."
+        "{ 3 4 1 }"
+    }
+} ;
+
+HELP: <sliced-circular-clumps>
+{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "clumps" clumps } }
+{ $description "Outputs a virtual sequence whose elements are overlapping slices of " { $snippet "n" } " elements from the underlying sequence, starting with each of its elements and wrapping around the end of the sequence." }
+{ $examples
+    { $example
+        "USING: arrays kernel sequences grouping prettyprint ;"
+        "{ 1 2 3 4 } 3 <sliced-circular-clumps> third >array ."
+        "{ 3 4 1 }"
     }
 } ;
 
-{ clumps groups } related-words
+{ clumps circular-clumps groups } related-words
 
-{ clump group } related-words
+{ clump circular-clump group } related-words
 
-{ <clumps> <groups> } related-words
+{ <clumps> <circular-clumps> <groups> } related-words
 
-{ <sliced-clumps> <sliced-groups> } related-words
+{ <sliced-clumps> <sliced-circular-clumps> <sliced-groups> } related-words
 
 HELP: monotonic?
 { $values { "seq" sequence } { "quot" { $quotation "( elt elt -- ? )" } } { "?" "a boolean" } }

diff --git a/basis/grouping/grouping-tests.factor b/basis/grouping/grouping-tests.factor
index 60500558a72f5a9270743d050f609e1fe80df588..9340b322e2d9e2da91a40a4e9c6300e3d29417e2 100644 (file)
--- a/basis/grouping/grouping-tests.factor
+++ b/basis/grouping/grouping-tests.factor
@@ -17,6 +17,15 @@ IN: grouping.tests
 [ 1 ] [ { 1 2 } 2 <clumps> length ] unit-test
 [ 2 ] [ { 1 2 3 } 2 <clumps> length ] unit-test
 
+[ { } 2 <circular-clumps> length ] must-fail
+[ { 1 } 2 <circular-clumps> length ] must-fail
+
+[ 2 ] [ { 1 2 } 2 <circular-clumps> length ] unit-test
+[ 3 ] [ { 1 2 3 } 2 <circular-clumps> length ] unit-test
+
+[ { { 1 2 } { 2 1 }         } ] [ { 1 2   } 2 circular-clump ] unit-test
+[ { { 1 2 } { 2 3 } { 3 1 } } ] [ { 1 2 3 } 2 circular-clump ] unit-test
+
 [ 1 ] [ V{ } 2 <clumps> 0 over set-length seq>> length ] unit-test
 [ 2 ] [ V{ } 2 <clumps> 1 over set-length seq>> length ] unit-test
 [ 3 ] [ V{ } 2 <clumps> 2 over set-length seq>> length ] unit-test

diff --git a/basis/grouping/grouping.factor b/basis/grouping/grouping.factor
index 4ee0d0c38519e9833db99f5745f7d032f9353a65..0dced6ad9d30b068a3252c4bec7d219b8ed74d34 100644 (file)
--- a/basis/grouping/grouping.factor
+++ b/basis/grouping/grouping.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2005, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel math math.order strings arrays vectors sequences
-sequences.private accessors fry ;
+sequences.private accessors fry combinators.short-circuit ;
 IN: grouping
 
 <PRIVATE
@@ -59,6 +59,13 @@ TUPLE: chunking-seq { seq read-only } { n read-only } ;
 : new-groups ( seq n class -- groups )
     [ check-groups ] dip boa ; inline
 
+: slice-mod ( n length -- n' )
+    2dup >= [ - ] [ drop ] if ; inline
+
+: check-circular-clumps ( seq n -- seq n )
+    2dup { [ nip 0 <= ] [ swap length > ] } 2|| 
+    [ "Invalid clump size" throw ] when ; inline
+
 PRIVATE>
 
 TUPLE: groups < chunking-seq ;
@@ -106,3 +113,37 @@ INSTANCE: sliced-clumps abstract-clumps
 : all-equal? ( seq -- ? ) [ = ] monotonic? ;
 
 : all-eq? ( seq -- ? ) [ eq? ] monotonic? ;
+
+TUPLE: circular-slice < slice ;
+M: circular-slice virtual@
+    [ from>> + ] [ seq>> ] bi [ length slice-mod ] keep ; inline
+
+C: <circular-slice> circular-slice
+
+TUPLE: sliced-circular-clumps < chunking-seq ;
+INSTANCE: sliced-circular-clumps sequence
+
+M: sliced-circular-clumps length
+    seq>> length ; inline
+
+M: sliced-circular-clumps nth
+    [ n>> over + ] [ seq>> ] bi <circular-slice> ; inline
+
+: <sliced-circular-clumps> ( seq n -- clumps )
+    check-circular-clumps sliced-circular-clumps boa ; inline
+
+TUPLE: circular-clumps < chunking-seq ;
+INSTANCE: circular-clumps sequence
+
+M: circular-clumps length
+    seq>> length ; inline
+
+M: circular-clumps nth
+    [ n>> over + ] [ seq>> ] bi [ <circular-slice> ] [ like ] bi ; inline
+
+: <circular-clumps> ( seq n -- clumps )
+    check-circular-clumps circular-clumps boa ; inline
+
+: circular-clump ( seq n -- array )
+    <circular-clumps> { } like ; inline
+