Coroutines

gistfile1.rkt

#lang racket

;; asymmetric full coroutines from "Revisiting Coroutines"

(provide (contract-out
          [create (-> procedure? coroutine?)]
          [resume (->* (coroutine?) () #:rest (listof any/c) any)]
          [yield (-> any/c any)]
          [status (-> coroutine? (or/c 'running 'done 'suspended))]))

(struct coroutine (body status) #:mutable)

(define coroutine-prompt-tag
  (make-continuation-prompt-tag 'coroutine))

;; create a new coroutine
(define (create f) (coroutine f 'suspended))

;; convenience function
(define (wrap f)
  (define coroutine (create f))
  (λ args (apply resume coroutine args)))

;; resume a coroutine
(define (resume coroutine . args)
  (apply
   call-with-continuation-prompt
   (λ args 
     (set-coroutine-status! coroutine 'running)
     (define result (apply (coroutine-body coroutine) args))
     (set-coroutine-status! coroutine 'done)
     result)
   coroutine-prompt-tag
   (λ (v k)
     (set-coroutine-body! coroutine k)
     (set-coroutine-status! coroutine 'suspended)
     v)
   args))

;; yield from inside a coroutine
(define (yield v)
  (call-with-composable-continuation
   (λ (k)
     (abort-current-continuation coroutine-prompt-tag v k))
   coroutine-prompt-tag))

;; get the status of a coroutine
(define (status coroutine)
  (coroutine-status coroutine))

;; in-order traversal

(module+ test
  (struct node (key left right))
  
  (define (in-order node)
    (when (node? node)
      (in-order (node-left node))
      (yield (node-key node))
      (in-order (node-right node))))
  
  (define (in-order-iterator tree)
    (define coroutine (create (λ (x) (in-order tree) #f)))
    (λ () (resume coroutine #f)))
  
  (define (merge t1 t2)
    (define it1 (in-order-iterator t1))
    (define it2 (in-order-iterator t2))
    (define v1 (it1))
    (define v2 (it2))
    
    (let loop ()
      (cond [(or v1 v2)
             (cond [(and v1 (or (not v2) (< v1 v2)))
                    (displayln v1)
                    (set! v1 (it1))]
                   [else
                    (displayln v2)
                    (set! v2 (it2))])
             (loop)])))
  
  (define bt-1 (node 5 (node 3 #f #f) (node 7 (node 6 #f #f) #f)))
  (define bt-2 (node 8 (node 2 #f (node 4 #f #f)) (node 9 #f #f)))
  
  (merge bt-1 bt-2))