[plt-scheme] generators with sequences

From: Matthias Felleisen (matthias at ccs.neu.edu)
Date: Wed Aug 26 10:46:21 EDT 2009

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



Posted on the users mailing list.