Megatest

Artifact [37c26a4330]
Login

Artifact 37c26a4330fa48ab28c220b1cbe16ad2448827e5:



;;======================================================================
;; Event Processing and Simulator
;;======================================================================

;; The global event list
(define *event-list* '())
(define *start-time* 0)
(define *end-time*   (* 60 60 4)) ;; four hours
(define *now*        *start-time*)
(define *done*       #f)

;; Each item in the event list is a list of a scheduled time and the thunk
;; (time thunk). Sort the list so that the next event is the earliest.
;;
(define event-sort
  (lambda (@a @b)
    (< (car @a)(car @b))))

(define event
  (lambda ($time $thunk)  ;; add a sort based on scheduled time here -- improve later
                          ;; to use an insert algorythm.
    (set! *event-list* (sort (cons (list $time $thunk) *event-list*) event-sort))))

(define start
  (lambda ()
    (let ((next (car *event-list*)))
      (set! *event-list* (cdr *event-list*))
      (set! *now* (car next))      
      (if (not *done*) ;; note that the second item in the list is the thunk
	  ((car (cdr next)))))))

(define pause
  (lambda ()
    (call/cc 
     (lambda (k)
       (event (lambda () (k #f)))
       (start)))))

(define schedule
  (lambda ($time)
    (call/cc 
     (lambda (k)
       (event (+ *now* $time) (lambda () (k #f)))
       (start)))))

;; (event (lambda () (let f () (pause) (display "h") (f))))

(define years->seconds
  (lambda ($yrs)
    (* $yrs 365 24 3600)))

(define weeks->seconds
  (lambda ($wks)
    (* $wks 7 24 3600)))

(define days->seconds
  (lambda ($days)
    (* $days 24 3600)))

(define months->seconds
  (lambda ($months)
    (* $months (/ 365 12) 24 3600)))

(define seconds->date
  (lambda ($seconds)
    (posix-strftime "%D" (posix-localtime (inexact->exact $seconds)))))

(define (seconds->h:m:s seconds)
  (let* ((hours   (quotient seconds 3600))
	 (rem1    (- seconds (* hours 3600)))
	 (minutes (quotient rem1 60))
	 (rem-sec (- rem1 (* minutes 60))))
    (conc hours "h " minutes "m " rem-sec "s")))