;;; -*- Mode:Common-Lisp; Package:TV; Fonts:(CPTFONT HL10B HL12BI HL12B CPTFONTB); Base:8Ï1; Ï*Patch-File:T -*-

;Ï1;;                     RESTRICTED RIGHTS LEGEND          Ï*
;Ï1;; Use, duplication, or disclosure by the Government is subject toÏ*
;Ï1;; restrictions as set forth in subdivision (b)(3)(ii) of the Rights inÏ*
;Ï1;; Technical Data and Computer Software clause at 52.227-7013.Ï*
;Ï1;;                   TEXAS INSTRUMENTS INCORPORATED.Ï*
;Ï1;;                            P.O. BOX 149149Ï*
;Ï1;;                         AUSTIN, TEXAS 78714-9149Ï*
;Ï1;;                             MS 2151Ï*
;Ï1;; Copyright (C) 1984-1989 Texas Instruments Incorporated. All rights reserved.Ï*

;; PEEK -- displays status information about the Lisp Machine
;; 03-14-89 DAB Fixed peek-set-time-cmd  to take return as a valid :prompt-and-read.

;Ï1; This is how long, in 60'ths of a second, to wait between updates of the screen.Ï*
(DEFVAR Ï4*peek-sleep-time*Ï* 170) 

;Ï1; Windows for PEEK.Ï*

(DEFFLAVOR Ï4basic-peekÏ* 
	   ((needs-redisplay nil))
	   (scroll-mouse-mixin
	    borders-mixin
	    scroll-bar-mixin
	    scroll-window-with-typeout full-screen-hack-mixin)
  :settable-instance-variables
  :gettable-instance-variables
  (:default-init-plist 
    :label "Ï3PeekÏ*"
    :truncation nil)
  (:documentation :special-purpose 
		  "Ï3The actual peek window.  This has the capability to display in a PEEK display mode.Ï*"))

(DEFMETHOD Ï4(basic-peek :who-line-documentation-stringÏ*) ()
  "Ï2If over mouse sensitive item get its documentation, else print default string.Ï*"
  (COND ((AND (CONSP tv:current-item)
              (CONSP (CDR tv:current-item)) 
              (GET (CDDR tv:current-item) :documentation)))
	(t '(:mouse-r-2 "Ï3System MenuÏ*"))))

(DEFMETHOD Ï4(basic-peek :name-for-selectionÏ*) ()
  (STRING-APPEND "Ï3Peek: Ï*" (label-string label)))

(DEFUN Ï4peek-mouse-clickÏ* (item leader-to-complement)
  (DECLARE (:self-flavor basic-peek))
  (SETQ needs-redisplay t)
  (SETF (ARRAY-LEADER item (+ scroll-item-leader-offset leader-to-complement))
        (NOT (ARRAY-LEADER item (+ scroll-item-leader-offset leader-to-complement)))))

(DEFFLAVOR Ï4dynamic-highlighting-command-menu-paneÏ* ()
	   (w:menu)
  (:default-init-plist
    :highlighting nil
    :scrolling-p nil
    :command-menu t
    :dynamic t))


(DEFFLAVOR Ï4peek-frameÏ*
	   ((peek-pane nil)	   ;Ï1; These variables can be used in the commands toÏ*
	    (typeout-pane nil)	   ;Ï1; access the respective panes.Ï*
	    (mode-pane nil)
	    (cmds-pane nil))
	   (ucl:command-loop-mixin
	    tv:stream-mixin
	    frame-dont-select-inferiors-with-mouse-mixin
	    bordered-constraint-frame-with-shared-io-buffer)
  :gettable-instance-variables
  :settable-instance-variables
  :inittable-instance-variables
  :special-instance-variables
  (:default-init-plist
    :active-command-tables '(peek-mode-cmd-table peek-cmd-table peek-other-cmd-table)
    :all-command-tables '(peek-mode-cmd-table peek-cmd-table peek-other-cmd-table)
    :menu-panes '((menu ucl-peek-menu)
		  (cmds ucl-peek-cmd-menu))
    :blip-alist '((:menu :handle-menu-input)
		  (:direct-command-entry :handle-direct-command-input)
		  (:mouse-button :peek-handle-blip)
	          (TELNET        :peek-handle-blip)
	          (QSEND         :peek-handle-blip)
	          (EH            :peek-handle-blip)
	          (INSPECT       :peek-handle-blip)
	          (DESCRIBE      :peek-handle-blip)
		  (host:host-status   :peek-handle-blip))       ;Ï1; LS 11/06/86Ï*
    :save-bits :delayed
    :typein-handler nil
    :basic-help '(peek-documentation-cmd)))

(DEFMETHOD Ï4(peek-frame :before :initÏ*) (IGNORE)
  "Ï2Set up the panes and constraints for the frame.Ï*"
  (SETQ io-buffer (tv:make-default-io-buffer))
  (SETQ panes  `((PEEK basic-peek
		   :io-buffer ,io-buffer)
	         (menu dynamic-highlighting-command-menu-pane
		   :font-map ,(LIST fonts:cptfont)
                   :label (:string "Ï3ModesÏ*" :font fonts:hl10b)
		   :item-list nil
		   :io-buffer ,io-buffer)
                 (cmds dynamic-highlighting-command-menu-pane
		   :font-map ,(LIST fonts:cptfont)
                   :label (:string "Ï3CommandsÏ*" :font fonts:hl10b)
		   :item-list nil
		   :io-buffer ,io-buffer)))
  (SETQ constraints `((main . ((PEEK menus)
			      ((menus  :horizontal (2 :lines menu) (menu cmds)
          		        ((cmds :ask :pane-size))
				((menu :even))))
			      ((PEEK :even)))))))

(DEFMETHOD Ï4(peek-frame :after :initÏ*) (IGNORE)
  "Ï2Set up the pane variables, which are used in the defcommands.Ï*"
  (SETQ peek-pane (SEND self :get-pane 'PEEK)
	typeout-pane (SEND peek-pane :typeout-window)
	mode-pane (SEND self :get-pane 'menu)
	cmds-pane (SEND self :get-pane 'cmds))
  (SEND self :select-pane peek-pane)
  (colorize-peek-frame))

(DEFUN  Ï4colorize-peek-frameÏ* ()
  (DECLARE (:self-flavor peek-frame))
  (LET ((menu-pane (SEND self :get-pane 'menu))
	(cmd-pane (SEND self :get-pane 'cmds)))
    (SETF (sheet-background-color menu-pane) w:25%-gray-color)
    (SETF (label-background (SEND menu-pane :label)) w:50%-gray-color)
    (SETF (sheet-background-color cmd-pane) w:25%-gray-color)
    (SETF (label-background (SEND cmd-pane :label)) w:50%-gray-color)))
  

(DEFMETHOD Ï4(peek-frame :before :exposeÏ*) (&rest ignore)
  "Ï2Necessary for the :ask :pane-size constraint for the menu.Ï*"
  (OR exposed-p
      (SEND self :set-configuration 'main)))



(DEFMETHOD Ï4(peek-frame :designate-io-streamsÏ*) ()
  "Ï2Redefine a UCL method to Bind io to the appropriate panes.Ï*"
  (SETQ *terminal-io* typeout-pane
        *standard-output* typeout-pane
        *standard-input* typeout-pane
	*debug-io* typeout-pane))

(DEFMETHOD Ï4(peek-frame :around :loopÏ*) (cont mt ignore)
  "Ï2This is used to put up the first KEYBOARD status message, so the user knows were ready.Ï*"
  (LET* ((kbd-intercepted-characters
	  (REMOVE (ASSOC #\Break kbd-intercepted-characters :test #'EQ)
		  kbd-intercepted-characters)))
    (UNLESS ucl::command-history
      (LET ((ch (tv:read-any *terminal-io*)))
	(SEND *terminal-io* :force-kbd-input ch)))
    (peek-clear-typeout peek-pane)
    (FUNCALL-WITH-MAPPING-TABLE cont mt :loop))) 

(DEFMETHOD Ï4(peek-frame :peek-handle-blipÏ*) ()
  "Ï2Handle special Peek blips.Ï*"
  (LET ((blip ucl::kbd-input))
    (DECLARE (SPECIAL peek-pane))
    (CASE (CAR blip)
      (TELNET (TELNET (CADR blip)))
      (QSEND (QSEND (CADR blip))                      ;Ï1; CHANGED 11/06/86 - LS - GOT RID OF EXTRA @Ï*
             (SEND peek-pane :set-needs-redisplay t)
	     (SEND *standard-output* :make-complete))
      (EH (EH (CADR blip)))
      (INSPECT (INSPECT (CADR blip)))
      (DESCRIBE (DESCRIBE (CADR blip)))
      (host:host-status
       (IF (CADR blip)
	   (host:host-status (CADR blip))
	   (host:host-status)))    ;Ï1; NEW - LS 11/06/86Ï*
      (:mouse-button (BEEP))
      (otherwise
       (FERROR () "Ï3Peek method :peek-handle-blip doesn't know what to do with blip ~A~%Ï*" blip))))) 

(DEFMETHOD Ï4(peek-frame :before :fetch-inputÏ*) ()
  "Ï2Before doing :any-tyi enter a while-no-typein - update-mode loop.Ï*"
  (peek-when-typeout-query-then-clear peek-pane)
  (UNLESS ucl::command-execution-queue
    (LET* ((*terminal-io* (SEND peek-pane :typeout-window))
	   (sleep-time *peek-sleep-time*)
	   (wakeup-time (TIME-DIFFERENCE (TIME) (- sleep-time))))
      (LOOP (peek-timeout peek-pane wakeup-time sleep-time)
	 (WHEN (SEND *terminal-io* :listen)
	   (RETURN t))
	 (SEND peek-pane :redisplay)))))

(DEFMETHOD Ï4(peek-frame :around :handle-key-inputÏ*)
	   (cont mt ignore &optional ignore)
  "Ï2Map uppercase characters to lowercase.Ï*"
  (SETQ ucl:kbd-input (CHAR-DOWNCASE ucl:kbd-input))
  (FUNCALL-WITH-MAPPING-TABLE cont mt :handle-key-input ucl:kbd-input))

(DEFUN Ï4peek-timeoutÏ* (peek-pane wakeup-time sleep-time)
  "Ï2Return when input or timeout.Ï*"
  (WHEN (TIME-LESSP wakeup-time (TIME))
    (SETQ wakeup-time (TIME-DIFFERENCE (TIME) (- sleep-time))))
  (PROCESS-WAIT
    "Ï3Peek timeoutÏ*"
    #'(lambda (wakeup-time stream frame)
	(AND (sheet-exposed-p frame)
	     (OR (TIME-LESSP wakeup-time (TIME))
		 (SEND stream :listen))))
    wakeup-time    
    (SEND peek-pane :typeout-window)
    (SEND peek-pane :superior)))

(DEFUN Ï4peek-wait-for-inputÏ* (typeout-pane)
  "Ï2If there is typeout on top of the peek-pane this prompts the user for clearing it.Ï*"
  (TERPRI typeout-pane)
  (FORMAT typeout-pane "Ï3~& ~AÏ*" *remove-typeout-standard-message*)
  (LET ((CHAR (tv:read-any *terminal-io*)))
    (UNLESS (EQL char #\Space)
      (tv:unread-any char *terminal-io*))))

(DEFUN Ï4peek-clear-typeoutÏ* (peek-pane)
  "Ï2Remove the typeout pane from over the peek pane.Ï*"
  (LET ((typeout-pane (SEND peek-pane :typeout-window)))
    (SEND typeout-pane :make-complete)
    (SEND peek-pane :redisplay)))

(DEFUN Ï4peek-when-typeout-query-then-clearÏ* (peek-pane)
  "Ï2When the typeout window is exposed query the user for clearing it.Ï*"
  (LET ((typeout-pane (SEND peek-pane :typeout-window)))
    (WHEN (SEND typeout-pane :exposed-p)
      (peek-wait-for-input typeout-pane)
      (peek-clear-typeout peek-pane))))
  


;Ï1; Commands for Peek modes.Ï*

(DEFCOMMAND Ï4peek-processes-cmdÏ* ()
  '(:description "Ï3List status of every process -- why waiting, how much run recently.Ï*"
    :names ("Ï3ProcessesÏ*")
    :keys (#\p))
  (DECLARE (SPECIAL ucl-peek-menu peek-pane mode-pane))
  (LET ((menu-item (DOLIST (item ucl-peek-menu)
		     (WHEN (EQ self (THIRD item)) (RETURN item)))))
    (SEND mode-pane :set-highlighted-items (LIST menu-item))
    (SEND peek-pane :set-label "Ï3Peek ProcessesÏ*")
    (SEND peek-pane :set-display-item (peek-processes  nil))
   ))

(DEFCOMMAND Ï4peek-counters-cmdÏ* ()
  '(:description "Ï3Display the values of all the microcode meters.Ï*"
    :names ("Ï3CountersÏ*")
    :keys (#\c #\%))
  (DECLARE (SPECIAL ucl-peek-menu peek-pane mode-pane))
  (LET ((menu-item (DOLIST (item ucl-peek-menu)
		     (WHEN (EQ self (THIRD item)) (RETURN item)))))
    (SEND mode-pane :set-highlighted-items (LIST menu-item))
    (SEND peek-pane :set-label "Ï3Statistic CountersÏ*")
    (SEND peek-pane :set-display-item (peek-counters nil))))

(DEFCOMMAND Ï4peek-areas-cmdÏ* ()
  '(:description "Ï3Display status of areas, including how much memory allocated and used.Ï*"
    :names ("Ï3AreasÏ*")
    :keys (#\a))
  (DECLARE (SPECIAL ucl-peek-menu peek-pane mode-pane))
  (LET ((menu-item (DOLIST (item ucl-peek-menu)
		     (WHEN (EQ self (THIRD item)) (RETURN item)))))
    (SEND mode-pane :set-highlighted-items (LIST menu-item))
    (SEND peek-pane :set-label "Ï3AreasÏ*")
    (SEND peek-pane :set-display-item (peek-areas nil))))



(DEFCOMMAND Ï4peek-file-system-cmdÏ* ()
  '(:description "Ï3Display status of FILE protocol connections to remote file systems.Ï*"
    :names ("Ï3FILE StatusÏ*")
    :keys (#\f))
  (DECLARE (SPECIAL ucl-peek-menu peek-pane mode-pane typeout-pane))
  (IF (FUNCTIONP 'fs::peek-file-system)
      (LET ((menu-item (DOLIST (item ucl-peek-menu)
		         (WHEN (EQ self (THIRD item)) (RETURN item)))))
        (SEND mode-pane :set-highlighted-items (LIST menu-item))
        (SEND peek-pane :set-label "Ï3File System StatusÏ*")
        (SEND peek-pane :set-display-item (fs::peek-file-system nil)))
      (FORMAT typeout-pane "Ï3There is no file system on this computer.~%Ï*")))

(DEFCOMMAND Ï4peek-window-hierarchy-cmdÏ* ()
  '(:description "Ï3Display the hierarchy of window inferiors, saying which are exposed.Ï*"
    :names ("Ï3WindowsÏ*")
    :keys (#\w))
  (DECLARE (SPECIAL ucl-peek-menu peek-pane mode-pane))
  (LET ((menu-item (DOLIST (item ucl-peek-menu)
		     (WHEN (EQ self (THIRD item)) (RETURN item)))))
    (SEND mode-pane :set-highlighted-items (LIST menu-item))
    (SEND peek-pane :set-label "Ï3Window HierarchyÏ*")
    (SEND peek-pane :set-display-item (peek-window-hierarchy nil))))

(DEFCOMMAND Ï4peek-servers-cmdÏ* ()
  '(:description "Ï3List all servers, who they are serving, and their status.Ï*"
    :names ("Ï3ServersÏ*")
    :keys (#\s))
  (DECLARE (SPECIAL ucl-peek-menu peek-pane mode-pane))
  (LET ((menu-item (DOLIST (item ucl-peek-menu)
		     (WHEN (EQ self (THIRD item)) (RETURN item)))))
    (SEND mode-pane :set-highlighted-items (LIST menu-item))
    (SEND peek-pane :set-label "Ï3Active ServersÏ*")
    (SEND peek-pane :set-display-item (net::peek-servers nil))))



;Ï1; Commands for Peek command menu.Ï*

;Ï1; Modified to fit into 604x432 window on MicroExplorer or 688x432 window on ExplorerÏ*
;Ï1; Shortened command name so command window would size correctly - 11/19/87 CATÏ*
(DEFCOMMAND Ï4peek-histo-cmdÏ* ()
  '(:description "Ï3Display a statistical sampling of what functions use the most system resources.Ï*"
    :names ("Ï3HistogramÏ*")
    :keys (#\m)) ;Ï1; M for Meter, because F and H are already taken...Ï*
  (DECLARE (SPECIAL ucl-peek-menu peek-pane mode-pane))
    (IF (FBOUNDP 'meter::peek-histo)
      (LET ((menu-item (DOLIST (item ucl-peek-menu)
                         (WHEN (EQ self (THIRD item)) (RETURN item)))))
        (SEND mode-pane :set-highlighted-items (LIST menu-item))
        (SEND peek-pane :set-label "Ï3Peek FunctionsÏ*")
        (SEND peek-pane :set-display-item (meter::peek-histo nil))
        )
      (BEEP)))

(DEFCOMMAND Ï4peek-host-status-cmdÏ* ()        ;Ï1; LS  11/06/86Ï*
  '(:description "Ï3Print Network statistics of all known hosts.Ï*"
    :names ("Ï3Host StatusÏ*")
    :keys (#\h))
  (DECLARE (SPECIAL typeout-pane peek-pane))
  (LET ((*standard-output* typeout-pane))
    (IF (FUNCTIONP 'host:host-status)
	(host:host-status)
	(FORMAT t "Ï3This computer is not on a network.~&Ï*"))))
    
(DEFCOMMAND Ï4peek-set-time-cmdÏ* ()
  '(:description "Ï3Reset time between updates of the screen in units of 1/60ths of a second.Ï*"
    :names ("Ï3Set TimeoutÏ*")
    :keys (#\t))
  (DECLARE (SPECIAL typeout-pane peek-pane))
  (LET* ((*terminal-io* typeout-pane)
	 (num (UNWIND-PROTECT
		  (PROMPT-AND-READ
		    '(:number :or-nil t)  ;Ï1; DAB 03-14-89 Take return, use default.Ï*
		    "Ï3~%Current timeout in 1/60ths of a second = ~A~%~%Enter new time: Ï*" *peek-sleep-time*)
		(peek-clear-typeout peek-pane))))
    (WHEN num (SETQ *peek-sleep-time* num))))  ;Ï1; DAB 03-14-89Ï*

(DEFCOMMAND Ï4peek-exit-cmdÏ* ()
  '(:description "Ï3Exit the Peek process.Ï*"
    :names ("Ï3ExitÏ*")
    :keys (#\end #\q))
  (DECLARE (SPECIAL peek-pane))
  (deselect-and-maybe-bury-window
    (SEND peek-pane :superior) :first))

(DEFCOMMAND Ï4peek-page-up-cmdÏ* ()
  '(:description "Ï3Display the next page up in the scroll window.Ï*"
    :names ("Ï3Page upÏ*")
    :keys (#\m-v #\c-up-arrow #\rubout))
  (DECLARE (SPECIAL peek-pane))
  (SEND peek-pane :scroll-relative :top :bottom))

(DEFCOMMAND Ï4peek-page-down-cmdÏ* ()
  '(:description "Ï3Display the next page down in the scroll window.Ï*"
    :names ("Ï3Page downÏ*")
    :keys (#\c-v #\c-down-arrow #\space))
  (DECLARE (SPECIAL peek-pane))
  (SEND peek-pane :scroll-relative :bottom :top))

(DEFCOMMAND Ï4peek-network-cmdÏ* ()             ;Ï1; CHANGED NAME -LS  - 11/06/86Ï*
  '(:description "Ï3Display useful information about all network connections & other network info.Ï*"
    :names ("Ï3NetworkÏ*")
    :keys (#\n))
  (DECLARE (SPECIAL ucl-peek-menu peek-pane mode-pane typeout-pane))
  (IF (FUNCTIONP 'net::peek-network)         ;Ï1; USED TO BE CHAOS  -- LSÏ*
      (LET ((menu-item (DOLIST (item ucl-peek-menu)
		         (WHEN (EQ self (THIRD item)) (RETURN item)))))
        (SEND mode-pane :set-highlighted-items (LIST menu-item))
        (SEND peek-pane :set-label "Ï3NetworkÏ*")
        (SEND peek-pane :set-display-item (net::peek-network nil)))    ;Ï1; PUT IN NET PACKAGE  -- LSÏ*
      (FORMAT t "Ï3This computer is not on a network.~%Ï*")))


;Ï1; Modified to fit into 604x432 window on MicroExplorer or 688x432 window on ExplorerÏ*
;Ï1; Shortened a line of text and  changed command name from documentation to help  - 11/19/87 CATÏ*
(DEFCOMMAND Ï4peek-documentation-cmdÏ* ()
  '(:description "Ï3Print out some brief general documentation about Peek.Ï*"
    :names ("Ï3HelpÏ*")
    :keys (#\C-help #\M-help))
  (DECLARE (SPECIAL typeout-pane peek-pane))
  (LET ((*standard-output* typeout-pane))
    (FORMAT t
 "
                                PEEK HELP


PEEK is a utility composed of MODES and COMMANDS.

MODES contain status information about various components of the Explorer 
system.  They are listed at the bottom of the screen and are briefly described 
below.  A MODE can be displayed by highlighting it with the mouse cursor and 
then clicking Mouse-Left or by entering its key assignment.

     *  WINDOWS--Displays the hierarchy of window inferiors, depicting which
                 are exposed.  Key assignment: w

     *  AREAS--Displays status of areas, including how much memory is allocated
               and used.  Key assignment: a

     *  PROCESSES--Lists status of every process.  Key assignment:  p

     *  FILE STATUS--Displays status of file protocol connections to remote file
                     systems.  Key assignment: f

     *  SERVERS--Lists all servers, who they are serving, and their status.
                 Key assignment: s

     *  NETWORK--Displays network connection information.  Key assignment: n

     *  COUNTERS--Displays the value of all microcode meters.  Key assignment: c

     *  FUNCTION HISTOGRAM--Displays most frequently called functions in one or
                           more processes. Key assignment: m
 
COMMANDS are actions that can be performed.  They are listed at the bottom
of the screen in the right-hand corner and are briefly described below.

     *  DOCUMENTATION--Displays this message.  Key assignment: CTRL-HELP

     *  SET TIMEOUT--Reset time between updates of the screen in units of 1/60ths  
                     of a second.  Key assignment: t

     *  HOSTAT--Displays network statistics of all known hosts.  Key assignment: h

     *  EXIT--Exits the Peek utility.  Key assignment:  or q


 ")))

(DEFCOMMAND Ï4peek-break-cmdÏ* ()
  '(:description "Ï3Enter the break read, eval and print loop.Ï*"
    :names ("Ï3BreakÏ*")
    :keys (#\Break))
  (DECLARE (SPECIAL typeout-pane peek-pane))
  (LET ((*terminal-io* typeout-pane))
    (BREAK "Ï3PeekÏ*" t)
    (peek-clear-typeout peek-pane)))



(DEFPARAMETER Ï4peek-modesÏ*
   '(peek-window-hierarchy-cmd
      peek-processes-cmd
      peek-servers-cmd
      peek-counters-cmd
      peek-areas-cmd
      peek-file-system-cmd
      peek-network-cmd
      peek-histo-cmd)) 

(DEFPARAMETER Ï4peek-cmdsÏ*
   '(peek-documentation-cmd
      peek-host-status-cmd   ;Ï1; LSÏ*
      peek-set-time-cmd
      peek-exit-cmd)) 

(DEFPARAMETER Ï4peek-non-menu-cmdsÏ*
              '(peek-page-up-cmd
                 peek-page-down-cmd
                 peek-break-cmd)) 

(BUILD-COMMAND-TABLE 'peek-mode-cmd-table 'peek-frame
  peek-modes
  :init-options
  '(:name "Ï3Peek modesÏ*"))

(BUILD-COMMAND-TABLE 'peek-cmd-table 'peek-frame
  peek-cmds
  :init-options
  '(:name "Ï3Peek commandsÏ*"))

(BUILD-COMMAND-TABLE 'peek-other-cmd-table 'peek-frame
  peek-non-menu-cmds
  :init-options
  '(:name "Ï3Other Peek commandsÏ*"))

(BUILD-MENU 'ucl-peek-menu 'peek-frame
  :default-item-options '(:font fonts:cptfont)
  :item-list-order peek-modes) 

(BUILD-MENU 'ucl-peek-cmd-menu 'peek-frame
  :default-item-options '(:font fonts:cptfont)
  :item-list-order peek-cmds) 

(COMPILE-FLAVOR-METHODS peek-frame basic-peek dynamic-highlighting-command-menu-pane) 


(DEFUN Ï4peekÏ* (&optional initial-mode)
  "Ï2Select a new or old Peek window.  An argument sets the Peek display mode.Ï*"
  (select-or-create-window-of-flavor 'peek-frame)
  (IF initial-mode
    (SEND selected-window :force-kbd-input
       (TYPECASE initial-mode
	 (STRING (AREF initial-mode 0))
	 (:symbol (AREF (SYMBOL-NAME initial-mode) 0))
	 (t initial-mode))))
  (await-window-exposure)) 

;Ï1; Modified to fit into 604x432 window on MicroExplorer or 688x432 window on ExplorerÏ*
;Ï1; Shortened name from 30 to 28, state from 21 to 19 chars, % from 8 to 7 - 11/24/87 CATÏ*
(DEFUN Ï4peek-processesÏ* (peek-pane &rest ignore)
  "Ï2Shows state of all active processes.Ï*"
  (LIST ()
	;Ï1; 30 of process name, 25 of state, 5 of priority, 10 of quantum left/quantum,Ï*
	;Ï1; 8 of percentage, followed by idle time (11 columns)Ï*
	(scroll-parse-item
	 (FORMAT () "Ï3~28A~19A~10A~10A~7A~8AÏ*" "Ï3Process NameÏ*" "Ï3StateÏ*" "Ï3PriorityÏ*" "Ï3QuantumÏ*" "Ï3 %Ï*"
		 "Ï3IdleÏ*"))
	(scroll-parse-item "")
	(scroll-maintain-list #'(lambda ()
				  all-processes)
			      #'(lambda (process)
				  (scroll-parse-item
				   `(:mouse-item
				     (nil :eval (peek-process-menu ',process ',peek-pane 'item 0)
				      :documentation
				      "Ï3Menu of useful things to do to this process.Ï*")
				     :string ,(PROCESS-NAME process) 34)
				   `(:function ,(FUNCTION peek-whostate) ,(CONS process ()) 23)
				   `(:function ,process (:priority) 11 ("Ï3~6D.Ï*"))
				   `(:function ,process (:quantum-remaining) 5 ("Ï3~4D/Ï*"))
				   `(:function ,process (:quantum) 5 ("Ï3~D.Ï*"))
				   `(:function ,process (:percent-utilization) 7
                                               ("Ï3~1,1,4$Ï*"))
				   `(:function ,process (:idle-time) nil
                                               ("Ï3~\\PEEK-PROCESS-IDLE-TIME\\Ï*"))))
			      () ())
	(scroll-parse-item "")
        (scroll-parse-item "Ï3Clock Function ListÏ*")
	(scroll-maintain-list #'(lambda () clock-function-list)
			      #'(lambda (func)
				  (scroll-parse-item
				   `(:string ,(WITH-OUTPUT-TO-STRING (str)
						(PRINC func str)))))))
	  ) 

(DEFPROP Ï4format::peek-process-idle-timeÏ* peek-process-idle-time format::format-ctl-one-arg) 

(DEFUN Ï4peek-process-idle-timeÏ* (arg ignore)
  (COND ((NULL arg) (SEND *standard-output* :string-out "Ï3foreverÏ*"))	;Ï1° character too smallÏ*
	((ZEROP arg))				;Ï1; Not idleÏ*
	((< arg 60.) (FORMAT *standard-output* "Ï3~2D secÏ*" arg))
	((< arg 3600.) (FORMAT *standard-output* "Ï3~2D minÏ*" (TRUNCATE arg 60.)))
	(t (FORMAT *standard-output* "Ï3~2D hrÏ*" (TRUNCATE arg 3600.)))))

(DEFUN Ï4peek-whostateÏ* (process)
  (COND ((si::process-arrest-reasons process) "Ï3ArrestÏ*")
	((si::process-run-reasons process) (PROCESS-WHOSTATE process))
	(t "Ï3StopÏ*")))


(DEFUN Ï4peek-countersÏ* (IGNORE)
  "Ï2Statistics countersÏ*"
  (LIST ()
    (scroll-maintain-list #'(lambda () sys:a-memory-counter-block-names)
			  #'(lambda (counter)
			      (scroll-parse-item
				`(:string ,(STRING counter) 35.)
				`(:function read-meter (,counter) nil ("Ï3~@15AÏ*" 10. t)))))))

;Ï1;; MemoryÏ*
;Ï1;; Modified to fit into 604x432 window on MicroExplorer or 688x432 window on ExplorerÏ*
;Ï1;; changed from one line entry to three lines - 11/19/87 CATÏ*
(DEFUN Ï4peek-memory-headerÏ* ()
  (LIST ()
  (scroll-parse-item
      "Ï3Physical memory: Ï*"
      `(:function ,#'(lambda (&aux (val (system-communication-area %sys-com-memory-size)))
		       (SETF (value 0) (TRUNCATE val 2000))
		       val)
		  nil nil (nil 8.))
      `(:value 0 nil ("Ï3 (~DK)Ï*")))
  (scroll-parse-item
      "Ï3Free space:      Ï*"
      `(:function ,#'(lambda (&aux (val (sys::usable-address-space)))
		       (SETF (value 0) (TRUNCATE val 2000))
		       val)
		  nil nil (nil 8.))
      `(:value 0 nil ("Ï3 (~DK)Ï*")))
  (scroll-parse-item
      "Ï3Wired pages:     Ï*"
      `(:function ,#'(lambda ()
		       (MULTIPLE-VALUE-BIND (n-wired-pages n-fixed-wired-pages)
			   (si::count-wired-pages)
			 (SETF (value 0) (- n-wired-pages n-fixed-wired-pages))
			 (SETF (value 1) (TRUNCATE n-wired-pages (TRUNCATE 2000 page-size)))
			 (SETF (value 2) (REM n-wired-pages (TRUNCATE 2000 page-size)))
			 n-fixed-wired-pages))
		  nil nil ("Ï3~DÏ*"))
      `(:value 0 nil ("Ï3+~D Ï*"))
      `(:value 1 nil ("Ï3(~DÏ*"))
      `(:value 2 nil ("Ï3~[~;.25~;.5~;.75~]K)Ï*")))))


;Ï1;; Modified to fit into 604x432 window on MicroExplorer or 688x432 window on ExplorerÏ*
;Ï1;; Shortened area name from 40 to 33 chars, region from 15 to 13 chars - 11/19/87 CATÏ*
(DEFUN Ï4peek-areasÏ* (IGNORE)
  "Ï2AreasÏ*"
  (LIST () (peek-memory-header) (scroll-parse-item "")
	(scroll-maintain-list #'(lambda ()
				  0)
			      #'(lambda (area)
				  (LIST '(:pre-process-function peek-areas-region-display)
					(scroll-parse-item :mouse-self
							   '(nil :eval
							     (peek-mouse-click 'self 0)
							     :documentation
							     "Ï3Insert//remove display of all regions in this area.Ï*")
							   :leader `(nil ,area)
							   `(:function identity (,area) 4
							     ("Ï3~3DÏ*"))
							   `(:string ,(STRING (AREA-NAME area))
							     41)
							   `(:function
							     ,(FUNCTION
							       (lambda (area)
								 (MULTIPLE-VALUE-BIND (LENGTH used n-regions)
								   (si::room-get-area-length-used
								    area)
								   (SETF (value 0) used)
								   (SETF (value 1) length)
								   (SETF (value 2)
									 (COND
									   ((ZEROP length) 0)
									   ((< length 40000)
									    (TRUNCATE
									     (* 144
										(- length used))
									     length))
									   (t
									    (TRUNCATE
									     (- length used)
									     (TRUNCATE length
										       144)))))
								   n-regions)))
							     (,area) 15 ("Ï3(~D region~:P)Ï*"))
							   '(:value 2 nil ("Ï3~@3A% free, Ï*" 12 t))
							   '(:value 0 nil ("Ï3~OÏ*"))
							   '(:value 1 nil ("Ï3/~O usedÏ*")))))
			      ()
			      #'(lambda (state)
				  (PROG (next-one
					 this-one
					 (len (ARRAY-TOTAL-SIZE #'AREA-NAME)))
				    (DO ((i state (1+ i)))
					((>= i len)
					 nil)
				      (COND
					((AND (NULL this-one) (AREF #'AREA-NAME i))
					 (SETQ this-one i))
					((AND this-one (AREF #'AREA-NAME i)) (SETQ next-one i)
					 (RETURN t))))
				    (RETURN (VALUES this-one next-one (NULL next-one)))))))) 

(DEFUN Ï4peek-areas-region-displayÏ* (item)
  "Ï2Handles adding/deleting of the region display when a mouse button is clicked.Ï*"
  (COND
    ((NULL (ARRAY-LEADER (CADR item) scroll-item-leader-offset)))
    ;Ï1; Clicked on this item, need to complement stateÏ*
    ((= (LENGTH item) 2)
     ;Ï1; If aren't displaying regions now, display themÏ*
     (RPLACD (CDR item)
	     (CONS
	      (scroll-maintain-list
	       #'(lambda ()
		   (area-region-list
		    (ARRAY-LEADER (FIRST (tv:scroll-item-component-items item)) (1+ scroll-item-leader-offset))))
	       #'(lambda (region)
		   (scroll-parse-item
		    `(:string
		      ,(FORMAT () "Ï3~d:~6TOrigin #o~O,~25TLength ~D, Ï*" region    ;Ï1 DAB 01-19-89Ï*
			       (si::region-origin-true-value region) (region-length region))
		      47)
		    `(:function ,(FUNCTION region-free-pointer) (,region) 16 ("Ï3Used ~D, Ï*"))
		    `(:function ,(FUNCTION region-gc-pointer) (,region) 14 ("Ï3GC #o~O, Ï*")) ;Ï1 DAB 01-19-89Ï*
		    `(:function
		      ,(FUNCTION
			(lambda (region &aux bits)
			  (SETQ bits (region-bits region))
			  (SETF (value 0)
				(NTH (LDB %%region-space-type bits)
				     '("Ï3FREEÏ*" "Ï3OLDÏ*" "Ï3NEWÏ*" "Ï3NEW1Ï*" "Ï3NEW2Ï*" "Ï3NEW3Ï*" "Ï3NEW4Ï*" "Ï3NEW5Ï*" "Ï3NEW6Ï*"
		                     "Ï3STATICÏ*" "Ï3FIXEDÏ*" "Ï3EX-PDLÏ*" "Ï3COPYÏ*" "Ï3TRAINÏ*" "Ï3TYPE16Ï*" "Ï3TYPE17Ï*")))

			  (SETF (value 1) (LDB %%region-map-bits bits))
			  (SETF (value 2) (LDB %%region-scavenge-enable bits))
			  (SETF (value 3) (SELECT (LDB %%region-usage bits)
					    (%region-usage-active :active)
					    (%region-usage-inactive-1 :inactive-1)
					    (%region-usage-inactive-2 :inactive-2)
					    (%region-usage-inactive-3 :inactive-3)))
			  (SETF (value 4) (LDB %%region-generation bits))
			  (NTH (LDB %%region-representation-type bits)
			       '(LIST struc "Ï3REP=2Ï*" "Ï3REP=3Ï*"))))
		      (,region) 13 ("Ï3Type ~A Ï*"))
		    '(:value 0 12 ("Ï3~A, Ï*")) '(:value 1 nil ("Ï3Map #o~O, Ï*")) ;Ï1 DAB 01-19-89Ï*
				      '(:value 2 nil ("Ï3~[NoScav~;Scav~]Ï*"))
				      '(:value 3 nil ("Ï3 ~o,Ï*"))
				      '(:value 4 nil ("Ï3 Gen ~dÏ*")) ;Ï1 DAB 01-19-89Ï*
				      ))
	       ()
	       #'(lambda (state)
		   (BLOCK ()
		     (RETURN
		      (VALUES state (region-list-thread state)
			      (MINUSP (region-list-thread state)))))))
	      ())))
    (t (RPLACD (CDR item) ())))
  (SETF (ARRAY-LEADER (CADR item) scroll-item-leader-offset) ())) 


(DEFUN Ï4peek-process-menuÏ* ( &rest args)
  (APPLY #'PROCESS-RUN-FUNCTION "Ï3Peek Process MenuÏ*"
         self :peek-process-menu args)) 

(DEFUN Ï4choose-new-priorityÏ* (process)
  (LET ((*print-base* 12)
	(*read-base* 12)
	(*nopoint t)
	(priority (SEND process :priority)))
    (DECLARE (SPECIAL priority))
       (choose-variable-values
	'((priority "Ï3PriorityÏ*" :documentation "Ï3Set priority of processÏ*" :number))
        :label (FORMAT () "Ï3Priority for ~AÏ*" process)
        :margin-choices `(, w::margin-choice-completion-string
			  (, w::margin-choice-abort-string (SIGNAL-CONDITION eh:*abort-object*))))
			  priority))

(DEFUN Ï4choose-new-arrest-reasonÏ* (process)
  (LET ((*print-base* 12)
	(*read-base* 12)
	(*nopoint t)
	(arrest-reason :user))
    (DECLARE (SPECIAL arrest-reason))
       (choose-variable-values
	'((arrest-reason "Ï3Arrest ReasonÏ*" :documentation "Ï3Choose an arrest reasonÏ*" :sexp))
        :label (FORMAT () "Ï3Arrest reason for ~AÏ*" process)
        :margin-choices `(, w::margin-choice-completion-string
			  (, w::margin-choice-abort-string (SIGNAL-CONDITION eh:*abort-object*))))
      arrest-reason)) 

(DEFUN Ï4choose-arrest-reasonÏ* (process &aux chosen-reason)
  (LET ((arrest-reasons (si::process-arrest-reasons process)))
    (WHEN arrest-reasons
      (LET ((alist))
	(DOLIST (reason arrest-reasons)
	  (SETQ alist
		(CONS (CONS reason `(:value ,reason :documentation "Ï3Remove this arrest reason from this process.Ï*"))
		      alist)))
	(SETQ alist (CONS '(all :value :all :documentation "Ï3Remove all arrest reasons from this process.Ï*") alist))
	(SETQ chosen-reason (w:menu-choose alist :label (FORMAT nil "Ï3Select reason to unarrest ~AÏ*" process)))))
    (IF (EQ chosen-reason :all) arrest-reasons chosen-reason)))



(DEFMETHOD Ï4(basic-peek :peek-process-menuÏ*) (process &rest ignore &aux choice)
  "Ï2Menu for interesting operations on processes in a peek displayÏ*"
  (LET ((*terminal-io* typeout-window)
	(choices
	 '(("Ï3DebuggerÏ*" :value process-eh
            :documentation
	    "Ï3Call the debugger to examine the selected process.Ï*")
	   ("Ï3ArrestÏ*" :value process-arrest
            :documentation
	    "Ï3Arrest the selected process.  Undone by Un-Arrest.Ï*")
	   ("Ï3Un-ArrestÏ*" :value process-un-arrest
            :documentation
	    "Ï3Un-Arrest the selected process.  Complement of Arrest.Ï*")
	   ("Ï3FlushÏ*" :value process-flush
            :documentation
	    "Ï3Unwind the selected process' stack and make it unrunnable.  Ask for confirmation.Ï*")
	   ("Ï3ResetÏ*" :value process-reset
            :documentation
	    "Ï3Reset the selected process.  Ask for confirmation.Ï*")
           ("Ï3Reset & EnableÏ*" :value process-reset-enable
            :documentation
            "Ï3Reset and Enable the selected process. Ask for confirmation.Ï*")
	   ("Ï3KillÏ*" :value process-kill
            :documentation
	    "Ï3Kill the selected process.  Ask for confirmation.Ï*")
	   ("Ï3DescribeÏ*" :value process-describe
            :documentation
            "Ï3Call DESCRIBE on this process.Ï*")
	   ("Ï3PriorityÏ*" :value process-priority
            :documentation
	    "Ï3Change priority of the selected process.Ï*")
	   ("Ï3InspectÏ*" :value process-inspect
            :documentation
            "Ï3Call INSPECT on this process.Ï*"))))
 	;Ï1; Don't offer EH for a simple process.Ï*
    (OR (TYPEP (PROCESS-STACK-GROUP process) 'STACK-GROUP) (POP choices))
    (SETQ choice (w:menu-choose choices :label (PROCESS-NAME process) :scrolling-p nil))
    (CASE choice
      (process-arrest
       (LET ((new-reason (choose-new-arrest-reason process)))
	 (IF new-reason
	   (SEND process :arrest-reason new-reason))))
      (process-un-arrest
       (LET ((arrest-reasons (choose-arrest-reason process)))
	 (COND
	   ((NULL arrest-reasons) nil)
	   ((LISTP arrest-reasons)
	    (LOOP for reason in arrest-reasons do (SEND process :revoke-arrest-reason reason)))
	   (t (SEND process :revoke-arrest-reason arrest-reasons)
	   )
	   )))
      (process-flush (IF (mouse-y-or-n-p (FORMAT () "Ï3Flush ~AÏ*" process))
		       (SEND process :flush))
		     )
      (PROCESS-RESET (IF (mouse-y-or-n-p (FORMAT () "Ï3Reset ~AÏ*" process))
		       (SEND process :reset))
		     )
      (process-reset-enable (IF (mouse-y-or-n-p (FORMAT () "Ï3Reset & Enable ~AÏ*" process))
                                (PROCESS-RESET-AND-ENABLE process))
			    )
      (process-kill (IF (mouse-y-or-n-p (FORMAT () "Ï3Kill ~AÏ*" process))
		      (SEND process :kill))
		    )
      (process-eh (SEND self :force-kbd-input `(EH ,process)))
      (process-describe (SEND self :force-kbd-input `(DESCRIBE ,process)))
      (process-priority
       (LET ((new-priority (choose-new-priority process)))
	 (IF new-priority
	   (SEND process :set-priority new-priority))))
      (process-inspect (SEND self :force-kbd-input `(INSPECT ,process)))
      (nil)
      (otherwise (BEEP)))))




(DEFUN Ï4peek-window-hierarchyÏ* (IGNORE)
  (scroll-maintain-list #'(lambda () all-the-screens)
			#'(lambda (screen)
			    (LIST ()
			      (scroll-parse-item (FORMAT nil "Ï3Screen ~AÏ*" screen))
			      (peek-window-inferiors screen 2)
			      (scroll-parse-item "")))))

(DEFUN Ï4peek-window-inferiorsÏ* (window indent)
  (DECLARE (SPECIAL window indent))
  (scroll-maintain-list (CLOSURE '(window) #'(lambda () (sheet-inferiors window)))
			(CLOSURE '(indent)
			  #'(lambda (sheet)
			      (LIST ()
				    (scroll-parse-item 
				      (FORMAT nil "Ï3~V@tÏ*" indent)
				      `(:mouse
					 (nil :eval (peek-window-menu ',sheet)
					      :documentation
					      "Ï3Menu of useful things to do to this window.Ï*")
					 :string
					 ,(STRING (SEND sheet :name))))
				    (peek-window-inferiors sheet (+ indent 4)))))))

(DEFUN Ï4peek-window-menuÏ* (&rest args)
  (APPLY #'PROCESS-RUN-FUNCTION "Ï3Peek Window MenuÏ*"
         self :peek-window-menu args)) 

(DEFMETHOD Ï4(basic-peek :peek-window-menuÏ*) (sheet &rest ignore &aux choice)
  "Ï2Menu for interesting operations on sheets in a peek displayÏ*"
  (SETQ choice
	(w:menu-choose
	 '(("Ï3DeexposeÏ*" :value :deexpose :documentation "Ï3Deexpose the window.Ï*")
	   ("Ï3ExposeÏ*" :value :expose :documentation "Ï3Expose the window.Ï*")
	   ("Ï3SelectÏ*" :value :select :documentation "Ï3Select the window.Ï*")
	   ("Ï3DeselectÏ*" :value :deselect :documentation "Ï3Deselect the window.Ï*")
	   ("Ï3DeactivateÏ*" :value :deactivate :documentation "Ï3Deactivate the window.Ï*")
	   ("Ï3KillÏ*" :value :kill :documentation "Ï3Kill the window.Ï*")
	   ("Ï3BuryÏ*" :value :bury :documentation "Ï3Bury the window.Ï*")
	   ("Ï3DescribeÏ*" :value describe :documentation "Ï3Describe the window.Ï*")
	   ("Ï3InspectÏ*" :value inspect :documentation "Ï3Inspect the window.Ï*"))
	 :label (SEND sheet :name) :scrolling-p nil))
  (AND choice (OR (NEQ choice :kill) (mouse-y-or-n-p (FORMAT () "Ï3Kill ~AÏ*" (SEND sheet :name))))
     (COND
       ((MEMBER choice '(INSPECT describe) :test #'EQ)
	(LET ((*terminal-io* typeout-window))
	  (SEND self :force-kbd-input `(,choice ,sheet))))
       (t (SEND sheet choice)
	  )))) 

;Ï1(tv:remove-system-key #\p)Ï*			Ï1; In case one already exits.Ï*
;Ï1(tv:add-system-key #\p 'tv:peek-frame "Peek - display system activities and their current states." t)Ï*

;Ï1(tv:delete-from-system-menu-column :debug "Peek")Ï*	Ï1; In case one already exists.Ï*
;Ï1(tv:add-to-system-menu-column :debug "Peek" '(SELECT-OR-CREATE-WINDOW-OF-FLAVOR 'TV:PEEK-FRAME)Ï*
;			Ï1      "Display system activities and their current states.")
