Yow! LOOP macros are LOOPY!

[Alex Shinn]

Scheme was the first general purpose language to take the brave
stance of not providing any primitive iteration syntax. From the
R5RS[1] introduction:

By relying entirely on procedure calls to express iteration,
Scheme emphasized the fact that tail-recursive procedure calls
are essentially goto's that pass arguments.[2]

Despite this, people are eternally adding their own iteration
syntax to the language. From the very beginning Scheme has in fact
included an iteration form, DO, borrowed from MacLisp; however it
was specifically intended as derived syntax, a thin wrapper around
a recursive procedure call. Perhaps this was included as some sort
of defensive measure, the author worrying a language without
explicit iteration might not be taken seriously. Or perhaps it was
intended to show how ugly iteration forms could be, encouraging
programmers to use and feel comfortable with manual recursion.
Certainly the latter seems to be the result, since very few people
actually use DO.

What does do do? Do be do.

DO expresses the fundamental iteration concept in a manner similar
to but cleaner than C's FOR loop. Consider

(do ((ls '(1 3 5 7 9) (cdr ls))
(sum 0 (+ sum (car ls))))
((null? ls) sum))

We have any number of loop variables each with an initial form and
step form, a termination condition, and optional return value and
body. If you want to introduce a lexical scope with loop variables
this is about as simple and general as you can get (if you don't
want even scope then WHILE is the simplest iteration construct).

However, for practical purposes this is very limited. The most
obvious problem, and the one solved by pretty much all other loop
macros, is convenience of iterating easily over different sequence
types. If the above were summing over a vector instead of a list,
then the code would have to become

(let* ((vec '#(1 3 5 7 9))
(len (vector-length vec)))
(do ((i 0 (+ i 1))
(sum 0 (+ sum (vector-ref vec i))))
((= i len) sum)))

Changes are required throughout the code for only a simple
conceptual change in the design. Shivers' LOOP macro discussed
below makes this point especially clear.

Don't be do.

So now, in addition to providing a scope and clean separation of
iteration phases, we want some abstraction over sequence types. Of
other macros going around at the time other than MacLisp's
new-style DO, Common-Lisp of course adopted the most featureful,
the Common-Lisp LOOP[3]. It solves this problem and also provides
features such as aggregate functions to perform implicit summing or
collecting into lists, and explicit controls such as return and
goto. It uses a keyword syntax which for simple examples makes it
look like broken English (this is a plus or minus, depending on who
you ask). As a simple example, the following generates a list of
the numbers from 1 to 10:

(loop for i from 1 to 10 collect i)

This is baroque, explicitly mutation and state-oriented, doesn't
nest properly, and is unextensible. Yes, despite having all these
features, no more can be added. Schemers tend to make fun of CL's
LOOP almost as much as they make fun of their own DO form.

Don't Loop, Iterate.

Jonathan Amsterdam's ITERATE macro[4] is an attempt to clean up
LOOP, removing some warts and giving it a more Lisp-like syntax.
Most notably, ITERATE is extensible. You can portably add your own
syntax for iterating over new sequence types, such as your own
custom stream type or database query handles. This is an important
feature that is shared by all the remaining macros we will look at.
The above example becomes

(loop (for i from 1 to 10)
(collect i))

One limitation of ITERATE is that you still need a RETURN form for
special conditional returns, and this doesn't nest cleanly without
tagbodies. There are also certain patterns we'll see shortly where
it isn't convenient or efficient to update loop variables with
complex conditionals, such that you have to resort to binding them
outside the loop and using mutation.

Reducing to iteration.

Scheme48's approach[5] to iteration is to take a step back towards
named let, but add just enough to make iterating over sequence
types easier. The ITERATE macro is essentially a named let where
certain of the variables are updated for you automatically. For
example, to implement FIND from SRFI-1:

(define (find pred ls)
(iterate loop ((list* elt ls)) ; loop variables
() ; state variables
(if (pred elt) ; body
elt
(loop))
#f)) ; [tail expression]

In this case there are no explicitly recursed variables (called
state variables), and so each time we recurse with just (LOOP), ELT
is bound to the next element of LS. We terminate the loop as in
named let by simply choosing not to recurse, or by default
returning the optional tail expression when the list elements are
used up. An example using state variables would be COUNT:

(define (count pred ls)
(iterate loop ((list* elt ls))
((sum 0))
(if (pred elt)
(loop (+ sum 1))
(loop sum))
sum))

Here SUM is a state variable - we manually recurse on that with
each iteration because the logic behind it can't be captured easily
behind some common iterator syntax. In this case we are always
recursing with LOOP, relying on the list to be exhausted for
termination. This common pattern is captured with the REDUCE
macro, by which the above form can be more succinctly written:

(define (count pred ls)
(reduce ((list* elt ls))
((sum 0))
(if (pred elt)
(+ sum 1)
sum)))

and the list from 1 to 10 example becomes

(reverse (reduce ((count* i 1 11))
((res '()))
(cons i res)))

See the Scheme48 reference manual for a more thorough explanation
and examples. The important point is that by returning to a more
natural Scheme flow-control, the iteration becomes easier to
follow, and at the same time more expressive. And they are, of
course, easily extensible. These macros deserve better recognition
in the Scheme community.

Comprehending iteration.

For certain very common patterns, many people prefer to name it
once and be done with. It doesn't matter how COUNT is implemented
if you already know what it does. Unfortunately, COUNT as is works
only on lists. If you want to work with vectors you need
VECTOR-COUNT, and so on, and this approach doesn't work at all for
things like a combination of lists and vectors.

SRFI-42 "Eager Comprehensions"[6] attempts to solve this by not
only making the sequence iterators extensible, but by providing a
set of extensible iteration control structures. So, for example,
there is a LIST-EC form to collect the sequence elements into a
list, and a SUM-EC to sum the sequence elements. There is no
FIND-EC or COUNT-EC, but these could be defined.

(list-ec (: i 1 11) i)

Compared to explicit named looping you lose some flexibility, and
you can't establish complex interactions between iterators or sum
at the same time as you collect a list. The scope and timing of
bindings can also be unintuitive.

Anatomical correctness.

Shivers did a full analysis of loop macros in his "The Anatomy of a
Loop,"[7] and addresses the confusing scope issue with a
control-flow graph language. The possible branches of the loop are
represented in a CFG, and the scope of variables can be traced by
their path through the graph. This can represent any program, but
is too low-level to program in directly. On top of this is built a
high-level extensible LOOP macro, based on another earlier macro
the Yale LOOP, which is similar to Amsterdam's ITERATE. Thus the
recurring example becomes something like

(loop (incr i from 1 to: 11)
(save i))

A more complicated and impressive example, quicksort, is given
showing various features of the macro:

(let recur ((left 0) (right (vector-length v)))
(if (> (- right left) 1)
(loop (initial (p (pick-pivot v left right))
(i (- left 1))
(j right))
(subloop (incr i from i)
(bind (vi (vector-ref v i)))
(while (< vi p)))
(subloop (decr j from j)
(bind (vj (vector-ref v j)))
(while (< p vj)))
(until (<= j i))
(do (vector-set! v i vj)
(vector-set! v j vi))
(after (recur left i)
(recur (+ j 1) right)))))

Although the CFG determines scope unambiguously, looking at the
high-level code it's not immediately obvious what happens when, and
which bindings are available where. You can't simply trace the
indentation and nesting, since the far right indented VI introduced
with a BIND is later accessible in the outer DO. It is also
interesting to note that the macro itself is incapable of handling
general recursion, requiring the entire form to be wrapped in a
named let.

Named let, named bindings.

With the exception of Scheme48, all of the loop macros require the
programmer to learn a domain language unrelated the Scheme.
Moreover, these domain languages still can't handle all general
forms of recursion, and it's possible that as your program becomes
more complicated you may have to rewrite from loop macros to
general recursion.

There are also some common patterns not addressed by any of these
macros. One problem is that iteration over a sequence may be only
semi-regular. For example, string traversals often have "escape"
characters, such as a backslash, which need to be processed
together with the next character. Similarly in a VM or
state-machine you may want to step through one instruction at a
time, but may also have instructions which are jumps. In both
cases you want to be able to override the default sequence
iteration when necessary.

Another problem that turns up in loops is when you have too many
state variables, usually only one or two of which is updated on a
given iteration. For example, if processing keyword arguments or
command-line arguments to check for certain settings. As a more
abstract example we can consider a variant of partition that splits
a list into multiple separate sub-lists rather than just two:

(define (color-partition ls)
(let part ((ls ls) (red '()) (blue '()) (green '()) (other '()))
(if (null? ls)
(values (reverse red) (reverse blue) (reverse green) (reverse
other))
(let ((x (car ls)))
(cond
((red? x) (part (cdr ls) (cons x red) blue green other))
((blue? x) (part (cdr ls) red (cons x blue) green other))
((green? x) (part (cdr ls) red blue (cons x green) other))
(else (part (cdr ls) red blue green (cons x
other))))))))

Both of these patterns can be addressed by allowing update by
keyword arguments on each recursion. In the normal case we can
just recurse with no arguments, but when we want to manually alter
a loop variable we can do so. The attached LOOP implementation is
based on Oleg's portable keyword macros[8] but uses

keyword <- new-value

syntax to make the updates more explicit, and also to optionally
allow positional parameters. As such, it can pass as a drop-in
replacement for named let, so just replacing "let part" in the
procedure above with "loop part" will have the same effect.
However, we can also leave out all the variables that stay the same
and update only those that change:

(define (color-partition ls)
(let part ((ls ls) (red '()) (blue '()) (green '()) (other '()))
(if (null? ls)
(values (reverse red) (reverse blue) (reverse green) (reverse
other))
(let ((x (car ls)))
(cond
((red? x) (part (cdr ls) red <- (cons x red)))
((blue? x) (part (cdr ls) blue <- (cons x blue)))
((green? x) (part (cdr ls) green <- (cons x green)))
(else (part (cdr ls) other <- (cons x other))))))))

Of course, since the next step for LS is always the same we can
specify that as in our old friend the DO macro:

(define (color-partition ls)
(let part ((ls ls (cdr ls)) (red '()) (blue '()) (green '()) (other
'()))
(if (null? ls)
(values (reverse red) (reverse blue) (reverse green) (reverse
other))
(let ((x (car ls)))
(cond
((red? x) (part red <- (cons x red)))
((blue? x) (part blue <- (cons x blue)))
((green? x) (part green <- (cons x green)))
(else (part other <- (cons x other))))))))

And more generally we can use extensible sequence iterators by
again using the <- keyword. Since the termination then becomes
implicit, we can signify a final result with a "=> value" form at
the start of the loop body:

(define (color-partition ls)
(loop part ((x <- in-list ls) (red '()) (blue '()) (green '())
(other '()))
=> (values (reverse red) (reverse blue) (reverse green) (reverse
other))
(cond
((red? x) (part red <- (cons x red)))
((blue? x) (part blue <- (cons x blue)))
((green? x) (part green <- (cons x green)))
(else (part other <- (cons x other))))))

For simple cases where we always recurse, we can follow the example
of REDUCE, but rather than using a separate macro just omit the
loop name. Thus, SRFI-1 FOLD becomes:

(define (fold kons knil ls)
(loop ((x <- in-list ls) (a knil (kons x a))) => a))

The VAR <- VALUE syntax is used so that we can possibly have
multiple variables, e.g. (KEY VALUE <- IN-HASH-TABLE TAB), or more
commonly so that we can specify the name of the cursor. In all of
the above IN-LIST iterators, although X is bound to the element,
there is an implicit cursor variable hidden from us cdring down the
list. However, it can be useful to explicitly name the cursor.
FOLD's cousin PAIR-FOLD then can be defined as

(define (pair-fold kons knil ls)
(loop ((x p <- in-list ls) (a knil (kons p a))) => a))

Whereas it would make no sense to manually update the element
variables, it can be useful to update the cursor variables. You
can skip over some elements of the list, or even switch to a new
list at some point. The string backslash escape procedure could be
written as something like

(define (string-escape str)
(with-output-to-string
(lambda ()
(loop ((ch i <- in-string str))
(cond
((eqv? ch #\\)
(write-char (char-escape (string-ref str (+ i 1))))
(loop i <- (+ i 2)))
(else
(write-char ch)
(loop)))))))

and the above quicksort can be implemented as:

(loop qsort ((left 0) (right (- (vector-length v) 1)))
(if (> right left)
(let ((p (pick-pivot v left right)))
(loop up ((vi i <- in-vector v left right)
(k right))
(cond
((> i k) (qsort right <- i) (qsort left <- (+ i 1)))
((< vi p) (up))
(else
(loop down ((vj j <- in-vector-reverse v k (+ i 1)))
=> (up i <- i k <- (- j 1))
(if (< p vj)
(down)
(begin
(vector-set! v i vj)
(vector-set! v j vi)
(up i <- i k <- j))))))))))

Note the scope of variables is immediately visible, and that the
outermost loop is also implemented with the same macro.

The implementation below currently includes the following
iterators:

elt [pair] <- in-list list [cdr]
ch [index] <- in-string str [start [end]]
elt [index] <- in-vector vec [start [end]]
elt [index] <- in-vector-reverse vec [start [end]]
elt <- in-port port [reader]
elt <- in-file file [reader]
int <- in-range start [end [step]]
int <- in-random [range [low]]
perm <- in-permutations set
res [pair] <- collecting expr

though it's straightforward to define new iterators.

Suggestions and criticism appreciated before I finalize the API and
write up more thorough documentation. And thanks if you've read
this far! :)

References:
[1] Richard Kelsey, William Clinger, and Jonathan Rees (eds.):
Revised(5) Report on the Algorithmic Language Scheme, 1998.
http://schemers.org/Documents/Standards/R5RS/.

[2] Shriram Krishnamurthi: The Swine Before Perl, 2001.
http://ll1.ai.mit.edu/shriram-talk.pdf

[3] Kent Pitman: Common Lisp Hyperspec, 1996.
http://www.lisp.org/HyperSpec/FrontMatter/index.html

[4] Jonathan Amsterdam: Don't Loop, Iterate, 1989.

http://common-lisp.net/~loliveira/tmp/iterate-manual/html_node/index.html

[5] Richard Kelsey, Jonathan Rees, Mike Sperber: Macros for writing
loops.
http://www.s48.org/1.3/manual/manual-Z-H-7.html#node_sec_5.18

[6] Sebastian Egner: Eager Comprehensions, July 2003.
http://srfi.schemers.org/srfi-42/

[7] Olin Shivers: The Anatomy of a Loop, September 2005.
http://www.cc.gatech.edu/~shivers/papers/loop.pdf

[8] Oleg Kiselyov: Macros with keyword arguments, May 2004.
http://okmij.org/ftp/Scheme/keyword-arg-macro.txt

--
Alex

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; for Chicken
;; (require-extension syntax-case)
;; (define random-integer random)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Adapted from http://okmij.org/ftp/Scheme/keyword-arg-macro.txt

(define-syntax let-keyword-form
(syntax-rules ()
((let-keyword-form
((labeled-arg-macro-name
(positional-form-name (arg-name . arg-default) ...)))
. body)
(letrec-syntax
((labeled-arg-macro-name
(syntax-rules ()
((labeled-arg-macro-name . keyword-val-pairs)
(letrec-syntax
((find
(syntax-rules (<- arg-name ...)
((find kvp k-args (arg-name . default) arg-name
<- val
. others) ; found arg-name among
keyword-val-pairs
(next kvp val . k-args)) ...
((find kvp k-args key arg-no-match-name <- val .
others)
(find kvp k-args key . others))
((find kvp k-args (arg-name default)) ; default
must be here
(next kvp default . k-args)) ...
))
(next ; pack the continuation to find
(syntax-rules ()
((next kvp val vals key . keys)
(find kvp ((val . vals) . keys) key . kvp))
((next kvp val vals) ; processed all
arg-descriptors
(rev-apply (val) vals))))
(match-positionals
(syntax-rules (<-)
((match-positionals () res . rest)
(rev-apply () res))
((match-positionals args (val . vals) name <-
value . rest)
(next (name <- value . rest) val vals . args))
((match-positionals args (val . vals))
(next () val vals . args))
((match-positionals (arg1 . args) res pos-arg .
rest)
(match-positionals args (pos-arg . res) .
rest))))
(rev-apply
(syntax-rules ()
((rev-apply form (x . xs))
(rev-apply (x . form) xs))
((rev-apply form ()) form))))
(match-positionals ((arg-name . arg-default) ...)
(positional-form-name)
. keyword-val-pairs)
)))))
. body))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-syntax loop
(syntax-rules ()
;; unnamed, implicit recursion
((loop (vars ...) body ...)
(%loop tmp-loop () () () () () (vars ...) body ... (tmp-loop)))
;; named, explicit recursion
((loop name (vars ...) body ...)
(%loop name () () () () () (vars ...) body ...))))

(define-syntax %loop
(syntax-rules (=> <-)
;; automatic iteration
((_ name l v c r f ((var1 <- iterator source ...) rest ...) . body)
(iterator ((var1) (source ...)) %loop-next name l v c r f (rest
...) . body))
((_ name l v c r f ((var1 var2 <- iterator source ...) rest ...) .
body)
(iterator ((var1 var2) (source ...)) %loop-next name l v c r f
(rest ...) . body))
((_ name l v c r f ((var1 var2 var3 <- iterator source ...) rest
...) . body)
(iterator ((var1 var2 var3) (source ...)) %loop-next name l v c r
f (rest ...) . body))
((_ name l v c r f ((var1 var2 var3 var4 <- iterator source ...)
rest ...) . body)
(iterator ((var1 var2 var3 var4) (source ...)) %loop-next name l v
c r f (rest ...) . body))
;; do equivalents, with optional guards
((_ name l (vars ...) (checks ...) r f ((var init step guard) rest
...) . body)
(%loop name l (vars ... (var init step)) (checks ... (guard var))
r f (rest ...) . body))
((_ name l (vars ...) c r f ((var init step) rest ...) . body)
(%loop name l (vars ... (var init step)) c r f (rest ...) . body))
((_ name l (vars ...) c r f ((var init) rest ...) . body)
(%loop name l (vars ... (var init var)) c r f (rest ...) . body))
;; specify a default done?
((_ name l v c r f ())
(%loop name l v c r f () (#f #f)))
((_ name l v c r f () () . body)
(%loop name l v c r f () (#f #f) . body))
;; final expansion
((_ name (lets ...) ((var init step) ...) (checks ...) (refs ...)
(finals ...) ()
=> result
. body)
(let* (lets ...)
(letrec ((tmp (lambda (var ...)
(if (or checks ...)
(let-keyword-form ((name (tmp (var step)
...)))
(let (finals ...)
result))
(let (refs ...)
(let-keyword-form ((name (tmp (var step)
...)))
(if #f #f)
. body))))))
(tmp init ...))))
((_ name (lets ...) ((var init step) ...) (checks ...) (refs ...)
(finals ...) ()
. body)
(%loop name (lets ...) ((var init step) ...) (checks ...) (refs
...) (finals ...) ()
=> (if #f #f) . body))
))

(define-syntax %loop-next
(syntax-rules ()
((_ (new-lets ...) (new-vars ...) (new-checks ...) (new-refs ...)
(new-finals ...)
name (lets ...) (vars ...) (checks ...) (refs ...) (finals ...)
. rest)
(%loop name (lets ... new-lets ...) (vars ... new-vars ...)
(checks ... new-checks ...) (refs ... new-refs ...)
(finals ... new-finals ...)
. rest))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Iterators

;; Each gets passed two lists, those items left of the <- and those to
;; the right, followed by a NEXT and REST continuation.

;; Should finish with
;;
;; (next (outer-vars) (cursor-vars) (done?-tests) (loop-vars) . rest)
;;
;; OUTER-VARS: bound once outside the loop in a LET*
;; CURSOR-VARS: DO-style bindings of the form (name init update)
;; DONE?-TESTS: possibly empty list of forms that terminate the loop
on #t
;; LOOP-VARS: inner variables, updated in parallel after the cursors

(define-syntax in-list ; called just "IN" in ITER
(syntax-rules ()
((in-list ((var) source) next . rest)
(in-list ((var cursor) source) next . rest))
((in-list ((var cursor) (source)) next . rest)
(in-list ((var cursor) (source cdr)) next . rest))
((in-list ((var cursor) (source step)) next . rest)
(next () ; outer let bindings
((cursor source (step cursor))) ; iterator, init, step
((null? cursor)) ; finish tests for iterator
vars
((var (car cursor))) ; step variables and values
() ; final result bindings
. rest))))

(define-syntax in-string
(syntax-rules ()
((in-string ((var) (source)) next . rest)
(in-string ((var cursor) (source)) next . rest))
((in-string ((var cursor) (source)) next . rest)
(next ((tmp-str source) (len (string-length tmp-str)))
((cursor 0 (+ cursor 1)))
((>= cursor len))
((var (string-ref tmp-str cursor)))
()
. rest))))

(define-syntax in-vector
(syntax-rules ()
((in-vector (ls ...) next . rest)
(%in-vector >= + 0 (vector-length tmp-vec)
tmp-vec (ls ...) next . rest))))

(define-syntax in-vector-reverse
(syntax-rules ()
((in-vector (ls ...) next . rest)
(%in-vector < - (- (vector-length tmp-vec) 1) 0
tmp-vec (ls ...) next . rest))))

(define-syntax %in-vector
(syntax-rules ()
((%in-vector ge + s e tmp-vec ((var) (vec ...)) next . rest)
(%in-vector ge + s e tmp-vec ((var vec-index) (vec ...)) next .
rest))
((%in-vector ge + s e tmp-vec ((var index) (vec)) next . rest)
(%in-vector ge + s e tmp-vec ((var index) (vec s e 1)) next .
rest))
((%in-vector ge + s e tmp-vec ((var index) (vec from)) next . rest)
(%in-vector ge + s e tmp-vec ((var index) (vec from e 1)) next .
rest))
((%in-vector ge + s e tmp-vec ((var index) (vec from to)) next .
rest)
(%in-vector ge + s e tmp-vec ((var index) (vec from to 1)) next .
rest))
((%in-vector ge + s e tmp-vec ((var index) (vec from to step)) next
. rest)
(next ((tmp-vec vec) (end to))
((index from (+ index step)))
((ge index end))
((var (vector-ref tmp-vec index)))
()
. rest))
))

(define-syntax in-port
(syntax-rules ()
((in-port ((var) ()) next . rest)
(in-port ((var) ((current-input-port) read-char)) next . rest))
((in-port ((var) (port)) next . rest)
(in-port ((var) (port read-char)) next . rest))
((in-port ((var) (port reader)) next . rest)
(next ((p port) (r reader))
((var (r p) (r p)))
((eof-object? var))
()
()
. rest))))

(define-syntax in-file
(syntax-rules ()
((in-file ((var) (file)) next . rest)
(in-file ((var) (file read-char)) next . rest))
((in-file ((var) (file reader)) next . rest)
(next ((p (open-input-file file)) (r reader))
((var (r p) (r p)))
((eof-object? var))
()
((dummy (close-input-port p)))
. rest))))

(define-syntax in-range
(syntax-rules ()
((in-range ((var) ()) next . rest)
(next () ((var 0 (+ var 1))) () () . rest))
((in-range ((var) (from)) next . rest)
(next () ((var from (+ var 1))) () () . rest))
((in-range ((var) (from to)) next . rest)
(in-range ((var) (from to 1)) next . rest))
((in-range ((var) (from to step)) next . rest)
(next ((tmp-to to))
((var from (+ var step)))
((>= var tmp-to))
()
()
. rest))))

(define-syntax collecting
(syntax-rules ()
((collecting ((var) source) next . rest)
(collecting ((var cursor) source) next . rest))
((collecting ((var cursor) (source)) next . rest)
(next ()
((cursor '() (cons source cursor)))
()
()
((var (reverse cursor)))
. rest))))

(define random-real
(let ((MAX_RAND (+ (expt 2 29) (- (expt 2 29) 1))))
(lambda () (/ (random-integer MAX_RAND) MAX_RAND))))

(define-syntax in-random
(syntax-rules ()
((in-random ((var) ()) next . rest)
(next () ((var (random-real) (random-real))) () () . rest))
((in-random ((var) (n)) next . rest)
(next ((tmp-n n))
((var (random-integer tmp-n) (random-integer tmp-n)))
()
()
()
. rest))
((in-random ((var) (n lo)) next . rest)
(next ((tmp-n n) (tmp-lo lo))
((var (+ tmp-lo (random-integer tmp-n))
(+ tmp-lo (random-integer tmp-n))))
()
()
()
. rest))))

;; Johnson-Trotter
;; Fast and uses constant space, but this implementation mutates the
;; cursor, which breaks re-entrant recursion. Not tuned.

(define (next-permutation! state lefts len . o)
(letrec
((mobile?
(lambda (i)
(let ((x (vector-ref state i)))
(if (vector-ref lefts i)
(and (positive? i) (< (vector-ref state (- i 1)) x))
(and (< i (- len 1)) (< (vector-ref state (+ i 1))
x))))))
(move!
(lambda (i x)
(if (vector-ref lefts i)
(let ((j (- i 1)))
(vector-set! state i (vector-ref state j))
(vector-set! state j x)
(vector-set! lefts i (vector-ref lefts j))
(vector-set! lefts j #t))
(let ((j (+ i 1)))
(vector-set! state i (vector-ref state j))
(vector-set! state j x)
(vector-set! lefts i (vector-ref lefts j))
(vector-set! lefts j #f)))
(let lp ((j (- len 1)))
(if (not (negative? j))
(begin
(if (< x (vector-ref state j))
(vector-set! lefts j (not (vector-ref lefts j))))
(lp (- j 1)))))))
(first-mobile
(lambda ()
(let lp ((i (- len 1)))
(cond
((negative? i) #f)
((mobile? i) (next-mobile i))
(else (lp (- i 1)))))))
(next-mobile
(lambda (i)
(let lp ((i i) (x (vector-ref state i)) (j (- i 1)))
(cond
((negative? j)
(move! i x)
(if (pair? o)
(let ((set (list->vector (car o))))
(let lp ((i (- len 1)) (res '()))
(if (negative? i)
res
(lp (- i 1)
(cons (vector-ref set (vector-ref state i))
res)))))
(vector->list state)))
((and (mobile? j) (< x (vector-ref state j)))
(lp j (vector-ref state j) (- j 1)))
(else
(lp i x (- j 1))))))))
(first-mobile)))

(define (make-vector-range n)
(let ((res (make-vector n)))
(let lp ((i (- n 1)))
(if (negative? i)
res
(begin (vector-set! res i i) (lp (- i 1)))))))

(define-syntax in-permutations
(syntax-rules ()
((in-permutations ((var) (set)) next . rest)
(next ((tmp-set set)
(len (length tmp-set))
(vec (make-vector-range len))
(lefts (make-vector len #t)))
((var set (next-permutation! vec lefts len tmp-set)))
((not var))
()
()
. rest))))

(define (next-pair-bucket vec start end)
(let lp ((i start))
(and (< i end)
(let ((x (vector-ref vec i)))
(if (pair? x)
i
(lp (+ i 1)))))))

;; can't be implemented portably & efficiently (could use call/cc +
;; hash-table-for-each though)

; (define-syntax in-hash-table
; (syntax-rules ()
; ((in-hash-table ((key val) (table)) next . rest)
; (next ((tmp-vec (##sys#slot table 1))
; (end (vector-length tmp-vec))
; (first-bucket (next-pair-bucket tmp-vec 0 end)))
; ((bucket first-bucket
; (if (and (pair? cell) (pair? (cdr cell)))
; bucket
; (next-pair-bucket tmp-vec (+ bucket 1) end)))
; (cell (and first-bucket (vector-ref tmp-vec
first-bucket))
; (if (and (pair? cell) (pair? (cdr cell)))
; (cdr cell)
; (let ((i (next-pair-bucket tmp-vec (+ bucket 1)
end)))
; (and i (vector-ref tmp-vec i))))))
; ((not bucket))
; ((key (caar cell))
; (val (cdar cell)))
; . rest))
; ))

[Abdulaziz Ghuloum]

Alex,

Thank you for a nice write up about a nice idea. This is perhaps the
most schemely loop that I've seen so far.

If I were able to (i.e. had 5 hours to spare), I would've written a
much longer criticism. :-)

Aziz,,,