Continuation Patterns

26.1 Generators

(define (make-generator lst)
  (define return #f)
  (define resume
    (lambda (ignored)
      (for-each (lambda (x)
                  (call/cc (lambda (k)
                             (set! resume k)
                             (return x))))
                lst)
      (return 'done)))
  (lambda ()
    (call/cc (lambda (r)
               (set! return r)
               (resume #f)))))

(define g (make-generator '(a b c)))
(g) (g) (g) (g)                            ; a b c done

;; Tree walker generator: compare the fringes of two trees lazily
(define (tree->generator tree)
  (define return #f)
  (define resume
    (lambda (ignored)
      (let walk ((t tree))
        (cond ((null? t) 'skip)
              ((pair? t) (walk (car t)) (walk (cdr t)))
              (else (call/cc (lambda (k) (set! resume k) (return t))))))
      (return 'done)))
  (lambda () (call/cc (lambda (r) (set! return r) (resume #f)))))

(define (same-fringe? t1 t2)
  (let ((g1 (tree->generator t1)) (g2 (tree->generator t2)))
    (let loop ()
      (let ((a (g1)) (b (g2)))
        (cond ((not (eqv? a b)) #f)
              ((eq? a 'done) #t)
              (else (loop)))))))
(same-fringe? '(1 (2 3)) '((1 2) 3))      
…

26.2 Cooperative Threads (Coroutines)

(define task-queue '())
(define scheduler-exit #f)
(define (enqueue! k) (set! task-queue (append task-queue (list k))))
(define (dequeue!) (let ((k (car task-queue))) (set! task-queue (cdr task-queue)) k))

(define (next-task)
  (if (null? task-queue)
      (scheduler-exit 'all-done)
      ((dequeue!) #f)))

(define (spawn thunk)
  (enqueue! (lambda (ignored) (thunk) (next-task))))

(define (yield)
  (call/cc (lambda (k) (enqueue! k) (next-task))))

(define (run-tasks)
  (call/cc (lambda (k) (set! scheduler-exit k) (next-task))))

(spawn (lambda () (for-each (lambda (i) (display "A") (display i) (newline) (yield)) '(1 2 3))))
(spawn (lambda () (for-each (lambda (i) (display "B") (display i) (newline) (yield)) '(1 2))))
(run-tasks)                                ; prints A1 B1 A2 B2 A3, returns all-done

26.3 Backtracking with amb

amb ("ambiguous", McCarthy 1963) explores choices depth-first, backtracking with continuations whenever a requirement fails. SICP 4.3 builds a whole evaluator around it.

(define amb-fail #f)
(define (reset-amb!) (set! amb-fail (lambda () (error "amb: no more choices"))))
(reset-amb!)

(define-syntax amb
  (syntax-rules ()
    ((_) (amb-fail))
    ((_ e) e)
    ((_ e1 e2 ...)
     (let ((prev-fail amb-fail))
       (call/cc
         (lambda (success)
           (call/cc
             (lambda (fail)
               (set! amb-fail (lambda () (set! amb-fail prev-fail) (fail 'retry)))
               (success e1)))
           (success (amb e2 ...))))))))

(define (amb-require condition) (if (not condition) (amb)))

;; Pythagorean triple search
(let* ((a (amb 1 2 3 4 5 6 7 8 9 10))
       (b (amb 1 2 3 4 5 6 7 8 9 10))
       (c (amb 1 2 3 4 5 6 7 8 9 10)))
  (amb-require (< a b))
  (amb-require (= (+ (* a a) (* b b)) (* c c)))
  (list a b c))                            ; (3 4 5)