add circular-while, optimize circular a bit

diff --git a/basis/circular/circular-docs.factor b/basis/circular/circular-docs.factor
index 8abadfadd2230f54f41bb8921f50d0fbbe70de96..b75f3ee2a15dc33a3eb56da6f33cf643dd344c5a 100644 (file)
--- a/basis/circular/circular-docs.factor
+++ b/basis/circular/circular-docs.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: help.markup help.syntax io.streams.string sequences
-math kernel ;
+math kernel quotations ;
 IN: circular
 
 HELP: <circular-string>
@@ -33,12 +33,12 @@ HELP: circular
 HELP: growing-circular
 { $description "A circular sequence that is growable." } ;
 
-HELP: push-circular
+HELP: circular-push
 { $values
      { "elt" object } { "circular" circular } }
 { $description "Pushes an element to a " { $link circular } " object." } ;
 
-HELP: push-growing-circular
+HELP: growing-circular-push
 { $values
      { "elt" object } { "circular" circular } }
 { $description "Pushes an element onto a " { $link growing-circular } " object." } ;
@@ -48,6 +48,13 @@ HELP: rotate-circular
     { "circular" circular } }
 { $description "Advances the start index of a circular object by one." } ;
 
+HELP: circular-while
+{ $values
+    { "sequence" sequence }
+    { "quot" quotation }
+}
+{ $description "Calls " { $snippet "quot" } " on each element of the sequence until each call yields yields " { $link f } " in succession." } ;
+
 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:"
@@ -63,8 +70,10 @@ ARTICLE: "circular" "Circular sequences"
 }
 "Pushing new elements:"
 { $subsections
-    push-circular
-    push-growing-circular
-} ;
+    circular-push
+    growing-circular-push
+}
+"Iterating over a circular until a stop condition:"
+{ $subsections circular-while } ;
 
 ABOUT: "circular"

diff --git a/basis/circular/circular-tests.factor b/basis/circular/circular-tests.factor
index c3c4860f953a3e51b1f219f811ec4c015f561374..cda26df1d3f54e9e31444a1761b3ce94a6005adb 100644 (file)
--- a/basis/circular/circular-tests.factor
+++ b/basis/circular/circular-tests.factor
@@ -23,7 +23,7 @@ IN: circular.tests
 [ "boo" ] [ "foo" <circular> CHAR: b 3 pick set-nth-unsafe >string ] unit-test
 [ "ornact" ] [ "factor" <circular> 4 over change-circular-start CHAR: n 2 pick set-nth >string ] unit-test
 
-[ "bcd" ] [ 3 <circular-string> "abcd" [ over push-circular ] each >string ] unit-test
+[ "bcd" ] [ 3 <circular-string> "abcd" [ over circular-push ] each >string ] unit-test
 
 [ { 0 0 } ] [ { 0 0 } <circular> -1 over change-circular-start >array ] unit-test
 
@@ -34,11 +34,11 @@ IN: circular.tests
 [ { } ] [ 3 <growing-circular> >array ] unit-test
 [ { 1 2 } ] [
     3 <growing-circular>
-    [ 1 swap push-growing-circular ] keep
-    [ 2 swap push-growing-circular ] keep >array
+    [ 1 swap growing-circular-push ] keep
+    [ 2 swap growing-circular-push ] keep >array
 ] unit-test
 [ { 3 4 5 } ] [
     3 <growing-circular> dup { 1 2 3 4 5 } [
-        swap push-growing-circular
+        swap growing-circular-push
     ] with each >array
 ] unit-test

diff --git a/basis/circular/circular.factor b/basis/circular/circular.factor
index 1c0efb1c36c15c104ba8a200e39f8028a3cd3a8d..67ddd3467b180e913d176330f3eeb967c7522fc8 100644 (file)
--- a/basis/circular/circular.factor
+++ b/basis/circular/circular.factor
@@ -1,57 +1,85 @@
 ! Copyright (C) 2005, 2006 Alex Chapman, Daniel Ehrenberg
 ! See http;//factorcode.org/license.txt for BSD license
 USING: kernel sequences math sequences.private strings
-accessors ;
+accessors locals fry ;
 IN: circular
 
-! a circular sequence wraps another sequence, but begins at an
-! arbitrary element in the underlying sequence.
-TUPLE: circular seq start ;
+TUPLE: circular { seq read-only } { start integer } ;
 
 : <circular> ( seq -- circular )
-    0 circular boa ;
+    0 circular boa ; inline
 
 <PRIVATE
+
 : circular-wrap ( n circular -- n circular )
     [ start>> + ] keep
     [ seq>> length rem ] keep ; inline
+
 PRIVATE>
 
-M: circular length seq>> length ;
+M: circular length seq>> length ; inline
 
-M: circular virtual@ circular-wrap seq>> ;
+M: circular virtual@ circular-wrap seq>> ; inline
 
-M: circular virtual-exemplar seq>> ;
+M: circular virtual-exemplar seq>> ; inline
 
 : change-circular-start ( n circular -- )
     #! change start to (start + n) mod length
-    circular-wrap (>>start) ;
+    circular-wrap (>>start) ; inline
 
 : rotate-circular ( circular -- )
-    [ 1 ] dip change-circular-start ;
+    [ 1 ] dip change-circular-start ; inline
 
-: push-circular ( elt circular -- )
+: circular-push ( elt circular -- )
     [ set-first ] [ rotate-circular ] bi ;
 
 : <circular-string> ( n -- circular )
-    0 <string> <circular> ;
+    0 <string> <circular> ; inline
 
 INSTANCE: circular virtual-sequence
 
 TUPLE: growing-circular < circular length ;
 
-M: growing-circular length length>> ;
+M: growing-circular length length>> ; inline
 
 <PRIVATE
 
 : full? ( circular -- ? )
-    [ length ] [ seq>> length ] bi = ;
+    [ length ] [ seq>> length ] bi = ; inline
 
 PRIVATE>
 
-: push-growing-circular ( elt circular -- )
-    dup full? [ push-circular ]
+: growing-circular-push ( elt circular -- )
+    dup full? [ circular-push ]
     [ [ 1 + ] change-length set-last ] if ;
 
 : <growing-circular> ( capacity -- growing-circular )
-    { } new-sequence 0 0 growing-circular boa ;
+    { } new-sequence 0 0 growing-circular boa ; inline
+
+TUPLE: circular-iterator
+    { circular read-only } { n integer } { last-start integer } ;
+
+: <circular-iterator> ( sequence -- obj )
+    <circular> 0 0 circular-iterator boa ; inline
+
+<PRIVATE
+
+: (circular-while) ( iterator quot: ( obj -- ? ) -- )
+    [ [ [ n>> ] [ circular>> ] bi nth ] dip call ] 2keep rot [
+        [
+            [ 1 + ] change-n
+            dup n>> >>last-start
+        ] dip (circular-while)
+    ] [
+        over [ 1 + ] change-n
+        [ n>> ] [ [ last-start>> ] [ circular>> length ] bi + ] bi = [
+            2drop
+        ] [
+            (circular-while)
+        ] if
+    ] if ; inline recursive
+
+PRIVATE>
+
+: circular-while ( sequence quot: ( obj -- ? ) -- )
+    [ <circular-iterator> ] dip (circular-while) ; inline

diff --git a/basis/sequences/parser/parser.factor b/basis/sequences/parser/parser.factor
index 93bbbdf53d52ef480ae96ec522b4111154787b63..44fa75239cfa08acbd9e60c48f4730f3fb211641 100644 (file)
--- a/basis/sequences/parser/parser.factor
+++ b/basis/sequences/parser/parser.factor
@@ -83,7 +83,7 @@ TUPLE: sequence-parser sequence n ;
     sequence length <growing-circular> :> growing
     sequence-parser
     [
-        current growing push-growing-circular
+        current growing growing-circular-push
         sequence growing sequence=
     ] take-until :> found
     growing sequence sequence= [

diff --git a/basis/xml/tokenize/tokenize.factor b/basis/xml/tokenize/tokenize.factor
index b0dbdf22ac83036076b8271eb0dfc3322a9c2fee..beb5983b5a61ce1f1158736e3bd0212b6de9f60d 100644 (file)
--- a/basis/xml/tokenize/tokenize.factor
+++ b/basis/xml/tokenize/tokenize.factor
@@ -86,7 +86,7 @@ HINTS: next* { spot } ;
     spot get '[ _ char>> blank? not ] skip-until ;
 
 : string-matches? ( string circular spot -- ? )
-    char>> over push-circular sequence= ;
+    char>> over circular-push sequence= ;
 
 : take-string ( match -- string )
     dup length <circular-string>
@@ -147,7 +147,7 @@ HINTS: next* { spot } ;
 :: parse-text ( -- string )
     3 f <array> <circular> :> circ
     depth get zero? :> no-text [| char |
-        char circ push-circular
+        char circ circular-push
         circ assure-no-]]>
         no-text [ char blank? char CHAR: < = or [
             char 1string t pre/post-content

diff --git a/extra/project-euler/186/186.factor b/extra/project-euler/186/186.factor
index ed4f03dda1aabc8a3a13e5004234bc20260b1b77..922a28cb22c51f21a0212937bc635b545f0a3129 100644 (file)
--- a/extra/project-euler/186/186.factor
+++ b/extra/project-euler/186/186.factor
@@ -45,7 +45,7 @@ IN: project-euler.186
     55 [1,b] [ (generator) ] map <circular> ;
 
 : advance ( lag -- )
-    [ { 0 31 } swap nths sum 1000000 rem ] keep push-circular ;
+    [ { 0 31 } swap nths sum 1000000 rem ] keep circular-push ;
 
 : next ( lag -- n )
     [ first ] [ advance ] bi ;