;;; -*- Mode:LISP; Package:TV; Readtable:CL; Base:10 -*-

(defun setup-landscape-with-guages ()
  (generate-gc-guages)
  (setup-guage-configuration)
  (start-guage-process))

(defun make-cheap-averager (averaging-factor)
  (let ((last-value 0)
	(inverse-factor (- 1 averaging-factor)))
    #'(lambda (next-value)
	(setq last-value (+ (* averaging-factor last-value)
			    (* inverse-factor   next-value)))
	last-value)))

(defvar *disk-average-value* .8)

(defun make-disk-usage-meter-function ()
  (let ((averager  (make-cheap-averager *disk-average-value*))
	(last-time (time:fixnum-microsecond-time))
	(last-disk-time (logand (read-meter 'sys:%disk-wait-time) (- (expt 2 24) 1))))
    #'(lambda ()
	(let ((now       (time:fixnum-microsecond-time))
	      (this-wait (logand (read-meter 'sys:%disk-wait-time) (- (expt 2 24) 1))))
	  (prog1 (funcall averager (* 100. (/ (time:time-difference this-wait last-disk-time)
					      (time:time-difference now last-time))))
		 (setq last-time now
		       last-disk-time this-wait))))))

(defun total-processor-utilization (&aux (total 0))
  (without-interrupts
    (dolist (ape si:active-processes)
      (when (car ape)
	(incf total (send (car ape) :percent-utilization)))))
  (values (round total)))

(defvar *utilization-guage*
	(make-instance 'probe-map-guage
		       :superior         *control-panel*
		       :label            "Utilization"
		       :mapping-function #'percent->guage
		       :probe-function   #'total-processor-utilization))

(defvar *disk-guage* 
	(make-instance 'probe-map-guage
		       :superior         *control-panel*
		       :label            "Disk"
		       :mapping-function #'percent->guage
		       :probe-function   (make-disk-usage-meter-function)))

(defvar *big-guage-list* (list *disk-guage* *utilization-guage*))

(defconstant *number-of-volatility-levels* 4)
(defconstant *gc-guages* (make-array *number-of-volatility-levels*))

(defun gc-probe (level)
  #'(lambda ()
      (let ((lc (aref gc:*level-control* level))
	    (sdb (if (and (boundp 'gc:*gc-process*)
			  gc:*gc-process*
			  (send gc:*gc-process* :run-reasons))
		     gc:*most-recent-storage-distribution-block*  ;; try to avoid costly gc computations.
		     (gc:compute-storage-distribution))))
	(cond ((numberp lc) (/ (aref sdb level)(float lc)))
	      ((null lc)    (/ (gc:committed-free-space level :batch       sdb)
			       (float si:virtual-memory-size)))
	      (t            (/ (gc:committed-free-space level :incremental sdb) (aref sdb 5)))))))

(defun generate-gc-guages ()
  (dotimes (v *number-of-volatility-levels*)
    (setf (aref *gc-guages* v)
		(make-instance 'probe-map-guage
			       :superior         tv:*control-panel*
			       :mapping-function #'fraction->guage
			       :label            (format nil "Vol ~D" v)
			       :probe-function   (gc-probe v)))))

(defun setup-guage-configuration ()
  ;; stack the guages from bottom up
  (multiple-value-bind (left ignore right bottom) (send tv:*control-panel* :inside-edges)
    (let ((big-guage-size (- right left)))
      (do ((big-guages *big-guage-list* (cdr big-guages))
	   (bottom bottom top)
	   (top (- bottom big-guage-size) (- top big-guage-size)))
	  ((null big-guages)
	   (let ((middle (truncate big-guage-size 2)))
	     (do ((v 0 (1+ v))
		  (flag nil (not flag)) ;T if going to next layer
		  (layer-bottom bottom      (if flag layer-top layer-bottom))
		  (layer-top (- bottom middle) (if flag (- layer-top middle) layer-top)))
		 ((= v *number-of-volatility-levels*) '())
	       (let ((this-guage (aref *gc-guages* v)))
		 (send this-guage :activate)
		 (send this-guage :expose)
		 (send this-guage :set-edges (if flag left middle) layer-top
					     (if flag middle right) layer-bottom)
		 ))))
	(let ((this-guage (first big-guages)))
	  (send this-guage :activate)
	  (send this-guage :expose)
	  (send this-guage :set-edges left top right bottom)
	  )))))

(defvar *guage-process* (make-process "Guages" :arrest-reasons '(:guages-off)))
(defvar *guage-process-sleep-time* 2.)

(defun guage-process ()
  (do-forever
    (sleep *guage-process-sleep-time*)
    (send *disk-guage* :update)
    (send *utilization-guage* :update)
    (dotimes (v *number-of-volatility-levels*)
      (send (aref *gc-guages* v) :update))))

(defun start-guage-process ()
  (send *guage-process* :preset 'guage-process)
  (send *guage-process* :reset)
  (send *guage-process* :run-reason :enable)
  (send *guage-process* :revoke-arrest-reason :guages-off))