;;; -*- Mode: LISP; Syntax: Common-lisp; Package: USER; Base: 10 -*-

;;;; Wholine hacks

;=====================================
(SYSTEM-INTERNALS:BEGIN-PATCH-SECTION)
(SYSTEM-INTERNALS:PATCH-SECTION-ATTRIBUTES
  "-*- Mode: LISP; Syntax: Common-Lisp; Package: TV; Base: 8 -*-")

;;>> Separate function because of compiler BD
(defun tv::who-line-thermometer-updater (window)
  (let ((last-update-time 0)
	(mercury 0)
	(incremental -1) (immediate -1)
	;;>> Don't bother with these -- gc progress notes already give me this info
	;(min-scavenge -1) (max-scavenge -1)
	)
    (lambda ()
      (when (time-elapsed-p 600. last-update-time)	;Update at most every ten seconds
	(setq last-update-time (time:time))	;si:gc-get-space-sizes is EXPENSIVE!
       (multiple-value-bind (dynamic static free old)
	  (si:gc-get-space-sizes)
	(declare (ignore static))
	(let* ((sheet-height (tv:sheet-inside-height window))
	       (sheet-width (tv:sheet-inside-width window))
	       (total (+ dynamic free old))
	       (scale (/ (lisp:float total 0s0) sheet-width)))
	  (multiple-value-bind (rectangle-offset rectangle-height)
	      (cond (( sheet-height 1) (values 0 1))
		    (( sheet-height 4) (values 1 2))
		    (( sheet-height 6) (values 2 3))
		    (t (values 2 (- sheet-height 4))))
	    ;;>> Have to use macrolet instead of labels
	    ;;>>  because of a compiler bug which made
	    ;;>>  downward closures within a non-downward closure
	    ;;>>  always cons an environment  (on every clock tick)
	    ;;>> BARF!
	    (macrolet ((scale (n)
			 `(max (min (round ,n scale) sheet-width) 0))
		       (rectangle (x width)
			 `(send window :draw-rectangle ,width rectangle-height
			                               ,x rectangle-offset
						       lisp:boole-xor))
		       (tic (old new)
			 (once-only (new)
			   `(progn
			      (when ( ,old ,new)
				(when ( ,old 0) (rectangle ,old 1))
				(when ( ,new 0) (rectangle ,new 1))
				(setq ,old ,new))))))
	      (let ((old mercury)
		    (new (scale (- total free))))
		(setq mercury new)
		;; Draw 100% tic mark for reference
		(when ( old 0) (rectangle (1- sheet-width) 1))
		(when ( new old) (rectangle (min new old) (abs (- new old)))))
	      (if (or si:%gc-flip-ready
		      (not (zerop (si::ephemeral-oldspace-level-mask))))	;ephemeral flip
		  (multiple-value-bind (committed ignore immediate-committed)
		      (si:gc-get-committed-free-space)
		    (tic incremental (scale (- total committed)))
		    (tic immediate (scale (- total immediate-committed)))
;		    (tic min-scavenge -1)
;		    (tic max-scavenge -1)
		    )
		  (multiple-value-bind (committed ignore ignore)
		      (si:gc-get-committed-free-space)
		    ;; keep indicating this mark while dynamic flipping -- it is interesting
		    (tic incremental (scale (- total committed)))
		    (tic immediate -1))
;		  (multiple-value-bind (work uncertainty)
;		      (si:get-max-gc-work-remaining)
;		    (setq incremental (tic incremental -1)
;			  immediate (tic immediate -1))
;		    (if (or (= work 0) (= work uncertainty))
;		        (setq min-scavenge (tic min-scavenge -1)
;			      max-scavenge (tic max-scavenge -1))
;		        (setq min-scavenge (tic min-scavenge (scale (- total
;								       (- work uncertainty))))
;			      max-scavenge (tic max-scavenge (scale (- total work))))))
		  )))))))))

(defun tv::who-line-thermometer (window state extra-state)
  (declare (ignore extra-state))
  (when (typep window 'tv:who-line-mixin)
    ;; For debugging
    (lisp:setf (scl:symbol-value-in-instance window 'tv:name)
	       "Wholine GC Thermometer"))
  (unless (lisp:typep state 'sys:lexical-closure)
    (setq state (tv::who-line-thermometer-updater window))
    (send window :clear-window))
  (funcall state)
  (values state nil))

;;; This attempts to tell me how much of the machine the current process is getting
;;;  (ie how much I am competing with any background processes)
D,#TD1PsT[Begin using 006 escapes](1 0 (NIL 0) (NIL :BOLD NIL) "CPTFONTCB")(si:allow-redefinition 'tv:who-line-run-state)
0(defun tv:who-line-run-state (window state extra-state)
1  (unless (and (lisp:consp state)
	       (lisp:integerp (car state))
	       (stringp (cdr state)))
    (setq state (cons-in-area 0 "" tv:who-line-area))
    (send window :clear-window))
  (let* ((process (or (tv:who-line-screen-last-process (tv:sheet-screen window))))
	 (percent (cond ((not (lisp:typep process 'si:process))
			 0)
			((not (eq (process:process-state process) 'process::runnable))
			 0)
			(t
0			  1(round (*0 1(process::percent-utilization process)
				    0.01s0
				    (tv:sheet-inside-height window)))0)))
1	 (string 0(if (eq window tv:who-line-run-state-sheet)
		     tv:who-line-run-state
		     (or extra-state ""))1))
;    ;; >> 100% isn't very interesting
;    (if ( percent (1- (tv:sheet-inside-height window))) (setq percent 0))
    (unless (= (car state) percent)
      (send window :draw-rectangle
	           1 (abs (- percent (car state)))
		   0 (- (tv:sheet-inside-height window) (max percent (car state)))
		   lisp:boole-xor))
0    (unless (eq (cdr state) string)
      (tv:prepare-sheet (window)
1	(send window :set-cursorpos 1 0 :pixel)
0	(send window :clear-rest-of-window)
	(send window :string-out string)))
1    (lisp:setf (car state) percent
	       (cdr state) string)
    (values state string))0)


;;>> Isn't this so GENERIC and MODULAR??
;;>>  (I guess it needs the new GENERIC SUBSTRATE MODULARITY INTERFACE SYSTEM!)

;=====================================
(SYSTEM-INTERNALS:BEGIN-PATCH-SECTION)
(SYSTEM-INTERNALS:PATCH-SECTION-SOURCE-FILE "SYS:WINDOW;WHOLIN.LISP.359") ; 8.1
(SYSTEM-INTERNALS:PATCH-SECTION-ATTRIBUTES
  "-*- Syntax: Zetalisp; Mode: LISP; Package: TV; Base: 10; Lowercase: Yes -*-")

1(si:allow-redefinition 'tv:default-construct-who-line-template 'defun)
0(defun tv:default-construct-who-line-template (device-type &optional max-width)
  (let ((template nil)
	(pixel-row 0))
    (flet ((style-size (style)
	     (declare (values width height))
	     (let ((font (si:get-font device-type si:*standard-character-set* style)))
	       (values (let ((cwt (tv:font-char-width-table font)))
			 (if cwt
			     ;; Average looks better for variable-width
			     ;; fonts, even if not 100% accurate 
			     (loop for width being the array-elements of cwt
				   when (and width (plusp width))
				     sum width into total-width
				     and count t into nchars
				   finally (return (round total-width nchars)))
			     (tv:font-char-width font)))
		       (tv:font-char-height font))))
	   (add-field (fields)
	     (setf template (nconc template (ncons fields)))))
      ;;
      (multiple-value-bind (default-char-width default-char-height)
	  (style-size tv:*wholine-default-character-style*)
	;;
	(when (eql tv:*note-progress-in-wholine* 't)
	  (add-field
	    `(:progress
	       :top ,pixel-row :left 0 :height ,default-char-height :width :end
	       :function tv:who-line-note-progress))
	  (incf pixel-row (+ 2 default-char-height)))
	;;
	(when (plusp tv:*number-of-wholine-documentation-lines*)
	  (multiple-value-bind (ignore line-height)
	      (style-size tv:*wholine-documentation-character-style*)
	    (let ((height (+ 3 -2 ;;The 3 is for the margin.  See :margin-components.
			     (* (+ 2 line-height) tv:*number-of-wholine-documentation-lines*))))
	      (add-field
		`(:mouse-documentation
		   :top ,pixel-row :left 0
		   :height ,height
		   :width :end
		   :reverse-video-p ,tv:*wholine-documentation-reverse-video-p*
		   :default-character-style ,tv:*wholine-documentation-character-style*
		   :function tv:who-line-documentation-function
		   :margin-components
		   ,(if tv:*wholine-documentation-border-p*
		        tv:*mouse-documentation-line-margin-decoration*
		        tv:*mouse-documentation-line-margin-noborder*)
		   ))
	      (incf pixel-row height))))
	;;
	(let ((column 0)
	      ;; Allow for whichever is larger -- default or file
	      (max-subfield-height (max default-char-height
					(multiple-value-bind (nil line-height)
					    (style-size tv:*wholine-file-state-character-style*)
					  line-height))))
	  (labels ((add-subfield-internal (name width char-width rest)
		     (let ((wid (if (eql width :end) width (* width char-width))))
		       (add-field `(,name :top ,pixel-row :left ,column
				    :height ,max-subfield-height
				    :width ,wid
				    ,@(cl:copy-list rest)))
		       (unless (symbolp wid)
			 (incf column wid))))
		   (add-subfield (name width &rest rest)
		     (add-subfield-internal name width default-char-width rest))
		   (add-subfield-6 (name width &rest args)
		     (when max-width
		       (scl:minf width (zl:// max-width (* default-char-width 6))))
		     (zl:lexpr-funcall #'add-subfield name width args)))
1	    ;;>> Allocate less space to silly user/process field
	    ;;>>  (and thus more to winning progress-notes field)
0	    ;; Try to keep run-state in same place for all clock formats
	    ;; and align things so the run-state and run-bar line up 
	    (cl:ecase tv:*wholine-clock-format*
	      ((:dow-hh-mm-ss)
	       (add-subfield :time (+ 21 (if tv:*wholine-clock-delimiters* 1 0))
			     :function 'tv:wwatch-who-function)
	       (add-subfield-6 :user (+ 1#|0221|#0 1140 (if tv:*wholine-clock-delimiters* -1 0))
			       :function 'tv:who-line-user-or-process))
	      ((:dow-hh-mm-am)
	       (add-subfield :time (+ 20 (if tv:*wholine-clock-delimiters* 1 0))
			     :function 'tv:wwatch-who-function)
	       (add-subfield-6 :user (+ 1#|0231|#0 1150 (if tv:*wholine-clock-delimiters* -1 0))
			       :function 'tv:who-line-user-or-process))
	      ((:month-day-year)
	       (add-subfield :time 19
			     :function 'tv:nwatch-who-function)
	       (add-subfield-6 :user 1#|0241|#0 116
0			       :function 'tv:who-line-user-or-process)))
	    (add-subfield-6 :package 17 :function 'tv:who-line-package :align :right)
	    (add-subfield-6 :run-state 28 :function 'tv:who-line-run-state :align :left)
	    (add-subfield :file-state :end
			  :default-character-style tv:*wholine-file-state-character-style*
			  :flavor 'tv:who-line-file-sheet)
	    (incf pixel-row max-subfield-height)))
1	(let ((w (1- (lisp:getf (cdr (assoc :user template)) :left))))
	  (add-field `(:gc-thermometer :top ,pixel-row :left 0 :height 3 :width ,w
				       :function who-line-thermometer))
0	  (add-field `(:run-line :top ,pixel-row :left 1,w0 :height 3 :width :end))1)
0	(incf pixel-row 3)))
    template))

;; Gee!  Wasn't changing the wholine a small amount so simple and convenient?