;;; File:
;;;   coroutine.scm
;;; Summary:
;;;   A short exploration of coroutining in Scheme, using
;;;   continuations.
;;; Author:
;;;   Samuel A. Rebelsky

;;; Procedure:
;;;   make-buffer
;;; Purpose:
;;;   Creates a new buffer.
(define make-buffer
  (lambda (capacity)
    (let ((contents (make-vector capacity))
          (front 0)
          (back 0)
          (capacity capacity)
          (size 0))
      (lambda (command . params)
        (cond 
          ((eq? command ':empty?)
           (<= size 0))
          ((eq? command ':full?)
           (>= size capacity))
          ((eq? command ':get!)
           (let ((tmp (vector-ref contents front)))
             (set! front (modulo (+ front 1) capacity))
             (set! size (- size 1))
             tmp))
          ((eq? command ':put!)
           (vector-set! contents back (car params))
           (set! back (modulo (+ back 1) capacity))
           (set! size (+ size 1)))
          ((eq? command ':dump)
           (display "capacity: ") (display capacity) (newline)
           (display "size: ") (display size) (newline)
           (display "front: ") (display front) (newline)
           (display "back: ") (display back) (newline)
           (display "contents: ") (display contents) (newline))
          (else
           (error "Undefined command")))))))

;;; Procedure:
;;;   consumer
;;; Purpose:
;;;   Mimics a generic consumer.
(define consumer 
  (lambda (buffer DONE? SUSPEND CONSUMEVALUE)
    (let kernel ((count 0))
      (cond 
        ((DONE?) (display "ENDING CONSUMER") (newline))
        ((buffer ':empty?) 
         (display (list 'suspending 'consumer count)) (newline)
         (SUSPEND) 
         (kernel count))
        (else 
         (CONSUMEVALUE (buffer ':get!) count)
         (kernel (+ count 1)))))))

;;; Procedure:
;;;   producer
;;; Purpose:
;;;   Mimics a generic producer
(define producer
  (lambda (buffer DONE? SUSPEND CREATEVALUE)
    (let kernel ((count 0))
      (cond 
        ((DONE?) (display "ENDING PRODUCER") (newline))
        ((buffer ':full?) 
         (display (list 'suspending 'producer count)) (newline)
         (SUSPEND) 
         (kernel count))
        (else 
         (buffer ':put! (CREATEVALUE count)) 
         (kernel (+ count 1)))))))

;;; Procedure:
;;;   suspend
;;; Purpose:
;;;   Suspends the current operation and resumes the
;;;   previously suspended operation.  If there is no
;;;   previously suspended operation, caches the current
;;;   operation and exits.
(define cached 0)
(define suspend
    (lambda ()
      (let/cc k
        (let ((resume cached))
          (set! cached k)
          (if (not (eq? resume 0)) (resume))))))
(define reset
  (lambda ()
    (set! cached 0)))

;;; Procedure:
;;;   done?
;;; Purpose:
;;;   Decide that something is done
(define doneflag #f)

(define done?
  (lambda ()
    (zero? (random 50))))

;;; Procedure:
;;;   run
;;; Purpose:
;;;   Run the damn simulation
(define run
  (lambda ()
    ; Reset the suspension system
    (reset)
    (set! doneflag #f)
    ; Allocate the shared buffer
    (let ((buf (make-buffer 5)))
      ; Start the consumer.  Since the buffer is empty, the
      ; consumer will immediately suspend.
      (consumer buf done? suspend (lambda (x y) (display (list y x)) (newline)))
      ; Start the producer
      (producer buf done? suspend 
                (lambda (x) 
                   (let ((val (+ x (modulo x 3))))
                     (display (list 'Creating val)) (newline) val))
      )
    )
  )
)