;; tschedule.scm - (c) rohan drape, 2000-2006

;; ch = channel, th = thread, sq = queue, spp = seconds per pulse,
;; (cnt,utc) = known pulse location.

(define-structure tschedule ch th sq spp pls utc)

(define (tschedule-ppm Q)
  (spp->ppm (tschedule-spp Q)))

(define (pulse->utc Q pulse)
  (+ (tschedule-utc Q)
     (* (- pulse (tschedule-pls Q))
	(tschedule-spp Q))))

(define (utc->pulse Q utc)
  (+ (tschedule-pls Q)
     (/ (- utc (tschedule-utc Q))
	(tschedule-spp Q))))

(define (tschedule-at! Q p f)
  (async-channel-put (tschedule-ch Q) (make-sqe p f)))

(define (tschedule-set-timer! Q t)
  (async-channel-put (tschedule-ch Q) t))

(define (tschedule-clear! Q)
  (async-channel-put (tschedule-ch Q) #f))

(define (tschedule-dispatch! Q SQ t p)
  (let* ((e  (sq-min SQ))
	 (f  (sqe-v e))
	 (p* (sqe-k e)))
    (if (<= p* p)
	(begin
	 (sq-remove-min! SQ)
	 (with-exception-handler
	  (lambda (e) (begin (display "tschedule-dispatch!: error:")
			     (display e)
			     (newline)))
	  (lambda ()  (f p (lambda (i)
			     (if (number? i)
				 (tschedule-at! Q (+ p i) f))))))))))

(define (tschedule-sync-thread! CH SQ Q)
  (make-thread*
   (lambda ()
     (let loop ((p +inf.0) (t +inf.0))
       (sync
	(handle-evt (alarm-evt (* 1000.0 t))
		    (lambda (_)
		      (begin
			(if (not (sq-empty? SQ))
			    (tschedule-dispatch! Q SQ t p))
			(if (sq-empty? SQ)
			    (loop +inf.0 +inf.0)
			    (let ((p* (sqe-k (sq-min SQ))))
			      (loop p* (pulse->utc Q p*)))))))
	(handle-evt CH
		    (lambda (v)
		      (cond ((sqe? v)
			     (begin
			       (sq-insert! SQ v)
			       (let ((p* (min (sqe-k v) p)))
				 (loop p* (pulse->utc Q p*)))))
			    ((number? v)
			     (let ((p* (utc->pulse Q v)))
			       (loop p* v)))
			    ((eq? v #f)
			     (begin
			       (sq-clear! SQ)
			       (loop +inf.0 +inf.0)))
			    (else
			     (error "illegal value" v))))))))))

(define (make-tschedule! ppm pulse time)
  (let* ((CH (make-async-channel))
	 (SQ (make-sq* <=))
	 (Q  (make-tschedule CH #f SQ (ppm->spp ppm) pulse time)))
    (begin
     (set-tschedule-th! Q (tschedule-sync-thread! CH SQ Q))
     Q)))

(define (tschedule-terminate! Q)
  (begin
   (tschedule-clear! Q)
   (thread-terminate! (tschedule-th Q))))

(define (tschedule-reset! Q ppm pls utc)
  (let ((spp (ppm->spp ppm))
	(SQ  (tschedule-sq Q)))
    (set-tschedule-pls! Q pls)
    (set-tschedule-utc! Q utc)
    (set-tschedule-spp! Q spp)
    (if (not (sq-empty? SQ))
	(let* ((p (sqe-k (sq-min SQ)))
	       (t (pulse->utc Q p)))
	  (tschedule-set-timer! Q t)))))

(define (tschedule-reset*! Q ppm)
  (let* ((utc (utc))
	 (pls (utc->pulse Q utc)))
    (tschedule-reset! Q ppm pls utc)))