(module sicp-concurrency mzscheme
  ;; concurrency: SICP concurrency primitives
  ;; adapted from
  ;;; Sources:
  ;;; Dorai Sitaram, "Learn Scheme in a Fixnum of Dayes", chapter 15
  ;;; Dyvig,
  (provide (all-from-except mzscheme #%app #%datum set!))
  (provide make-serializer
           (rename timed-datum #%datum)
           (rename timed-apply #%app)
           (rename timed-set! set!))
  (require (only (lib "") first rest sort))
  (define yield-handler (lambda () (void)))
  (define clock 0)
  (define (start-timer ticks new-handler)
    (set! yield-handler new-handler)
    (set! clock ticks))
  (define (stop-timer)
    (let ([time-left clock])
      (set! clock 0)
  (define (decrement-timer)
    (if (> clock 0)
          (set! clock (- clock 1))
          (if (= clock 0)
  (define (random-shuffle a-list)
    (map rest
         (sort (map (lambda (x) (cons (random) x)) a-list)
               (lambda (x y) (< (first x) (first y))))))
  (define (parallel-execute . thunks)
    (round-robin (map make-engine (random-shuffle thunks))))
  (define (dole-out-gas)
    (add1 (random 12)))
  (define (round-robin engs)
    (if (null? engs)
        ((car engs) (dole-out-gas)
                    (lambda (ticks value)
                      (cons value (round-robin (cdr engs))))
                    (lambda (eng)
                       (append (cdr engs) (list eng)))))))
  (define make-engine
    (let ([do-complete #f]
          [do-expire #f])
      (define (timer-handler)
        (start-timer (call/cc do-expire) timer-handler))
      (define (new-engine resume)
        (lambda (ticks complete expire)
          ((call/cc (lambda (escape)
                      (set! do-complete
                            (lambda (ticks value)
                              (escape (lambda () (complete ticks value)))))
                      (set! do-expire
                            (lambda (resume)
                              (escape (lambda () (expire (new-engine resume))))))
                      (resume ticks))))))
      (lambda (proc)
         (lambda (ticks)
           (start-timer ticks timer-handler)
           (let ((value (proc)))
             (let ((ticks (stop-timer)))
               (do-complete ticks value))))))))
  (define-syntax timed-datum
    (syntax-rules ()
      [(_ . datum)
         (#%datum . datum))]))
  (define-syntax timed-apply
    (syntax-rules ()
      ((_ operator rand ... . last-rand)
         (#%app (begin (decrement-timer) operator)
                (begin (decrement-timer) rand) ...
                . (begin (decrement-timer) last-rand))))
      ((_ operator rand ...)
         (#%app (begin (decrement-timer) operator)
                (begin (decrement-timer) rand) ...)))))
  (define-syntax timed-set!
    (syntax-rules ()
      ((_ id expr)
         (set! id (begin
                    (let ([val expr])
  ;; The following definitions are adapted from SICP
  (define (make-serializer)
    (let ((mutex (timed-apply make-mutex)))
      (lambda (p)
        (define (serialized-p . args)
          (timed-apply mutex 'acquire)
          (let ((val (timed-apply apply p args)))
            (timed-apply mutex 'release)
  (define (make-mutex)
    (let ((cell (timed-apply list #f)))
      (define (the-mutex m)
        (cond ((timed-apply eq? m 'acquire)
               (if (timed-apply test-and-set! cell)
                   (timed-apply the-mutex 'acquire)))
              ((timed-apply eq? m 'release)
               (timed-apply clear! cell))))
  (define (clear! cell)
    (timed-apply set-car! cell #f))
  (define (test-and-set! cell)
    (if (car cell)
        (begin (set-car! cell #t)