;; Schachtelbare Engines
;; ,open signals queues

(define call/cc call-with-current-continuation)

;; a stack

(define stack '())

(define (push . l)
  (set! stack (cons l stack)))

(define (pop handler)
  (if (null? stack)
      (error "attempt to return from inactive engine")
      (let ((top (car stack)))
	(set! stack (cdr stack))
	(apply handler top))))

(define (active?)
  (not (null? stack)))

;; timer

(define clock 0)

(define handler #f)

(define (start-timer ticks new-handler)
  (set! handler new-handler)
  (set! clock ticks))

(define (stop-timer)
  (let ((time-left clock))
    (set! clock 0)
    time-left))

(define (decrement-timer)
  (if (> clock 0)
      (begin
	(set! clock (- clock 1))
	(if (zero? clock)
	    (handler)))))

;; nestable engines

(define (timer-handler)
  (go (call/cc do-expire)))

(define (run resume parent-ticks child-ticks return expire)
  (let ((ticks (if (and (active?)
			(< parent-ticks child-ticks))
		   parent-ticks
		   child-ticks)))
    (push (- parent-ticks ticks)
	  (- child-ticks ticks)
	  return
	  expire)
    (resume ticks)))

(define (new-engine resume)
  (lambda (ticks return expire)
    ((call/cc
      (lambda (escape)
	(run resume
	     (stop-timer)
	     ticks
	     (lambda (value ticks)
	       (escape (lambda () (return value ticks))))
	     (lambda (engine)
	       (escape (lambda () (expire engine))))))))))

(define (go ticks)
  (if (active?)
      (if (zero? ticks)
	  (timer-handler)
	  (start-timer ticks timer-handler))))

(define (do-return value ticks)
  (pop (lambda (parent-ticks child-ticks return expire)
	 (go (+ parent-ticks ticks))
	 (return value (+ child-ticks ticks)))))

(define (do-expire resume)
  (pop (lambda (parent-ticks child-ticks return expire)
	 (if (> child-ticks 0)
	     (do-expire (lambda (ticks)
			  (run resume ticks child-ticks return expire)))
	     (begin
	       (go parent-ticks)
	       (expire (new-engine resume)))))))

(define (make-engine proc)
  (new-engine
   (lambda (ticks)
     (go ticks)
     (proc)
     (error "invalid completion"))))

(define (engine-return value)
  (do-return value (stop-timer)))

;; Round-Robin-Scheduler

(define (time-slice) 2)

(define (round-robin-scheduler proc)

  (define ready-queue (make-queue))

  (define (start proc)
    (enqueue! ready-queue
	      (make-engine
	       (lambda ()
		 (proc trap)))))

  (define (restart k v)
    (enqueue! ready-queue
	      (make-engine
	       (lambda ()
		 (k v)))))

  (define (trap message arg)
    (call/cc
     (lambda (k)
       (engine-return
	(lambda ()
	  (case message
	    ((uninterruptible)
	     (restart k (arg)))
	    ((start-process)
	     (start arg)
	     (restart k #f))
	    ((stop-process)
	     #f)))))))

  (define (dispatch)
    (if (queue-empty? ready-queue)
	'finished
	((dequeue! ready-queue)
	 (time-slice)
	 (lambda (trap-handler ticks)
	   (trap-handler)
	   (dispatch))
	 (lambda (engine)
	   (enqueue! ready-queue engine)
	   (dispatch)))))

  (start proc)
  (dispatch))

;; Beispiel

(define (print-thread thread-id)
  (lambda (trap)
    (let lp ((n 10))
      (if (zero? n)
	  (trap 'stop-process n)
	  (begin
	    (trap 'start-process
		  (lambda (trap)
		    (display 
		     (string-append "Thread " thread-id "-" thread-id))
		    (newline)
		    (trap 'stop-process #f)))
	    (display (string-append "Thread " thread-id))
	    (newline)
	    (decrement-timer)
	    (lp (- n 1)))))))

(define (two-threads)
  (round-robin-scheduler
   (lambda (trap)
     (trap 'start-process (print-thread "1"))
     (trap 'start-process (print-thread "2"))
     (trap 'stop-process #f))))