steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

change behavior of circular-while

db4
Doug Coleman 2009-12-07 19:27:36 -06:00
parent 7f1a643de2
commit 82f57e57f9
2 changed files with 10 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/circular/circular-docs.factor
View File

@ -50,7 +50,7 @@ HELP: rotate-circular
HELP: circular-while HELP: circular-while
{ $values { $values
{ "sequence" sequence } { "circular" circular }
{ "quot" quotation } { "quot" quotation }
} }
{ $description "Calls " { $snippet "quot" } " on each element of the sequence until each call yields " { $link f } " in succession." } ; { $description "Calls " { $snippet "quot" } " on each element of the sequence until each call yields " { $link f } " in succession." } ;

24
basis/circular/circular.factor
View File

@ -59,27 +59,21 @@ PRIVATE>
TUPLE: circular-iterator TUPLE: circular-iterator
{ circular read-only } { n integer } { last-start integer } ; { circular read-only } { n integer } { last-start integer } ;
: <circular-iterator> ( sequence -- obj ) : <circular-iterator> ( circular -- obj )
<circular> 0 0 circular-iterator boa ; inline 0 0 circular-iterator boa ; inline
<PRIVATE <PRIVATE
: (circular-while) ( iterator quot: ( obj -- ? ) -- ) : (circular-while) ( iterator quot: ( obj -- ? ) -- )
[ [ [ n>> ] [ circular>> ] bi nth ] dip call ] 2keep rot [ [ [ [ n>> ] [ circular>> ] bi nth ] dip call ] 2keep
[ rot [ [ dup n>> >>last-start ] dip ] when
[ 1 + ] change-n over [ n>> ] [ [ last-start>> ] [ circular>> length ] bi + 1 - ] bi = [
dup n>> >>last-start 2drop
] dip (circular-while)
] [ ] [
over [ 1 + ] change-n [ [ 1 + ] change-n ] dip (circular-while)
[ n>> ] [ [ last-start>> ] [ circular>> length ] bi + ] bi = [
2drop
] [
(circular-while)
] if
] if ; inline recursive ] if ; inline recursive
PRIVATE> PRIVATE>
: circular-while ( sequence quot: ( obj -- ? ) -- ) : circular-while ( circular quot: ( obj -- ? ) -- )
[ <circular-iterator> ] dip (circular-while) ; inline [ clone ] dip [ <circular-iterator> ] dip (circular-while) ; inline