[plt-scheme] On continuations...

On Fri, 17 Dec 2004 17:48:05 -0500, Matthias Felleisen
<matthias at ccs.neu.edu> wrote:
> 
> John, I think michael wants macros so that
> 
> (def part (n)
>       (if (= n 0)
>           (yield empty)
>           (return #f))
>       (for-each-yield part (- n 1)
>                       (lambda (p)
>                         (yield (cons 1 p))
>                         (if (and (pair? p) (or (null? (cdr p)) (< (car
> p) (cadr p))))
>                             (yield (cons (+ 1 (car sp)) (cdr sp)))))))
> 
> works. Daniel? -- Matthias
> 
> P.S. The macros are left as an exercise to the reader. Hint: use
> syntax-case.

The Pythonic way would use vectors, so here we go:

(module generator mzscheme
  ;; Implemetation of Generators by Oleg
  ;; http://okmij.org/ftp/Scheme/enumerators-callcc.html#Generators

  ;;; PLTized Oleg's "generative" for easier reading.
  ;;; Also renamed "suspend" to "yield."
  
  (provide generative define-gen)
  
  ;; (yield -> sxp) -> promise
  (define (generative g)
    (delay (let/cc k-main
             (define (yield val)
               (let/cc k-reenter
                 (k-main (cons val
                               (delay (let/cc k-new-main
                                        (set! k-main k-new-main)
                                        (k-reenter #f)))))))
             (g yield)
             (k-main null))))

  (define-syntax (define-gen stx)
    (syntax-case stx ()
      [(_ (id args ...) bodies ...)
       (with-syntax ([yield (datum->syntax-object stx 'yield)])
         #'(define (id args ...)
             (generative (lambda (yield)
                           bodies ...))))]))
  
  )

(module iterator mzscheme
  (require (lib "class.ss")
           "generator.ss")
  (provide iterator% define-igen exn:stop-iteration? iterate)
  
  (define-struct (exn:stop-iteration exn) ())
  
  (define iterator%
    (class object%
      (init-field init-cursor)
      (define promise init-cursor)
      (define/public (next)
        (unless promise
          (raise (make-exn:stop-iteration "StopIteration"
                                          (current-continuation-marks))))
        (let ([res (with-handlers ([void (lambda (e)
                                           (set! promise #f)
                                           (raise e))])
                     (force promise))])
          (if (pair? res)
              (begin (set! promise (cdr res))
                     (car res))
              (begin (set! promise #f)
                     (next)))))
      
      (define/public (reset)
        (set! promise init-cursor))
      (super-new)))
  
  (define (iterate proc iterator)
    (let loop ()
      (with-handlers ([exn:stop-iteration? void])
        (proc (send iterator next))
        (loop))))
  
  (define-syntax (define-igen stx)
    (syntax-case stx ()
      [(_ (id args ...) bodies ...)
       (with-syntax ([yield (datum->syntax-object stx 'yield)])
         #'(define (id args ...)
             (make-object iterator%
               (generative (lambda (yield)
                             bodies ...)))))]))
  
  )

(module iterator-test mzscheme
  (require "iterator.ss"
           (lib "class.ss"))
  
  (define-igen (iter lst)
    (for-each yield
              lst))

  (define-igen (iter/errors lst)
    (for-each yield
              lst)
    (raise "oops"))

  (define i (iter '(1 2 3)))
  (for-each (lambda (result)
              (printf "~a~n" result))
            (list (= 1 (send i next))
                  (= 2 (send i next))
                  (= 3 (send i next))
                  (with-handlers ([exn:stop-iteration? (lambda (e) #t)])
                    (send i next)
                    #f)))
  
  (iterate display (iter '(1 2 3)))
  (newline)

  (define ie (iter/errors '(1 2 3)))
  (for-each (lambda (result)
              (printf "~a~n" (force result)))
            (list (delay (= 1 (send ie next)))
                  (delay (= 2 (send ie next)))
                  (delay (= 3 (send ie next)))
                  ;; BUG! why isn't this exn caught?
                  ;(delay
                  ;  (with-handlers ([exn:stop-iteration? (lambda (e) #t)])
                  ;    (send ie next)
                  ;    #f))
                  ))
  
  )

(module vector-utils mzscheme
  (provide (all-defined))
  (define (vector->bool v)
    (not (zero? (vector-length v))))
  
  (define (vector+ v w)
    (define size (+ (vector-length v)
                    (vector-length w)))
    (define newv (make-vector size))
    (let loop ([idx 0])
      (unless (= idx (vector-length v))
        (vector-set! newv idx (vector-ref v idx))
        (loop (add1 idx))))
    (let loop ([idx (vector-length v)])
      (unless (= idx size)
        (vector-set! newv idx (vector-ref w (- idx
                                               (vector-length v))))
        (loop (add1 idx))))
    newv)
  
  (define (vector-for-each proc v)
    (let loop ([idx 0])
      (unless (= idx (vector-length v))
        (proc (vector-ref v idx))
        (loop (add1 idx)))))
  
  (define (subvector v start)
    (define size (- (vector-length v) start))
    (define newv (make-vector size))
    (let loop ([idx 0])
      (unless (= idx size)
        (vector-set! newv idx
                     (vector-ref v (+ start idx)))))
    newv)
)

(module partitions mzscheme
  
  (require "iterator.ss"
           "vector-utils.ss"
           (lib "class.ss"))
  (provide partitions)
  
  ;def partitions(n):
  ;       # base case of recursion: zero is the sum of the
  ;empty list
  ;       if n == 0:
  ;               yield []
  ;               return
  ;
  ;       # modify partitions of n-1 to form partitions of n
  ;       for p in partitions(n-1):
  ;               yield [1] + p
  ;               if p and (len(p) < 2 or p[1] > p[0]):
  ;                       yield [p[0] + 1] + p[1:]
  
  (define-igen (partitions n)
     (let/ec return
       (when (= n 0)
         (yield (vector))
         (return (void)))
       (iterate (lambda (p)
                  (yield (vector+ (vector 1) p))
                  (when (and (vector->bool p)
                             (or (< (vector-length p) 2)
                                 (> (vector-ref p 1)
                                    (vector-ref p 0))))
                    (yield (vector+ (vector (+ (vector-ref p 0) 1))
                                    (subvector p 1)))))
                (partitions (- n 1)))))
  
  )


Daniel