; generators
(define-syntax define-generator
(lambda (x)
(syntax-case x (lambda)
((stx name (lambda formals e0 e1 ...))
(with-syntax ((yield (datum->syntax-object (syntax stx) 'yield)))
(syntax (define name
(lambda formals
(let ((resume #f) (return #f))
(define yield
(lambda args
(call-with-current-continuation
(lambda (cont)
(set! resume cont)
(apply return args)))))
(lambda ()
(call-with-current-continuation
(lambda (cont)
(set! return cont)
(cond (resume (resume))
(else (let () e0 e1 ...)
(error 'name "unexpected return"))))))))))))
((stx (name . formals) e0 e1 ...)
(syntax (stx name (lambda formals e0 e1 ...)))))))
;;; simple example
(define-generator (yield123)
(yield 1) (yield 2) (yield 3))
(define y (yield123))
(display (y)) (newline)
(display (y)) (newline)
(display (y)) (newline)
; (display (y)) (newline) ; uncomment to see error
;;; generator with arguments
(define-generator (one-up n)
(let loop ((n n)) (yield n) (loop (+ n 1))))
(define from10 (one-up 10))
(display (from10)) (newline)
(display (from10)) (newline)
(display (from10)) (newline)
;;; prime number generator
(define-syntax pq-rank (syntax-rules () ((_ pq) (vector-ref pq 0))))
(define-syntax pq-item (syntax-rules () ((_ pq) (vector-ref pq 1))))
(define-syntax pq-lkid (syntax-rules () ((_ pq) (vector-ref pq 2))))
(define-syntax pq-rkid (syntax-rules () ((_ pq) (vector-ref pq 3))))
(define pq-empty (vector 0 'pq-empty 'pq-empty 'pq-empty))
(define (pq-empty? pq) (eqv? pq pq-empty))
(define (pq-merge lt? p1 p2)
(define (pq-swap item lkid rkid)
(if (< (pq-rank rkid) (pq-rank lkid))
(vector (+ (pq-rank rkid) 1) item lkid rkid)
(vector (+ (pq-rank lkid) 1) item rkid lkid)))
(cond ((pq-empty? p1) p2)
((pq-empty? p2) p1)
((lt? (pq-item p2) (pq-item p1))
(pq-swap (pq-item p2) (pq-lkid p2)
(pq-merge lt? p1 (pq-rkid p2))))
(else (pq-swap (pq-item p1) (pq-lkid p1)
(pq-merge lt? (pq-rkid p1) p2)))))
(define (pq-insert lt? x pq)
(pq-merge lt? (vector 1 x pq-empty pq-empty) pq))
(define (pq-first pq)
(if (pq-empty? pq)
(error 'pq-first "empty priority queue")
(pq-item pq)))
(define (pq-rest lt? pq)
(if (pq-empty? pq)
(error 'pq-rest "empty priority queue")
(pq-merge lt? (pq-lkid pq) (pq-rkid pq))))
(define (lt? a b)
(or (< (car a) (car b))
(and (= (car a) (car b))
(< (cdr a) (cdr b)))))
(define-generator (prime-generator)
(yield 2) (yield 3)
(let ((pq (pq-insert lt? (cons 9 6) pq-empty)))
(let loop1 ((p 5) (pq pq))
(cond ((< p (car (pq-first pq)))
(yield p)
(let* ((c (* p p)) (s (+ p p))
(pq (pq-insert lt? (cons c s) pq)))
(loop1 (+ p 2) pq)))
(else (let loop2 ((pq pq))
(if (< p (car (pq-first pq)))
(loop1 (+ p 2) pq)
(let* ((c (car (pq-first pq)))
(s (cdr (pq-first pq)))
(pq (pq-rest lt? pq)))
(loop2 (pq-insert lt? (cons (+ c s) s) pq))))))))))
(define p (prime-generator))
(display (p)) (newline)
(display (p)) (newline)
(display (p)) (newline)
(display (p)) (newline)
(display (p)) (newline)
(display (p)) (newline)
(display (p)) (newline)