ADDED   batchsim/batchsim.scm
Index: batchsim/batchsim.scm
==================================================================
--- /dev/null
+++ batchsim/batchsim.scm
@@ -0,0 +1,356 @@
+(use ezxdisp srfi-18)
+
+(define *ezx* (ezx-init 650 650 "Test Critter"))
+(require-library ezxgui)
+(define *green*  (make-ezx-color 0 1 0)) 
+(define *black*  (make-ezx-color 0 0 0))
+(define *grey*   (make-ezx-color 0.1 0.1 0.1))
+(define *blue*   (make-ezx-color 0 0 1)) 
+(define *cyan*   (make-ezx-color 0 1 1))
+(define *green*  (make-ezx-color 0 1 0))
+(define *purple* (make-ezx-color 1 0 1))
+(define *red*    (make-ezx-color 1 0 0))
+(define *white*  (make-ezx-color 1 1 1))
+(define *yellow* (make-ezx-color 1 1 0))
+
+(define *user-colors-palette*
+  (list 
+   *green*
+   *blue*
+   *cyan*
+   *purple*
+   *red*
+   *yellow*
+   *black*))
+
+(define *dark-green* (get-color "dark-green"))
+(define *brown*      (get-color "brown"))
+
+(ezx-select-layer *ezx* 1)
+(ezx-wipe-layer *ezx* 1)
+
+;; (ezx-str-2d *ezx* 30 30 "Hello" *white*)
+;; (ezx-fillrect-2d *ezx* 100 100 120 120 *brown*)
+(ezx-redraw *ezx*)
+
+(define *last-draw* (current-milliseconds))
+(define *draw-delta* 40) ;; milliseconds between drawing
+
+(define (wait-for-next-draw-time)
+  (let* ((cm    (current-milliseconds))
+	 (delta (- *draw-delta* (- cm *last-draw*))))
+    (if (> delta 0)
+	(thread-sleep! (/ delta 1000)))
+    (set! *last-draw* (current-milliseconds))))
+
+(include "events.scm")
+
+;; System spec (to be moved into loaded file)
+;;
+;;                           x  y  w gap  x-min x-max
+(define *cpu-grid* (vector  500 50 15  2  500   645))
+(define (make-cpu:grid)(make-vector 6))
+(define *queues* (make-hash-table)) ;; name -> (list (list user duration num-cpus num-gigs) ... )
+(define *cpus* (make-hash-table)) ;; cpu-name => (vector user job-len num-cpu mem x-loc y-loc)
+(define *obj-locations* (make-hash-table)) ;; name -> (x y layer)
+(define *queue-spec*
+  (vector
+   80  ;; start-x
+   300 ;; start-y
+   300 ;; delta-y how far to next queue
+   15  ;; height
+   400 ;; length
+   ))
+(define *use-log* #f)
+(define *job-log-scale* 10)
+
+;;======================================================================
+;; Users
+;;======================================================================
+
+(define *user-colors* (make-hash-table))
+
+(define (get-user-color user)
+  (let ((color (hash-table-ref/default *user-colors* user #f)))
+    (if color
+	color
+	(let* ((color-num (+ (length (hash-table-keys *user-colors*)) 1))
+	       (color     (list-ref *user-colors-palette* color-num)))
+	  (hash-table-set! *user-colors* user color)
+	  color))))
+
+;;======================================================================
+;; Job Queues
+;;======================================================================
+
+;; jobs
+
+(define (make-queue:job)(make-vector 4))
+(define-inline (queue:job-get-user       vec)    (vector-ref  vec 0))
+(define-inline (queue:job-get-duration   vec)    (vector-ref  vec 1))
+(define-inline (queue:job-get-num-cpu    vec)    (vector-ref  vec 2))
+(define-inline (queue:job-get-num-gigs   vec)    (vector-ref  vec 3))
+(define-inline (queue:job-set-user!      vec val)(vector-set! vec 0 val))
+(define-inline (queue:job-set-duration!  vec val)(vector-set! vec 1 val))
+(define-inline (queue:job-set-num-cpu!   vec val)(vector-set! vec 2 val))
+(define-inline (queue:job-set-num-gigs!  vec val)(vector-set! vec 3 val))
+
+;; add a job to the queue
+;;
+(define (add-job queue-name user duration num-cpu num-gigs)
+  (let* ((queue-dat (hash-table-ref/default *queues* queue-name '()))
+	 (new-queue (append 
+		     queue-dat
+		     (list (vector user duration num-cpu num-gigs)))))
+  (hash-table-set! *queues* queue-name new-queue)
+  (draw-queue-jobs queue-name)))
+
+;; peek for jobs to do in queue
+;;
+(define (peek-job queue-name)
+  (let ((queue (hash-table-ref/default *queues* queue-name '())))
+    (if (null? queue)
+	#f
+	(car queue))))
+
+;; take job from queue
+;;
+(define (take-job queue-name)
+  (let ((queue (hash-table-ref/default *queues* queue-name '())))
+    (if (null? queue)
+	#f
+	(begin
+	  (hash-table-set! *queues* queue-name (cdr queue))
+	  (draw-queue-jobs queue-name)
+	  (car queue)))))
+
+;;======================================================================
+;; CPUs
+;;======================================================================
+
+(define (make-cpu:dat)(make-vector 6 #f))
+(define-inline (cpu:dat-get-user      vec)    (vector-ref  vec 0))
+(define-inline (cpu:dat-get-job-len   vec)    (vector-ref  vec 1))
+(define-inline (cpu:dat-get-num-cpu   vec)    (vector-ref  vec 2))
+(define-inline (cpu:dat-get-mem       vec)    (vector-ref  vec 3))
+(define-inline (cpu:dat-get-x         vec)    (vector-ref  vec 4))
+(define-inline (cpu:dat-get-y         vec)    (vector-ref  vec 5))
+(define-inline (cpu:dat-set-user!     vec val)(vector-set! vec 0 val))
+(define-inline (cpu:dat-set-job-len!  vec val)(vector-set! vec 1 val))
+(define-inline (cpu:dat-set-num-cpu!  vec val)(vector-set! vec 2 val))
+(define-inline (cpu:dat-set-mem!      vec val)(vector-set! vec 3 val))
+(define-inline (cpu:dat-set-x!        vec val)(vector-set! vec 4 val))
+(define-inline (cpu:dat-set-y!        vec val)(vector-set! vec 5 val))
+
+(define-inline (cpu:grid-get-x        vec)    (vector-ref  vec 0))
+(define-inline (cpu:grid-get-y        vec)    (vector-ref  vec 1))
+(define-inline (cpu:grid-get-w        vec)    (vector-ref  vec 2))
+(define-inline (cpu:grid-get-gap      vec)    (vector-ref  vec 3))
+(define-inline (cpu:grid-get-x-min    vec)    (vector-ref  vec 4))
+(define-inline (cpu:grid-get-x-max    vec)    (vector-ref  vec 5))
+(define-inline (cpu:grid-set-x!       vec val)(vector-set! vec 0 val))
+(define-inline (cpu:grid-set-y!       vec val)(vector-set! vec 1 val))
+(define-inline (cpu:grid-set-w!       vec val)(vector-set! vec 2 val))
+(define-inline (cpu:grid-set-gap!     vec val)(vector-set! vec 3 val))
+(define-inline (cpu:grid-set-x-min!   vec val)(vector-set! vec 4 val))
+(define-inline (cpu:grid-set-x-max!   vec val)(vector-set! vec 5 val))
+
+(define (add-cpu name num-cores mem)
+  (let ((x     (cpu:grid-get-x     *cpu-grid*))
+	(y     (cpu:grid-get-y     *cpu-grid*))
+	(delta (+ (cpu:grid-get-w  *cpu-grid*)(cpu:grid-get-gap *cpu-grid*)))
+	(x-max (cpu:grid-get-x-max *cpu-grid*)))
+    (hash-table-set! *cpus* name (vector #f #f num-cores mem x y))
+    (if (> x x-max)
+	(begin
+	  (cpu:grid-set-x! *cpu-grid* (cpu:grid-get-x-min *cpu-grid*))
+	  (cpu:grid-set-y! *cpu-grid* (+ y delta)))
+	(cpu:grid-set-x! *cpu-grid* (+ x delta)))))
+
+;; draw grey box for each cpu on layer 2
+;; jobs are drawn on layer 1
+;;
+(define (draw-cpus) ;; call once after init'ing all cpus
+  (ezx-select-layer *ezx* 1)
+  (ezx-wipe-layer   *ezx* 1)
+  ;; draw time at upper right
+  (ezx-str-2d *ezx* 20 20 (seconds->h:m:s *now*) *black*)
+  (for-each
+   (lambda (cpu)
+     (let ((x (cpu:dat-get-x cpu))
+	   (y (cpu:dat-get-y cpu))
+	   (w (cpu:grid-get-w *cpu-grid*)))
+       (ezx-rect-2d *ezx* x y (+ x w) (+ y w) *grey* 1)))
+   (hash-table-values *cpus*))
+  (ezx-redraw *ezx*))
+
+(define (draw-jobs)
+  ;; (draw-cpus)
+  (ezx-select-layer *ezx* 2)
+  (ezx-wipe-layer   *ezx* 2)
+  (for-each
+   (lambda (cpu)
+     (let* ((x (cpu:dat-get-x cpu))
+	    (y (cpu:dat-get-y cpu))
+	    (w (cpu:grid-get-w *cpu-grid*))
+	    (u (cpu:dat-get-user cpu)))
+       (if u ;; job running if not #f
+	   (let ((color (get-user-color u)))
+	     (ezx-fillrect-2d *ezx* (+ x 2)(+ 2 y)(+ x 9) (+ y 9) color)))))
+   (hash-table-values *cpus*))
+  (ezx-redraw *ezx*))
+
+(define (end-job cpu-name user)
+  (let ((cpu (hash-table-ref/default *cpus* cpu-name #f)))
+    (if cpu
+	(let ((curr-user (cpu:dat-get-user cpu))) ;; if it is a user name then job is not done - error
+	  (if (or (not curr-user)
+		  (not (equal? curr-user user)))
+	      (print "ERROR: cpu " cpu-name " not running job for " user "!")
+	      (begin
+		(cpu:dat-set-user!    cpu #f)
+		(cpu:dat-set-job-len! cpu #f)
+		(draw-jobs)))) ;; hash-table-set! *cpus* cpu-name (make-cpu:dat))))
+	(print "ERROR: no cpu " cpu-name " found. Ensure it is registered before addressing it."))))
+
+(define (run-job cpu-name job)
+  (let* ((user    (queue:job-get-user     job))
+	 (job-len (queue:job-get-duration job))
+	 (cpu     (hash-table-ref/default *cpus* cpu-name #f)))
+    (if cpu
+	(let ((curr-user (cpu:dat-get-user cpu))) ;; if it is a user name then job is not done - error
+	  (if curr-user
+	      (begin
+		(print "ERROR: cpu already busy! Adding more jobs not supported yet. " cpu-name)
+		#f)
+	      (begin
+		(cpu:dat-set-user!    cpu user)
+		(cpu:dat-set-job-len! cpu job-len)
+		(draw-jobs)
+		(hash-table-set! *cpus* cpu-name cpu)
+		(event (+ *now* job-len) (lambda ()(end-job cpu-name user)))
+		#t)))
+	#f)))
+    
+(define (get-cpu)
+  (let ((all-cpus (hash-table-keys *cpus*)))
+    (if (null? all-cpus) 
+	#f
+	(let loop ((hed (car all-cpus))
+		   (tal (cdr all-cpus)))
+	  (if (cpu:dat-get-user (hash-table-ref/default *cpus* hed '(#f #f))) ;; if user is #f then cpu is available
+	      (if (null? tal)
+		  #f
+		  (loop (car tal)(cdr tal)))
+	      hed)))))
+  
+;;======================================================================
+;; Animation
+;;======================================================================
+
+;; make-vector-record  queue spec x y delta-y height length
+(define (make-queue:spec)(make-vector 5))
+(define-inline (queue:spec-get-x         vec)    (vector-ref  vec 0))
+(define-inline (queue:spec-get-y         vec)    (vector-ref  vec 1))
+(define-inline (queue:spec-get-delta-y   vec)    (vector-ref  vec 2))
+(define-inline (queue:spec-get-height    vec)    (vector-ref  vec 3))
+(define-inline (queue:spec-get-length    vec)    (vector-ref  vec 4))
+(define-inline (queue:spec-set-x!        vec val)(vector-set! vec 0 val))
+(define-inline (queue:spec-set-y!        vec val)(vector-set! vec 1 val))
+(define-inline (queue:spec-set-delta-y!  vec val)(vector-set! vec 2 val))
+(define-inline (queue:spec-set-height!   vec val)(vector-set! vec 3 val))
+(define-inline (queue:spec-set-length!   vec val)(vector-set! vec 4 val))
+
+;; queues are drawn on layer 3 but boxes (jobs) are drawn on the numbered layer
+;;
+(define (draw-queues)
+  (let* ((text-offset 3)
+	 (queue-names (sort (hash-table-keys *queues*) string>=?))
+	 (start-x (vector-ref *queue-spec* 0))
+	 (text-x  (+ start-x text-offset))
+	 (delta-y (vector-ref *queue-spec* 1))
+	 (delta-x (vector-ref *queue-spec* 2))
+	 (height  (vector-ref *queue-spec* 3))
+	 (length  (vector-ref *queue-spec* 4))
+	 (end-x   (+ start-x length)))
+    (ezx-select-layer *ezx* 3)
+    (ezx-wipe-layer   *ezx* 3)
+    (let loop ((y       (vector-ref *queue-spec* 1))
+	       (qname   (car queue-names))
+	       (tail    (cdr queue-names))
+	       (layer   4))
+      (print "Drawing queue at x=" start-x ", y=" y)
+      (ezx-fillrect-2d  *ezx* start-x y end-x (+ y height) *brown*)
+      (ezx-str-2d       *ezx* text-x (- (+ y height) text-offset) qname *white*)
+      (hash-table-set! *obj-locations* qname (list start-x y layer))
+      (if (not (null? tail))
+	  (loop (+ y height delta-y)
+		(car tail)
+		(cdr tail)
+		(+  layer 1))))
+    (ezx-redraw *ezx*)))
+
+;; compress queue data to (vector user count) list
+;;
+(define (draw-queue-compress-queue-data queue-dat)
+  (let loop ((hed  (car queue-dat))
+	     (tal  (cdr queue-dat))
+	     (curr #f) ;; (vector name count)
+	     (res  '()))
+    (let ((user (queue:job-get-user hed)))
+      (cond
+       ((not curr) ;; first time through only?
+	(if (null? tal)
+	    (append res (list (vector user 1)))
+	    (loop (car tal)(cdr tal)(vector user 1) res)))
+       ((equal? (vector-ref curr 0) user) 
+	(vector-set! curr 1 (+ (vector-ref curr 1) 1))
+	(if (null? tal)
+	    (append res (list curr))
+	    (loop (car tal)(cdr tal) curr res)))
+       (else ;; names are different, add curr to queue and create new curr
+	(let ((newcurr (vector user 1)))
+	  (if (null? tal)
+	      (append res (list newcurr))
+	      (loop (car tal)(cdr tal) newcurr (append res (list curr))))))))))
+
+;; draw jobs for a given queue
+;;
+(define (draw-queue-jobs queue-name)
+  (let* ((queue-dat (hash-table-ref/default *queues*        queue-name #f))  ;; list of jobs in the queue
+	 (obj-spec  (hash-table-ref/default *obj-locations* queue-name #f)))  ;; x, y etc. of the drawn queue
+    (if obj-spec
+	(let ((origin-x  (list-ref obj-spec 0))
+	      (origin-y  (list-ref obj-spec 1))
+	      (bar-width 10)
+	      (queue-len (queue:spec-get-length *queue-spec*))
+	      (layer     (list-ref obj-spec 2)))
+	  (ezx-select-layer *ezx* layer)
+	  (ezx-wipe-layer   *ezx* layer)
+	  (if (not (null? queue-dat))
+	      (let ((res (draw-queue-compress-queue-data queue-dat)))
+		(if (not (null? res))
+		    (let loop ((hed (car res))
+			       (tal (cdr res))
+			       (x2   (+ origin-x queue-len)))
+		      (let* ((user (vector-ref hed 0))
+			     (h    (let ((numjobs (vector-ref hed 1)))
+				     (if *use-log*
+					 (inexact->exact (round (log (+ 1 (* *job-log-scale* numjobs)))))
+					 numjobs)))
+			     (x1   (- x2  bar-width))
+			     (y2   (- origin-y h)))
+			(print "x1 " x1 ", origin-y " origin-y ", x2 " x2 ", y2 " y2)
+			(ezx-fillrect-2d *ezx* x1 y2 x2 origin-y (get-user-color user))
+			(if (not (null? tal))
+			    (loop (car tal)(cdr tal) x1)))))
+		(ezx-redraw *ezx*)))))))
+	  
+
+
+;; (let* ((args  (argv))
+;;        (fname (if (> (length args) 1)
+;; 		  (cadr args)
+;; 		  "default.scm")))
+
+(load "default.scm")

ADDED   batchsim/default.scm
Index: batchsim/default.scm
==================================================================
--- /dev/null
+++ batchsim/default.scm
@@ -0,0 +1,107 @@
+;; run sim for four hours
+;;
+(define *end-time* (* 60 40))
+
+;; create the cpus
+;;
+(let loop ((count 200))
+  (add-cpu (conc "cpu_" count) 1 1)
+  (if (>= count 0)(loop (- count 1))))
+
+(draw-cpus)
+
+;; init the queues
+;;
+(hash-table-set! *queues* "normal" '())
+(hash-table-set! *queues* "quick"  '())
+(draw-queues)
+
+;; user k adds 200 jobs at time zero
+;;
+(event *start-time*
+       (lambda ()
+	 (let loop ((count 300)) ;; add 500 jobs
+	   (add-job "normal" "k" 600 1 1)
+	   (if (>= count 0)(loop (- count 1))))))
+
+;; one minute in user m runs ten jobs
+;;
+(event (+ 600 *start-time*)
+       (lambda ()
+	 (let loop ((count 300)) ;; add 100 jobs
+	   (add-job "normal" "m" 600 1 1)
+	   (if (> count 0)(loop (- count 1))))))
+
+;; every minute user j runs ten jobs
+;;
+(define *user-j-jobs* 500)
+(event (+ 600 *start-time*)
+       (lambda ()
+	 (let f ()
+	   (schedule 60)
+	   (if (> *user-j-jobs* 0)
+	       (begin
+		 (let loop ((count 10)) ;; add 100 jobs
+		   (add-job "quick" "j" 600 1 1)
+		   (if (> count 0)(loop (- count 1))))
+		 (set! *user-j-jobs* (- *user-j-jobs* 10))))
+	   (if (and (not *done*)
+		    (> *user-j-jobs* 0))
+	       (f))))) ;; Megatest user running 200 jobs
+;; ;;
+;; (event *start-time*
+;;        (lambda ()
+;; 	 (let f ((count 200))
+;; 	   (schedule 10)
+;; 	   (add-job "normal" "t" 60 1 1)
+;; 	   (if (and (not *done*)
+;; 		    (>= count 0))
+;; 	       (f (- count 1))))))
+
+;; every 3 seconds check for available machines and launch a job
+;;
+(event *start-time*
+       (lambda ()
+	 (let f ()
+	   (schedule 3)
+	   (let ((queue-names (hash-table-keys *queues*)))
+	     (let loop ((cpu   (get-cpu))
+			(count (+ (length queue-names) 4))
+			(qname (car queue-names))
+			(remq  (cdr queue-names)))
+	       (if (and cpu
+			(> count 0))
+		   (begin
+		     (if (peek-job qname) ;; any jobs to do in normal queue
+			 (let ((job (take-job qname)))
+			   (run-job cpu job)))
+		     (loop (get-cpu)
+			   (- count 1)
+			   (if (null? remq)
+			       (car queue-names)
+			       (car remq))
+			   (if (null? remq)
+			       (cdr queue-names)
+			       (cdr remq)))))))
+	   (if (not *done*)(f)))))
+
+;; screen updates
+;;
+(event *start-time* (lambda ()
+		      (let f ()
+			(schedule 60) ;; update the screen every 60 seconds of sim time
+			(draw-cpus) ;; (print "Now: " *now* " queue: " (hash-table->alist *queues*))
+			(wait-for-next-draw-time)
+			(if (not *done*) (f)))))
+
+
+;; end the simulation
+;;
+(event *end-time*
+       (lambda () 
+	 (set! *event-list* '())
+	 (set! *done* #t)))
+
+(start)
+;; (exit 0)
+

ADDED   batchsim/events.scm
Index: batchsim/events.scm
==================================================================
--- /dev/null
+++ batchsim/events.scm
@@ -0,0 +1,74 @@
+
+;;======================================================================
+;; 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")))