[ create a new paste ] login | about

Project: programmingpraxis
Link: http://programmingpraxis.codepad.org/WNImfKrZ    [ raw code | output | fork ]

programmingpraxis - Scheme, pasted on Nov 8:
; 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)


Output:
1
2
3
4
5
6
7
8
9
10
11
12
13
1
2
3
10
11
12
2
3
5
7
11
13
17


Create a new paste based on this one


Comments: