(* ;;-*-LISP-*- KEEP EMACS HAPPY ********************************
*
*     STATUS WINDOW
*
*(1) TTY.PROCESS
*(2) Figure out how to make STATE the state of the TTY.PROCESS
*(3) INTERRUPTCHAR fot ^T possibility
*(4) If there is an error, could STATUS-PROCESS automatically
*deactivate a window? 
*(5) # of open files
*(6) RESHAPEING & REPAINTING
*(7) Trim bars not to clip chars.
*(8) Remaining memory indication
*(9) Stack depth
*(10) LOAD, LISTFILES, COMPILE progress indicators
*(11) MAXC & PHYLUM up or down indicators
*(12) MAIL check
*(13) Fix PUT menu command.
****************************************************************)

(RECORD STATUSENTRY (KEY TYPE FETCHFN MIN MAX USERDATA)
	(TYPE? (OR (EQ (STATUSENTRY.TYPE STATUSENTRY) 'READOUT)
		   (AND (EQ (STATUSENTRY.TYPE STATUSENTRY) 'BARGRAPH)
			(NUMBERP (STATUSENTRY.MIN DATUM))
			(NUMBERP (STATUSENTRY.MAX DATUM))
			(GREATERP (STATUSENTRY.MAX DATUM)
				  (STATUSENTRY.MIN DATUM))))))
(DEFDATATYPE STATUSENTRY)


(* ****************************************************************
*
*     STATUS-PROCESS
*
****************************************************************)

(DEFVAR STATUS.QUICKLYMSECSWAIT 2000)
(DEFVAR STATUS.SLOWLYMSECSWAIT 20000)
(DEFVAR STATUS.MSECSWAIT 20000)
(DEFVAR STATUS.WINDOWS)
(DEFEXPR (STATUS-PROCESS)
  (PROG ()
    (DO (FOR WINDOW IN STATUS.WINDOWS
	 DO (STATUS-UPDATE WINDOW))
	(COND ((NOT (NUMBERP STATUS.MSECSWAIT))
	       (* Set STATUS.MSECSWAIT to NIL if you do not want the
		  STATUS-PROCESS to run *)
	       (RETURN))
	      ((NULL STATUS.WINDOWS)
	       (* Probably shouldn't get here, but if we do ... *)
	       (RETURN)))
        (BLOCK STATUS.MSECSWAIT))
))

(DEFEXPR (STATUS-QUICKLY)
  (PROG ()
    (SETQ STATUS.MSECSWAIT STATUS.QUICKLYMSECSWAIT)
    (WAKE.PROCESS 'STATUS-PROCESS)
))

(DEFEXPR (STATUS-SLOWLY)
  (PROG ()
    (SETQ STATUS.MSECSWAIT STATUS.SLOWLYMSECSWAIT)
    (WAKE.PROCESS 'STATUS-PROCESS)
))


(* ****************************************************************
*
*     STATUS-WINDOW IN PARTICULAR
*
****************************************************************)

(DEFEXPR (STATUS-READOUT-STATUSENTRY KEY USERDATA)
  (CREATE STATUSENTRY
	  KEY _ KEY
	  TYPE _ 'READOUT
	  FETCHFN _ (COND (USERDATA (FUNCTION STATUS-GETTOPVAL)))
	  USERDATA _ USERDATA))

(DEFEXPR (STATUS-UNIT-STATUSENTRY KEY USERDATA)
  (CREATE STATUSENTRY
	  KEY _ KEY
	  TYPE _ 'BARGRAPH
	  FETCHFN _ (COND (USERDATA (FUNCTION STATUS-GETTOPVAL)))
	  MIN _ 0.0
	  MAX _ 1.0
	  USERDATA _ USERDATA))

(DEFEXPR (STATUS-GETTOPVAL KEY STATUSENTRY)
  (GETTOPVAL (STATUSENTRY.USERDATA STATUSENTRY)))

(DEFVAR STATUS-DEFAULT-LIST
  (LIST (STATUS-READOUT-STATUSENTRY 'USERNAME)
	(CREATE STATUSENTRY
		KEY _ 'TTY.PROCESS
		TYPE _ 'READOUT
		FETCHFN _ (F/L () (PROCESS.NAME (TTY.PROCESS))))
	(STATUS-READOUT-STATUSENTRY 'STATE 'STATUS.STATE)
	(STATUS-UNIT-STATUSENTRY 'UTIL 'STATUS.UTIL)
	(STATUS-UNIT-STATUSENTRY 'DISKIO 'STATUS.DISKIO)
	(STATUS-UNIT-STATUSENTRY 'GC 'STATUS.GC)
	(STATUS-UNIT-STATUSENTRY 'KEYBOARD 'STATUS.KEYBOARD)
	(STATUS-UNIT-STATUSENTRY 'SWAP 'STATUS.SWAP)))

(DEFVAR STATUS-DEFAULT-FORMS
  '((STATUS-^T)))

(DEFEXPR (STATUS-WINDOW POSITION SEPARATION)
  (PROG (WINDOW)
    (SETQ WINDOW 
	  (STATUS-CREATEW STATUS-DEFAULT-LIST
			  STATUS-DEFAULT-FORMS
			  POSITION
			  SEPARATION))
    (RETURN WINDOW)
))


(* ****************************************************************
*
*     STATUS WINDOWS IN GENERAL
*
****************************************************************)

(DEFEXPR (STATUS-CREATEW LIST FORMS POSITION (OPTIONAL SEPARATION 5))
  (PROG (REGION HEIGHT WIDTH)
    (FOR STATUSENTRY IN LIST
     WHEN (NOT (TYPE? STATUSENTRY STATUSENTRY))
     DO (ERROR "ARG NOT STATUSENTRY" STATUSENTRY))
    (SETQ REGION (CREATE REGION
			 LEFT _ 0
			 BOTTOM _ 0
			 HEIGHT _ 10
			 WIDTH _ 10))
    (SETQ WINDOW (CREATEW REGION NIL NIL T))
    (WINDOWPROP WINDOW 'STATUS.FORMS FORMS)
    (WINDOWPROP WINDOW 'STATUS.LIST LIST)
    (WINDOWPROP WINDOW 'CLOSEFN 'STATUS-DEACTIVATE)
    (WINDOWPROP WINDOW 'BUTTONEVENTFN 'STATUS-BUTTONEVENTFN)
    (STATUS-REPAINTFN WINDOW T POSITION SEPARATION)
    (STATUS-REACTIVATE WINDOW)
    (RETURN WINDOW)))

(DEFEXPR (STATUS-REPAINTFN WINDOW CREATEFLG POSITION SEPARATION)
  (PROG (FONT FONTHEIGHT ALIST TAB HEIGHT WIDTH LEFT BOTTOM REGION)
    (SETQ FONT (DSPFONT NIL WINDOW))
    (SETQ ALIST (WINDOWPROP WINDOW 'STATUS.LIST))
    (SETQ FONTHEIGHT (FONTPROP FONT 'HEIGHT))
    (SETQ HEIGHT (x FONTHEIGHT (LENGTH ALIST)))
    (SETQ HEIGHT (HEIGHTIFWINDOW HEIGHT
				 (WINDOWPROP WINDOW 'TITLE)
				 (WINDOWPROP WINDOW 'BORDER)))
    (COND ((NOT CREATEFLG)
	   (SETQ SEPARATION (WINDOWPROP WINDOW 'STATUS.SEPARATION)))
	  (T (WINDOWPROP WINDOW 'STATUS.SEPARATION SEPARATION)))
    (SETQ TAB
	  (+ (APPLY (FUNCTION IMAX)
		    (FOR STATUSENTRY IN ALIST
		     COLLECT (STRINGWIDTH (STATUSENTRY.KEY STATUSENTRY)
					  FONT)))
	     (x SEPARATION (STRINGWIDTH "A" FONT))))
    (SETQ WIDTH (WIDTHIFWINDOW (x 2 TAB)
			       (WINDOWPROP WINDOW 'BORDER)))
    (COND ((NOT CREATEFLG)
	   (SETQ REGION (WINDOWPROP WINDOW 'REGION))
	   (SETQ LEFT (REGION.LEFT REGION))
	   (SETQ BOTTOM (REGION.BOTTOM REGION)))
	  (T (COND ((NULL POSITION)
		    (SETQ POSITION 
			  (GETBOXPOSITION WIDTH HEIGHT NIL NIL NIL
					  "Position STATUS.WINDOW"))))
	     (SETQ LEFT (POSITION.XCOORD POSITION))
	     (SETQ BOTTOM (POSITION.YCOORD POSITION))))
    (SETQ REGION
	  (CREATE REGION
		  LEFT _ LEFT
		  BOTTOM _ BOTTOM
		  HEIGHT _ HEIGHT
		  WIDTH _ WIDTH))
    (WINDOWPROP WINDOW 'STATUS.FONTHEIGHT FONTHEIGHT)
    (WINDOWPROP WINDOW 'STATUS.TAB TAB)
    (SHAPEW WINDOW REGION)
    (CLEARW WINDOW)
    (FOR STATUSENTRY IN ALIST
     DO (PRINT (STATUSENTRY.KEY STATUSENTRY) WINDOW))
    (STATUS-UPDATE WINDOW)
))

(DEFEXPR (STATUS-UPDATE WINDOW)
  (PROG (FONTHEIGHT TAB ALIST REGION)
    (FOR FORM IN (WINDOWPROP WINDOW 'STATUS.FORMS)
     DO (EVAL FORM))
    (SETQ FONTHEIGHT (WINDOWPROP WINDOW 'STATUS.FONTHEIGHT))
    (SETQ TAB (WINDOWPROP WINDOW 'STATUS.TAB))
    (SETQ ALIST (WINDOWPROP WINDOW 'STATUS.LIST))
    (SETQ REGION (CREATE REGION
			 LEFT _ TAB
			 BOTTOM _ 0
			 HEIGHT _ FONTHEIGHT
			 WIDTH _ TAB))
    (FOR STATUSENTRY IN ALIST
     AS I FROM (1- (LENGTH ALIST)) TO 0 BY -1
     DO (SETF (REGION.BOTTOM REGION)
	      (+ (x I FONTHEIGHT) 
		 (FONTPROP (DSPFONT NIL WINDOW) 'DESCENT)))
     (STATUS-UPDATE-STATUSENTRY STATUSENTRY WINDOW REGION))
))

(DEFEXPR (STATUS-UPDATE-STATUSENTRY STATUSENTRY WINDOW REGION)
  (PROG (KEY TYPE FETCHFN MIN MAX VALUE LENGTH)
    (SETQ KEY (STATUSENTRY.KEY STATUSENTRY))
    (SETQ TYPE (STATUSENTRY.TYPE STATUSENTRY))
    (SETQ FETCHFN (STATUSENTRY.FETCHFN STATUSENTRY))
    (SETQ MIN (STATUSENTRY.MIN STATUSENTRY))
    (SETQ MAX (STATUSENTRY.MAX STATUSENTRY))
    (COND (FETCHFN (SETQ VALUE (APPLY* FETCHFN KEY STATUSENTRY)))
	  (T (SETQ VALUE (GETTOPVAL KEY))))
    (BITBLT NIL NIL NIL
		   WINDOW (REGION.LEFT REGION) (REGION.BOTTOM REGION)
		   (REGION.WIDTH REGION) (REGION.HEIGHT REGION)
		   'TEXTURE 'REPLACE WHITESHADE)
    (COND ((AND (EQ TYPE 'BARGRAPH) (NUMBERP VALUE))
	   (SETQ LENGTH
		 (x$ (/$ (FLOAT VALUE) (-$ (FLOAT MAX) (FLOAT MIN)))
		     (FLOAT (REGION.WIDTH REGION))))
	   (COND ((>=$ LENGTH 0.0)
		  (BITBLT NIL NIL NIL
			  WINDOW (REGION.LEFT REGION)
			  (REGION.BOTTOM REGION)
			  LENGTH (REGION.HEIGHT REGION)
			  'TEXTURE 'PAINT BLACKSHADE))
		 (T (BITBLT NIL NIL NIL
			    WINDOW (+$ (REGION.LEFT REGION) (-$ LENGTH))
			    (REGION.BOTTOM REGION)
			    (-$ LENGTH) (REGION.HEIGHT REGION)
			    'TEXTURE 'PAINT BLACKSHADE))))
	  (T (MOVETO (REGION.LEFT REGION) (REGION.BOTTOM REGION) WINDOW)
	     (PRIN1 VALUE WINDOW)))
))

(DEFEXPR (STATUS-BUTTONEVENTFN WINDOW)
  (PROG ()
    (COND ((LASTMOUSESTATE LEFT)
	   (STATUS-UPDATE WINDOW))
	  ((LASTMOUSESTATE MIDDLE)
	   (STATUS-MIDDLEBUTTONFN WINDOW)))
))

(DEFEXPR (STATUS-MIDDLEBUTTONFN WINDOW)
  (PROG (COMMAND)
    (SETQ COMMAND (MENU STATUS-MENU))
    (COND (COMMAND (APPLY* COMMAND WINDOW)))
))

(DEFVAR STATUS-MENU
  (CREATE MENU
	  ITEMS _ '((Quickly 'STATUS-QUICKLY "Run STATUS quickly")
		    (Slowly 'STATUS-SLOWLY "Run STATUS slowly")
		    (Get 'STATUS-PROMPTGET
			 "Display STATUSENTRY on window")
		    (Put 'STATUS-PROMPTPUT
			 "Add STATUSENTRY to window")
		    (Remove 'STATUS-PROMPTREMOVE
			    "Remove STATUSENTRY from window")
		    (Update 'STATUS-UPDATE "Update window")
		    (Deactivate 'STATUS-DEACTIVATE
				"Cease updating window")
		    (Reactivate 'STATUS-REACTIVATE
				"Resume updating window"))
	  CHANGEOFFSETFLG _ T
	  WHENHELDFN _ 'PPROMPT3))

(DEFEXPR (STATUS-PROMPTGET WINDOW)
  (PROG (STATUSENTRY)
    (FRESHLINE PROMPTWINDOW)
    (SETQ STATUSENTRY 
	  (STATUS-GET WINDOW
		      (MKATOM (PROMPTFORWORD "Get which STATUSENTRY?"
					     NIL NIL PROMPTWINDOW))))
    (FRESHLINE PROMPTWINDOW)
    (PRIN1 STATUSENTRY PROMPTWINDOW)))

(DEFEXPR (STATUS-PROMPTPUT WINDOW)
  (PROG (STATUSENTRY)
    (FRESHLINE PROMPTWINDOW)
    (SETQ STATUSENTRY
	  (PROMPTFORWORD "STATUSENTRY to add?"
			 NIL NIL PROMPTWINDOW))
    (COND ((NOT (TYPE? STATUSENTRY STATUSENTRY))
	   (FRESHLINE PROMPTWINDOW)
	   (PRIN1 STATUSENTRY PROMPTWINDOW)
	   (PRIN1 " not a STATUSENTRY" PROMPTWINDOW))
	  (T (STATUS-PUT WINDOW STATUSENTRY)))
))

(DEFEXPR (STATUS-PROMPTREMOVE WINDOW)
  (PROG (KEY)
    (FRESHLINE PROMPTWINDOW)
    (SETQ KEY (MKATOM (PROMPTFORWORD "Remove which STATUSENTRY?"
				     NIL NIL PROMPTWINDOW)))
    (COND ((NULL (STATUS-GET WINDOW KEY))
	   (FRESHLINE PROMPTWINDOW)
	   (PRIN1 "Can't find " PROMPTWINDOW)
	   (PRIN1 KEY PROMPTWINDOW))
	  (T (STATUE-REM WINDOW KEY)))
))


(* ****************************************************************
*
*     MENU OPERATIONS
*
****************************************************************)

(DEFEXPR (STATUS-REACTIVATE WINDOW)
  (PROG ()
    (COND ((NOT (MEMB WINDOW STATUS.WINDOWS))
	   (PUSH STATUS.WINDOWS WINDOW)))
    (COND ((AND (NUMBERP STATUS.MSECSWAIT)
		(NOT (FIND.PROCESS 'STATUS.PROCESS)))
	   (ADD.PROCESS '(STATUS-PROCESS))))
))

(DEFEXPR (STATUS-DEACTIVATE WINDOW)
  (PROG ()
    (SETQ STATUS.WINDOWS (DREMOVE WINDOW STATUS.WINDOWS))
    (COND ((NULL STATUS.WINDOWS)
	   (DEL.PROCESS 'STATUS-PROCESS)))
))

(DEFEXPR (STATUS-ADD WINDOW STATUSENTRY)
  (PROG (ALIST)
    (COND ((NOT (TYPE? STATUSENTRY STATUSENTRY))
	   (ERROR "ARG NOT STATUSENTRY" STATUSENTRY)))
    (SETQ ALIST (WINDOWPROP WINDOW 'STATUS.LIST))
    (PUTA ALIST (STATUSENTRY.KEY STATUSENTRY) 
	  (CDR STATUSENTRY))
    (WINDOWPROP WINDOW 'STATUS.LIST ALIST)
    (STATUS-REPAINTFN WINDOW)
))

(DEFEXPR (STATUS-REMOVE WINDOW KEY)
  (* Remove statusentry with KEY from WINDOW *)
  (PROG (ALIST ANSWER)
    (SETQ ALIST (WINDOWPROP WINDOW 'STATUS.LIST))
    (SETQ ANSWER
	  (FOR STATUSENTRY IN ALIST
	   THEREIS (EQ (STATUSENTRY.KEY STATUSENTRY) KEY)))
    (SETQ ALIST (DREMOVE ANSWER ALIST))
    (WINDOWPROP WINDOW 'STATUS.LIST ALIST)
    (STATUS-REPAINTFN WINDOW)
    (RETURN ANSWER)
))

(DEFEXPR (STATUS-GET WINDOW KEY)
  (* Current statusentry with KEY in WINDOW*)
  (PROG (ALIST ANSWER)
    (SETQ ALIST (WINDOWPROP WINDOW 'STATUS.LIST))
    (SETQ ANSWER
	  (FOR STATUSENTRY IN ALIST
	   THEREIS (EQ (STATUSENTRY.KEY STATUSENTRY) KEY)))
    (RETURN ANSWER)
))


(* ****************************************************************
*
*     SOME SPECIAL FUNCTIONS
*
****************************************************************)

(BLOCKRECORD MISCSTATS
  ((STARTTIME FIXP)
   (TOTALTIME FIXP)
   (SWAPWAITTIME FIXP)
   (PAGEFAULTS FIXP)
   (SWAPWRITES FIXP)
   (DISKIOTIME FIXP)
   (DISKOPS FIXP)
   (KEYBOARDWAITTIME FIXP)
   (GCTIME FIXP)
   (NETIOTIME FIXP)
   (NETIOOPS FIXP)
   (SWAPTEMP0 FIXP)
   (SWAPTEMP1 FIXP)
   (RCLKSECOND FIXP)
   (SECONDSCLOCK FIXP)
   (MILLISECONDSCLOCK FIXP)
   (BASECLOCK FIXP)
   (RCLKTEMP0 FIXP)
   (SECONDSTMP FIXP)
   (MILLISECONDSTMP FIXP)
   (BASETMP FIXP)
   (EXCESSTIMETMP FIXP)
   (CLOCKTEMP0 FIXP)
   (DISKTEMP0 FIXP)
   (DISKTEMP1 FIXP)
   (TELERAIDTEMP1 FIXP)
   (TELERAIDTEMP2 FIXP)
   (TELERAIDTEMP3 FIXP)
   (LASTUSERACTION FIXP))
  (CREATE (\ALLOCBLOCK 29))) 
(DEFDATATYPE MISCSTATS)

(DEFVAR STATUS.TIMEBOX (CLOCK 0))
(DEFVAR STATUS.KEYBOARDTIME 0)
(DEFVAR STATUS.KEYBOARDWAITTIME 0)
(DEFVAR STATUS.DISKIOTIME 0)
(DEFVAR STATUS.NETIOTIME 0)
(DEFVAR STATUS.GCTIME 0)
(DEFVAR STATUS.SWAPTIME 0)
(DEFVAR STATUS.UTIL 0)
(DEFVAR STATUS.SWAP 0)
(DEFVAR STATUS.DISKIO 0)
(DEFVAR STATUS.NETIO 0)
(DEFVAR STATUS.GC 0)
(DEFVAR STATUS.KEYBOARD 0)
(DEFVAR STATUS.STATE)
(DEFEXPR (STATUS-^T)
   (* UNINTERRUPTABLY *)
     (* Uninterruptable only so that control-t%'s don%'t trash each
	other *)
     (PROG (TEMP STKI 
		 TOTALDELTA UTILDELTA SWAPDELTA NETIODELTA DISKIODELTA
		 GCDELTA KEYBOARDDELTA)
       (SETQ TEMP (STKNTHNAME -3))
       (SETQ STKI -3)
       (SETQ STATUS.STATE NIL)
       (DO (SELECTQ TEMP
	     ((\INTERRUPTFRAME \INTERRUPTED 
			       INTERRUPTED \DOINTERRUPTINTTY)
	      (* Skip over these)
	      (SETQ TEMP (STKNTHNAME (add STKI -1))))
	     ((\GETCHAR \GETKEY)
	      (SETQ TEMP (STKNTHNAME (add STKI -1)))
	      (SETQ STATUS.STATE "IO wait"))
	     ((BLOCK \BACKGROUND AWAIT.EVENT 
		     MONITOR.AWAIT.EVENT 
		     \PROCESS.GO.TO.SLEEP)
	      (* Forms of blocking)
	      (SETQ TEMP (STKNTHNAME (add STKI -1)))
	      (SETQ STATUS.STATE "Waiting"))
	     (COND ((NULL STATUS.STATE)
		    (SETQ STATUS.STATE "Running")
		    (RETURN)))))
       (COND ((NULL STATUS.KEYBOARDTIME)
	      (* Just initialize the first time *)
	      (SETQ STATUS.KEYBOARDTIME 
		    (MISCSTATS.KEYBOARDWAITTIME \MISCSTATS))
	      (SETQ STATUS.TIMEBOX (CLOCK0 STATUS.TIMEBOX))
	      (SETQ STATUS.SWAPTIME (MISCSTATS.SWAPWAITTIME \MISCSTATS))
	      (SETQ STATUS.DISKIOTIME (MISCSTATS.DISKIOTIME \MISCSTATS))
	      (SETQ STATUS.NETIOTIME (MISCSTATS.NETIOTIME \MISCSTATS))
	      (SETQ STATUS.GCTIME (MISCSTATS.GCTIME \MISCSTATS))
	      (RETURN)))
       (* calculates the amount of time
	  spent not in disk wait since the
	  last control-T. Considers only 
	  time outside of key board wait.)
       (SETQ KEYBOARDDELTA
	     (+ (- STATUS.KEYBOARDTIME)
		(SETQ STATUS.KEYBOARDTIME
		      (MISCSTATS.KEYBOARDWAITTIME \MISCSTATS))))
       (SETQ TOTALDELTA
	     (+ (- STATUS.TIMEBOX)
		(SETQ STATUS.TIMEBOX (CLOCK0 
				      STATUS.TIMEBOX))))
       (SETQ SWAPDELTA
	     (+ (- STATUS.SWAPTIME)
		(SETQ STATUS.SWAPTIME
		      (MISCSTATS.SWAPWAITTIME \MISCSTATS))))
       (SETQ DISKIODELTA
	     (+ (- STATUS.DISKIOTIME)
		(SETQ STATUS.DISKIOTIME
		      (MISCSTATS.DISKIOTIME \MISCSTATS))))
       (SETQ NETIODELTA
	     (+ (- STATUS.NETIOTIME)
		(SETQ STATUS.NETIOTIME
		      (MISCSTATS.NETIOTIME \MISCSTATS))))
       (SETQ GCDELTA
	     (+ (- STATUS.GCTIME)
		(SETQ STATUS.GCTIME
		      (MISCSTATS.GCTIME \MISCSTATS))))
       (SETQ UTILDELTA
	     (- TOTALDELTA
		(+ SWAPDELTA DISKIODELTA NETIODELTA GCDELTA)))
       (SETQ STATUS.UTIL (/$ UTILDELTA TOTALDELTA))
       (SETQ STATUS.SWAP (/$ SWAPDELTA TOTALDELTA))
       (SETQ STATUS.DISKIO (/$ DISKIODELTA TOTALDELTA))
       (SETQ STATUS.NETIO (/$ NETIODELTA TOTALDELTA))
       (SETQ STATUS.GC (/$ GCDELTA TOTALDELTA))
       (SETQ STATUS.KEYBOARD (/$ KEYBOARDDELTA TOTALDELTA))
       (* *)
))

STOP