[plt-scheme] engines in mzscheme

Douglas Troeger wrote:
>   For list-related administrative tasks:
>     http://list.cs.brown.edu/mailman/listinfo/plt-scheme
>
> Does anyone have an implementation of engines for
> mzscheme?

I played with engines some months ago.
Unfortunately, I can't remember the exact sources, but I remember
I used Sitaram and Dybvig's chapters on engines.

My contribution were solely to replace the timer-interrupt with
a timed-apply construction. Each time you apply a function,
you decrement the timer. A nice application of %app.

This was meant for my own amusement, so there are no
comments (red ears).

;;; Sources:
;;;   Dorai Sitaram, "Learn Scheme in a Fixnum of Dayes", chapter 15
;;;   Dyvig, http://www.scheme.com/tspl2d/examples.html#g2433

(module engine mzscheme
  (provide make-engine
           (rename timed-apply #%app)
           mileage)

  (define start-timer #f)
  (define stop-timer #f)
  (define decrement-timer #f)
  (let ((clock 0) (handler #f))
    (set! start-timer
          (lambda (ticks new-handler)
            (set! handler new-handler)
            (set! clock ticks)))
    (set! stop-timer
          (lambda ()
            (let ((time-left clock))
              (set! clock 0)
              time-left)))
    (set! decrement-timer
          (lambda ()
            (if (> clock 0)
                (begin
                  (set! clock (- clock 1))
                  (if (= clock 0) (handler)))))))

  (define make-engine
    (let ((do-complete #f) (do-expire #f))
      (define timer-handler
        (lambda ()
          (start-timer (call/cc do-expire) timer-handler)))
      (define new-engine
        (lambda (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)
        (new-engine
         (lambda (ticks)
           (start-timer ticks timer-handler)
           (let ((value (proc)))
             (let ((ticks (stop-timer)))
               (do-complete ticks value))))))))

  (define-syntax timed-apply
    (syntax-rules ()
      ((_ exp ... )
       (begin (decrement-timer)
              (#%app exp ...)))))

  (define mileage
    (lambda (thunk)
      (let loop ((eng (make-engine thunk)) (total-ticks 0))
        (eng 50
             (lambda (ticks value)
               (+ total-ticks (- 50 ticks)))
             (lambda (new-eng)
               (loop new-eng (+ total-ticks 50))))))))


(require engine)

(define fibonacci
  (lambda (n)
    (if (< n 2)
        n
        (+ (fibonacci (- n 1))
           (fibonacci (- n 2))))))

(define round-robin
  (lambda (engs)
    (if (null? engs)
        '()
        ((car engs) 1
         (lambda (ticks value)
           (cons value (round-robin (cdr engs))))
         (lambda (eng)
           (round-robin
            (append (cdr engs) (list eng))))))))

(round-robin
 (map (lambda (x)
        (make-engine
         (lambda ()
           (fibonacci x))))
      '(10 5 2 8 3 7 6 2)))

; parallel or
(define-syntax por
  (syntax-rules ()
    ((_ x ...)
     (first-true
      (list (make-engine (lambda () x)) ...)))))

(define first-true
  (lambda (engs)
    (if (null? engs)
        #f
        ((car engs) 1
         (lambda (ticks value)
           (or value (first-true (cdr engs))))
         (lambda (eng)
           (first-true
            (append (cdr engs) (list eng))))))))


(por 1 2)
(por ((lambda (x) (x x)) (lambda (x) (x x)))
     (fibonacci 10))

--
Jens Axel Søgaard