[_CDCSL_93-16_]<1>Cedar>release>Scheme>Iterate.scheme

;;; Iterate.scheme

;;; Last changed by Pavel on March 22, 1989 6:17:43 pm PST

;;; Michael Plass, January 21, 1989 0:14:39 am PST

;;; ITERATE and ITERATE*

(extend-syntax (iterate)

( (iterate ((var gen-expr) ...)
body more-body ...)

(with ((return-name (gensym))

(loop-name (gensym))

((gen-name ...) (map (lambda (ignore) (gensym)) '(var ...))))

(call-with-current-continuation

(lambda (exit)

(let ((return-name (lambda () (exit '())))
(gen-name gen-expr) ...
(var #f) ...)

(let loop-name ()

(call-with-current-continuation

(lambda (loop)

(let ((loop (lambda () (loop #f))))

(set! var (gen-name return-name)) ...

body

more-body ...)))

(loop-name))))))))

(extend-syntax (iterate*)

( (iterate* ((var gen-expr) ...)
body more-body ...)

(with ((return-name (gensym))
(loop-name (gensym))
((gen-name ...) (map (lambda (ignore) (gensym)) '(var ...))))

(call-with-current-continuation

(lambda (exit)

(let* ((return-name (lambda () (exit '())))
{(gen-name gen-expr)
(var #f)} ...)

(let loop-name ()

(call-with-current-continuation

(lambda (loop)

(let ((loop (lambda () (loop #f))))

(set! var (gen-name return-name)) ...

body

more-body ...)))

(loop-name))))))))

;;; GATHERING

(extend-syntax (gathering)

;; Because we currently lack multiple values in Scheme, the one-gatherer

;; case of GATHERING returns the value of that accumulation but the

;; multiple-gatherer case returns a LIST of the values of the

;; accumulations. This discontinuity is ugly, but convenient for the

;; usual case.

( (gathering ((var expr))
body more-body ...)

(with ((gatherer-name (gensym)))

(let* ((gatherer-name expr)
(var (car gatherer-name))
(gather (lambda (value accumulator)
(accumulator value))))

body

more-body ...

((cadr gatherer-name)))))

( (gathering ((var expr) ...)
body more-body ...)

(with (((gatherer-name ...) (map (lambda (ignore) (gensym))
'(var ...))))

(let* ((gatherer-name expr) ...
(var (car gatherer-name)) ...
(gather (lambda (value accumulator)
(accumulator value))))

body

more-body ...

(list ((cadr gatherer-name)) ...)))))

;;; Some Useful Generators

(define (list-elements list)

(lambda (when-done-fn)

(if (null? list)

(when-done-fn)

(let ((elt (car list)))

(set! list (cdr list))

elt))))

(define (list-tails list)

(lambda (when-done-fn)

(if (null? list)

(when-done-fn)

(let ((prev list))

(set! list (cdr list))

prev))))

(define (interval from . rest)

"(from [to [step]]) Generate the numbers FROM <= FROM + k*STEP <= TO. TO defaults to positive infinity, STEP defaults to 1."

(let* ((n from)

(to #f)

(step 1))

(unless (null? rest)

(set! to (car rest))

(set! rest (cdr rest)))

(unless (null? rest)

(set! step (car rest)))

(if (not to)

(lambda (when-done-fn)

(let ((old-n n))

(set! n (+ n step))

old-n))

(lambda (when-done-fn)

(if (> n to)

(when-done-fn)

(let ((old-n n))

(set! n (+ n step))

old-n))))))

(define (interval-decreasing from . rest)

"(from [to [step]]) Generate the numbers TO <= FROM - k*STEP <= FROM. TO defaults to negative infinity, STEP defaults to 1."

(let* ((n from)

(to #f)

(step 1))

(unless (null? rest)

(set! to (car rest))

(set! rest (cdr rest)))

(unless (null? rest)

(set! step (car rest)))

(if (not to)

(lambda (when-done-fn)

(let ((old-n n))

(set! n (- n step))

old-n))

(lambda (when-done-fn)

(if (< n to)

(when-done-fn)

(let ((old-n n))

(set! n (- n step))

old-n))))))

(extend-syntax (interval)

( (interval arg others ...)

(#"Parse Interval" (#f #f #f #f #f #f #f) arg others ...)))

(extend-syntax (#"Parse Interval"
:from :down-from :to :down-to :above :below :by)

;; First, we parse the arguments. The use of #f here ensures that

;; no illegal combinations of options occur.

( (#"Parse Interval" (#f #f to down-to above below by)
:from from others ...)

(#"Parse Interval" (from #f to down-to above below by)
others ...))

( (#"Parse Interval" (#f #f to down-to above #f by)
:down-from down-from others ...)

(#"Parse Interval" (#f down-from to down-to above #f by)
others ...))

( (#"Parse Interval" (from down-from #f #f #f #f by)
:to to others ...)

(#"Parse Interval" (from down-from to #f #f #f by)
others ...))

( (#"Parse Interval" (from down-from #f #f #f #f by)
:down-to down-to others ...)

(#"Parse Interval" (from down-from #f down-to #f #f by)
others ...))

( (#"Parse Interval" (from down-from #f #f #f #f by)
:above above others ...)

(#"Parse Interval" (from down-from #f #f above #f by)
others ...))

( (#"Parse Interval" (from #f #f #f #f #f by)
:below below others ...)

(#"Parse Interval" (from #f #f #f #f below by)
others ...))

( (#"Parse Interval" (from down-from to down-to above below #f)
:by by others ...)

(#"Parse Interval" (from down-from to down-to above below by)
others ...))

;; Next, give a default value for BY

( (#"Parse Interval" (from down-from to down-to above below #f))

(#"Parse Interval" (from down-from to down-to above below 1)))

;; Next, figure out where we start the iteration variable.

( (#"Parse Interval" (#f #f to down-to above below by))

(#"Parse Interval" (0) (#f #f to down-to above below by)))

( (#"Parse Interval" (from #f to down-to above below by))

(#"Parse Interval" (from) (from #f to down-to above below by)))

( (#"Parse Interval" (#f down-from to down-to above below by))

(#"Parse Interval" (down-from)
(#f down-from to down-to above below by)))

;; Now figure out whether we're adding or subtracting.

( (#"Parse Interval" (start) (from #f to #f #f below by))

(#"Parse Interval" (start +) (from #f to #f #f below by)))

( (#"Parse Interval" (start)
(from down-from to down-to above below by))

(#"Parse Interval" (start -)
(from down-from to down-to above below by)))

;; We can generate code now if no limit was given

( (#"Parse Interval" (start op) (from down-from #f #f #f #f by))

(let ((n start)

(delta by))

(lambda (when-done-fn)

(let ((old-n n))

(set! n (op n delta))

old-n))))

;; Oh, well. Let's figure out what the limit and test are.

( (#"Parse Interval" (start op) (from down-from to #f #f #f by))

(#"Parse Interval" (start op to > by)))

( (#"Parse Interval" (start op) (from down-from #f down-to #f #f by))

(#"Parse Interval" (start op down-to < by)))

( (#"Parse Interval" (start op) (from down-from #f #f above #f by))

(#"Parse Interval" (start op above <= by)))

( (#"Parse Interval" (start op) (from down-from #f #f #f below by))

(#"Parse Interval" (start op below >= by)))

;; Now we can generate the code for the general case.

( (#"Parse Interval" (start op limit test by))

(let ((n start)
(top limit)
(delta by))

(lambda (when-done-fn)

(if (test n top)

(when-done-fn)

(let ((old-n n))

(set! n (op n delta))

old-n))))))

(define (vector-elements vector)

(let ((index 0)
(length (vector-length vector)))

(lambda (when-done-fn)

(if (>= index length)

(when-done-fn)

(let ((elt (vector-ref vector index)))

(set! index (+ index 1))

elt)))))

(define (init-step value step-fn)

(let ((first-time? #t))

(lambda (when-done-fn)

(if first-time?

(set! first-time? #f)

(set! value (step-fn value)))

value)))

(extend-syntax (each-time)

( (each-time expr)

(with ((when-done-fn (gensym)))

(lambda (when-done-fn)

expr))))

(extend-syntax (while)

( (while expr)

(with ((when-done-fn (gensym)))

(lambda (when-done-fn)

(if (not expr)

(when-done-fn))))))

(extend-syntax (until)

( (until expr)

(with ((when-done-fn (gensym)))

(lambda (when-done-fn)

(if expr

(when-done-fn))))))

;;; Some Useful Gatherers

(define (collecting)

(let ((head '())
(tail '()))

(list

(lambda (value)

(cond

((null? head)

(set! head (list value))

(set! tail head))

(else

(set-cdr! tail (list value))

(set! tail (cdr tail)))))

(lambda ()

head))))

(define (summing)

(let ((sum 0))

(list

(lambda (value)

(set! sum (+ sum value)))

(lambda ()

sum))))

(define (counting)

(let ((count 0))

(list

(lambda (flag)

(if flag

(set! count (+ count 1))))

(lambda ()

count))))

(define (maximizing)

(let ((top #f))

(list

(lambda (value)

(if (not top)

(set! top value)

(set! top (max top value))))

(lambda ()

top))))

(define (minimizing)

(let ((bottom #f))

(list

(lambda (value)

(if (not bottom)

(set! bottom value)

(set! bottom (min bottom value))))

(lambda ()

bottom))))

(define (appending)

(let ((head '())
(tail '()))

(list

(lambda (value)

(cond

((null? head)

(set! head (append value '()))

(set! tail (last-pair head)))

(else

(set-cdr! tail (append value '()))

(set! tail (last-pair tail)))))

(lambda ()

head))))

(define (appending!)

(let ((head '())
(tail '()))

(list

(lambda (value)

(cond

((null? head)

(set! head value)

(set! tail (last-pair head)))

(else

(set-cdr! tail value)

(set! tail (last-pair tail)))))

(lambda ()

head))))