[plt-scheme] generators with sequences
Write up a section for the Guide, check it in as an aux library for
for-loops, and advertise. I am sure Matthew can show you where the
Guide lives and what the editorial rules are. -- Matthias
On Aug 26, 2009, at 1:29 AM, Jon Rafkind wrote:
> I wrote a generator syntax for use with the v4 `for' sequences. Some
> example usages are below but the main point is you can say (yield 5)
> when you want a function to produce a value that can be used as a
> sequence. It took me a few tries to get this right and I left most
> of my attempts in so others can maybe learn what not to do. This
> could go into collects/, so if anyone has any improvements please
> share! The last attempt (test4) is my best effort so far.
>
> #lang scheme
>
> (require scheme/control)
> (require scheme/stxparam)
> (define (check v1 v2)
> (when (not (equal? v1 v2))
> (printf "test failed expected ~a actual ~a\n" v1 v2)))
>
> (define (do-tests for-function)
> (check (for/list ([i (in-range 0 10)])
> i)
> (for/list ([i (in-range 0 10)])
> i))
>
> #;
> (let ([x 0])
> (for/list ([i (for-function)])
> (printf "i ~a x ~a\n" i x)
> (set! x (add1 x))
> i))
>
> (check (for/list ([i (in-range 0 10)])
> i)
> (let ([x 0])
> (for/list ([i (for-function)])
> ;; (printf "i ~a x ~a\n" i x)
> (set! x (add1 x))
> i)))
>
> (for/list ([i (for-function)]
> [j (in-range 0 5)])
> ;; (printf "i ~a j ~a\n" i j)
> (list i j))
>
> (check (for/list ([i (in-range 0 10)]
> [j (in-range 0 5)])
> (list i j))
> (for/list ([i (for-function)]
> [j (in-range 0 5)])
> ;; (printf "i ~a j ~a\n" i j)
> (list i j)))
>
> (check (for/list ([i (in-range 0 10)]
> [j (in-range 0 10)])
> (list i j))
> (for/list ([i (for-function)]
> [j (for-function)])
> (list i j)))
>
> (check (for/list ([(v vi) (in-indexed (in-range 0 10))])
> (list v vi))
> (for/list ([(v vi) (in-indexed (for-function))])
> (list v vi)))
>
> (check (for/list ([v (in-sequences (in-range 0 10) (in-range 0 10))])
> v)
> (for/list ([v (in-sequences (for-function) (for-function))])
> v))
>
> ;; doesn't work yet
> #;
> (check (for/list ([v (in-cycle (in-range 0 10))]
> [x (in-range 0 100)])
> v)
> (for/list ([v (in-cycle (for-function))]
> [x (in-range 0 100)])
> (printf "~a ~a\n" v x)
> v))
> )
>
> ;; completely broken version using call/cc and creating too many
> sequence objects
> (define test1
> (let ()
> (define-syntax yield
> (syntax-rules ()
> [(_ yielder value)
> (call/cc (lambda (ret)
> (let ([s (make-do-sequence (lambda ()
> (values
> (lambda (i) value)
> (lambda (x) (ret #f))
> 0
> (lambda (x) #t)
> (lambda (v) (eq? v
> value))
> (lambda (x v)
> #t))))])
> (yielder s))))]))
>
> (define-syntax define-generator
> (syntax-rules ()
> [(_ ret (name args ...) body0 bodies ...)
> (define (name args ...)
> (call/cc (lambda (ret)
> body0 bodies ...
> (make-do-sequence (lambda ()
> (values
> (lambda (i) (void))
> (lambda (x) (void))
> 0
> (lambda (x) #f)
> (lambda (x) #f)
> (lambda (x y) #f))))
> )))]))
>
>
> (define-generator yielder (blah)
> (for ([x (in-range 0 10)])
> (yield yielder x)))
>
> (printf "test1\n")
> (do-tests blah)
> ))
>
> ;; working version using prompt/control
> (define test2
> (let ()
> (define-syntax yield
> (syntax-rules ()
> [(_ value)
> ;; Capture the current delimited continuation, f, and pass
> back to the last prompt a,
> ;; value and a function that installs a new prompt and
> continues where f left off.
> (control f (values value (lambda () (prompt (f)))))]))
>
> (define-syntax lambda-generator
> (syntax-rules ()
> [(_ (args ...) body0 bodies ...)
> (lambda (args ...)
> (let* ([current (lambda ()
> (prompt
> body0 bodies ...
> ;; (printf "now what\n")
> (values #f #f)
> ))]
> [pos 0]
> [seq (make-do-sequence (lambda ()
> (values
> (lambda (i) (let-values
> ([(value next) (current)])
> ;; (printf
> "Next value is ~a\n" value)
> (set!
> current next)
> value))
> (lambda (x) (add1 x))
> 0
> (lambda (x) current)
> (lambda (v) current)
> (lambda (x v) current))))])
> seq))]))
>
> (define-syntax define-generator
> (syntax-rules ()
> [(_ (name args ...) body0 bodies ...)
> (define name (lambda-generator (args ...) body0 bodies ...))]))
>
> (define-generator (blah)
> (for ([x (in-range 0 10)])
> (yield x)))
>
> (printf "test2\n")
> (do-tests blah)
>
> #;
> (printf "test3\n")
> #;
> (do-tests (lambda ()
> (make-do-sequence (lambda ()
> (values
> (lambda (i) i)
> (lambda (x) (add1 x))
> 0
> (lambda (x) (< x 10))
> (lambda (v) #t)
> (lambda (x v) #t))))))
>
> ;; a cute example
> #;
> (let ()
> ;; generate infinte list of unique names
> (define-generator (machine-names)
> (define letters "abcdefghijklmnopqrstuvwxyz")
> (let loop ([len 0])
> ;; generates strings of length num
> (define-generator (generate num)
> (for ([letter (in-string
> letters)])
> (if (= num 0)
> (yield (string
> letter))
> (for ([l2 (generate
> (- num 1))])
> (yield (string-
> append (string letter) l2))))))
> (for ([str (generate len)])
> (yield str))
> (loop (add1 len))))
> (for ([s (machine-names)]
> [j (in-range 0 1000)])
> (printf "~a: ~a\n" j s)))
>
> ))
>
> ;; better version using shift/reset
> (define test3
> (let ()
> (define-syntax yield
> (syntax-rules ()
> [(_ value)
> (shift f (values value f))]))
>
> (define-syntax lambda-generator
> (syntax-rules ()
> [(_ (args ...) body0 bodies ...)
> (lambda (args ...)
> (let* ([current (lambda ()
> (reset
> body0 bodies ...
> ;; (printf "now what\n")
> (values #f #f)
> ))]
> [pos 0]
> [seq (make-do-sequence (lambda ()
> (values
> (lambda (i) (let-values
> ([(value next) (current)])
> ;; (printf
> "Next value is ~a\n" value)
> (set!
> current next)
> value))
> (lambda (x) (add1 x))
> 0
> (lambda (x) current)
> (lambda (v) current)
> (lambda (x v) current))))])
> seq))]))
>
> (define-syntax define-generator
> (syntax-rules ()
> [(_ (name args ...) body0 bodies ...)
> (define name (lambda-generator (args ...) body0 bodies ...))]))
>
> (define-generator (blah)
> (for ([x (in-range 0 10)])
> (yield x)))
>
> (printf "test3\n")
> (do-tests blah)
>
> #;
> (printf "test3\n")
> #;
> (do-tests (lambda ()
> (make-do-sequence (lambda ()
> (values
> (lambda (i) i)
> (lambda (x) (add1 x))
> 0
> (lambda (x) (< x 10))
> (lambda (v) #t)
> (lambda (x v) #t))))))
>
> ;; a cute example
> #;
> (let ()
> ;; generate infinte list of unique names
> (define-generator (machine-names)
> (define letters "abcdefghijklmnopqrstuvwxyz")
> (let loop ([len 0])
> ;; generates strings of length num
> (define-generator (generate num)
> (for ([letter (in-string
> letters)])
> (if (= num 0)
> (yield (string
> letter))
> (for ([l2 (generate
> (- num 1))])
> (yield (string-
> append (string letter) l2))))))
> (for ([str (generate len)])
> (yield str))
> (loop (add1 len))))
> (for ([s (machine-names)]
> [j (in-range 0 1000)])
> (printf "~a: ~a\n" j s)))
>
> ))
>
> ;; better version of shift/reset using continuation tags
> ;; also use a unique value to determine the end of the sequence
> instead of using #f
> (define test4
> (let ()
> (define-syntax-parameter yield (lambda (stx)
> (raise-syntax-error #f "yield is
> only bound inside a sequence generator")))
>
> (define-syntax lambda-generator
> (syntax-rules ()
> [(_ (args ...) body0 bodies ...)
> (lambda (args ...)
> (let* ([last (lambda () (void))]
> ;; current is a function that invokes user code and
> produces values
> [current (lambda ()
> ;; a unique tag to jump to
> (define tag (make-continuation-prompt-tag))
> ;; give the value to the sequence
> (define next (lambda (value)
> (shift-at tag f (values
> value f))))
> (syntax-parameterize ([yield (make-rename-
> transformer #'next)])
> (reset-at tag
> body0 bodies ...
> (values #f last)
> )))]
> [pos 0]
> [seq (make-do-sequence (lambda ()
> (values
> ;; produce a value and a
> continuation
> (lambda (i) (let-values
> ([(value next) (current)])
> ;; set! is
> ugly but can we do better?
> (set!
> current next)
> value))
> (lambda (x) (add1 x))
> 0
> (lambda (x) (not (eq?
> last current)))
> (lambda (v) (not (eq?
> last current)))
> (lambda (x v) (not (eq?
> last current))))))])
> seq))]))
>
> (define-syntax define-generator
> (syntax-rules ()
> [(_ (name args ...) body0 bodies ...)
> (define name (lambda-generator (args ...) body0 bodies ...))]))
>
> (define-generator (blah)
> (for ([x (in-range 0 10)])
> (yield x)))
>
> (printf "test4\n")
> (do-tests blah)
>
> (check (for/list ([i ((lambda-generator ()
> (for ([i (in-range 0 5)])
> (yield #f))))])
> i)
> (for/list ([i (in-range 0 5)])
> #f))
>
> (check (for/list ([i ((lambda-generator ()
> (for ([i (in-range 0 5)])
> (yield
> (reset
> (for ([j (in-range
> 2 5)])
> (shift k (+ i
> j))))))))])
> i)
> (for/list ([i (in-range 2 7)])
> i))
>
> #;
> (printf "test3\n")
> #;
> (do-tests (lambda ()
> (make-do-sequence (lambda ()
> (values
> (lambda (i) i)
> (lambda (x) (add1 x))
> 0
> (lambda (x) (< x 10))
> (lambda (v) #t)
> (lambda (x v) #t))))))
>
> ;; a cute example
> #;
> (let ()
> ;; generate infinte list of unique names
> (define-generator (machine-names)
> (define letters "abcdefghijklmnopqrstuvwxyz")
> (let loop ([len 0])
> ;; generates strings of length num
> (define-generator (generate num)
> (for ([letter (in-string
> letters)])
> (if (= num 0)
> (yield (string
> letter))
> (for ([l2 (generate
> (- num 1))])
> (yield (string-
> append (string letter) l2))))))
> (for ([str (generate len)])
> (yield str))
> (loop (add1 len))))
> (for ([s (machine-names)]
> [j (in-range 0 1000)])
> (printf "~a: ~a\n" j s)))
>
> ))
>
> _________________________________________________
> For list-related administrative tasks:
> http://list.cs.brown.edu/mailman/listinfo/plt-scheme
![[logo]](/logo.png){kind=logo}