Add circular-while*

diff --git a/basis/circular/circular-docs.factor b/basis/circular/circular-docs.factor
index 93d137d626d3b377a5a734652029d14a815264ae..13934a1f91230bb3450cb1df6089ab61250862cb 100644 (file)
--- a/basis/circular/circular-docs.factor
+++ b/basis/circular/circular-docs.factor
@@ -55,6 +55,13 @@ HELP: circular-while
 }
 { $description "Calls " { $snippet "quot" } " on each element of the sequence until each call yields " { $link f } " in succession." } ;
 
+HELP: circular-while*
+{ $values
+    { "circular" circular }
+    { "quot" quotation }
+}
+{ $description "Calls " { $snippet "quot" } " on each element of the sequence until one call yields " { $link f } "." } ;
+
 ARTICLE: "circular" "Circular sequences"
 "The " { $vocab-link "circular" } " vocabulary implements the " { $link "sequence-protocol" } " to allow an arbitrary start index and wrap-around indexing." $nl
 "Creating a new circular object:"
@@ -74,6 +81,6 @@ ARTICLE: "circular" "Circular sequences"
     growing-circular-push
 }
 "Iterating over a circular until a stop condition:"
-{ $subsections circular-while } ;
+{ $subsections circular-while circular-while* } ;
 
 ABOUT: "circular"

diff --git a/basis/circular/circular-tests.factor b/basis/circular/circular-tests.factor
index a3b1d5541c9a3ddfcd6b79de0d9ecaf23e194a35..dbc467802897b57384838a042c20435a84a5d39d 100644 (file)
--- a/basis/circular/circular-tests.factor
+++ b/basis/circular/circular-tests.factor
@@ -42,3 +42,9 @@ IN: circular.tests
         swap growing-circular-push
     ] with each >array
 ] unit-test
+
+[ V{ 1 2 3 1 2 } ] [
+    { 1 2 3 } <circular> V{ } [
+        [ [ push ] [ length 4 < ] bi ] curry circular-while
+    ] keep
+] unit-test

diff --git a/basis/circular/circular.factor b/basis/circular/circular.factor
index f199413f8692393233778a77eaf66c9ac0cb40b5..1bd0c15995c0bf48d8e012e20bf6a1d7c7bc91ad 100644 (file)
--- a/basis/circular/circular.factor
+++ b/basis/circular/circular.factor
@@ -77,3 +77,6 @@ PRIVATE>
 
 : circular-while ( ... circular quot: ( ... obj -- ... ? ) -- ... )
     [ clone ] dip [ <circular-iterator> ] dip (circular-while) ; inline
+
+: circular-while* ( ... circular quot: ( ... obj -- ... ? ) -- ... )
+  [ clone ] dip '[ [ first @ ] [ rotate-circular ] bi ] curry loop ; inline