;;; -*- Mode:LISP; Package:LAMBDA; Readtable:ZL; Base:10; Lowercase:T; Fonts:(CPTFONTB) -*-
;;;
;;; (c) Copyright 1986 - Lisp Machine, Inc.
;;;

;;; Youcef. 01/06/86.
;;;
;;; This will provide an window interface for the hardware diagnostics.
;;;


(defflavor big-message-window
	   ()
	   (tv:window)
  (:default-init-plist
    :save-bits t
    :label nil
    :font-map `(,fonts:43vxms)
    :blinker-p nil)
  :GETTABLE-INSTANCE-VARIABLES
  :SETTABLE-INSTANCE-VARIABLES
  :INITTABLE-INSTANCE-VARIABLES)

(defflavor info-window
	   ()
	   (tv:window)
  (:Default-init-plist
    :save-bits t
    :label nil
    :font-map `(,fonts:tr12i fonts:tr12bi fonts:tr10i fonts:tr10bi)
    :blinker-p nil)
  :GETTABLE-INSTANCE-VARIABLES
  :SETTABLE-INSTANCE-VARIABLES
  :INITTABLE-INSTANCE-VARIABLES)

(defmethod (info-window :information-about-path) (path &aux interface)
  (funcall-self :clear-screen)
  (funcall-self :set-cursorpos 0 1 :character)
  (funcall-self :set-current-font fonts:tr12i)
  (format self "~10@THardware interface : ")
  (funcall-self :set-current-font fonts:tr12bi)
  (format self "~A~%" (setq interface (funcall path :interface)))
  (funcall-self :set-current-font fonts:tr12i)
  (selectq interface
    (:BURR-BROWN
     (format self "~10@TMultibus address : ")
     (funcall-self :set-current-font fonts:tr12bi)
     (format self "#X~X~%" (funcall path :multibus-address)))
    (:LMI-DEBUG
     (format self "~10@TBoard in slot : ")
     (funcall-self :set-current-font fonts:tr12bi)
     (format self "~D~%" (funcall path :slot-number)))
    (:SERIAL )
    (:LOCAL )
    )
  (funcall-self :set-current-font fonts:tr12i)
  (format self "~10@TBoard to debug is : ")
  (funcall-self :set-current-font fonts:tr12bi)
  (format self "~A in slot ~D~%" (first (funcall path :board))
	  (second (funcall path :board)))
  )

(defmethod (big-message-window :new-message) (message)
  (or (null message)
      (stringp message)
      (setq message (format nil "~A" message)))
  (funcall-self :clear-screen)
  (and message (funcall-self :string-out-x-y-centered-explicit message))
  )

(defun enable-diag-window ()
  (tv:add-system-key #/delta 'diag-window "Lambda diagnostic frame")
  t)

(defun disable-diag-window ()
  (tv:remove-system-key #/delta)
  t)

(DEFFLAVOR DIAG-WINDOW
	   NIL
	   (tv:select-mixin TV:BORDERED-CONSTRAINT-FRAME-WITH-SHARED-IO-BUFFER)
  (:DEFAULT-INIT-PLIST
    :SAVE-BITS T
    :PANES
    `((INTERACTION-PANE SENSITIVE-LISP-LISTENER
			:DEEXPOSED-TYPEOUT-ACTION :PERMIT
			:LABEL NIL
			:SAVE-BITS T)
      (GRAPHIC-PANE TV:WINDOW
			:BLINKER-P NIL
			:DEEXPOSED-TYPEOUT-ACTION :PERMIT
			:LABEL NIL
			:SAVE-BITS T)
      (MODE-LINE-PANE TV:COMMAND-MENU
		      :LABEL NIL
		      :SAVE-BITS T
		      :REVERSE-VIDEO-P T
		      :ITEM-LIST
		      ,*print-menu*)
      (COMMAND-MENU TV:COMMAND-MENU
		    :LABEL NIL
		    :SAVE-BITS T
		    :ITEM-LIST
		    ,*permanent-menu-items*)
      (CURRENT-TEST-PANE BIG-MESSAGE-WINDOW
			 :BLINKER-P NIL
			 :DEEXPOSED-TYPEOUT-ACTION :PERMIT
			 :LABEL NIL
			 :REVERSE-VIDEO-P T
			 :SAVE-BITS T)
      (PATH-INFO-PANE INFO-WINDOW
		      :BLINKER-P NIL
		      :DEEXPOSED-TYPEOUT-ACTION :PERMIT
		      :LABEL NIL
		      :SAVE-BITS T)
      (TITLE-PANE BIG-MESSAGE-WINDOW
		  :BLINKER-P NIL
		  :REVERSE-VIDEO-P T
		  :DEEXPOSED-TYPEOUT-ACTION :PERMIT
		  :LABEL NIL
		  :SAVE-BITS T)
      (CURRENT-CONFIG BIG-MESSAGE-WINDOW
		  :BLINKER-P NIL
		  :DEEXPOSED-TYPEOUT-ACTION :PERMIT
		  :REVERSE-VIDEO-P T		  
		  :LABEL NIL
		  :SAVE-BITS T)
      (CURRENT-INSTRUCTION-PANE TV:WINDOW
				:BLINKER-P NIL
				:DEEXPOSED-TYPEOUT-ACTION :PERMIT
				:LABEL NIL
				:SAVE-BITS T)
      (COMMANDS-FOR-LAM-PANE TV:COMMAND-MENU
			     :LABEL (:string "LAM commands" :font fonts:tr12bi :centered)
			     :GEOMETRY (2 NIL NIL NIL NIL NIL)
			     :SAVE-BITS T
			     :ITEM-LIST ,*lam-menu-commands*
			     )
      (COMMANDS-FOR-LAM-EXPERIENCED TV:COMMAND-MENU
			     :LABEL nil
			     :FONT-MAP (,fonts:tr8b)
			     :GEOMETRY (4 nil nil nil nil nil)
			     :SAVE-BITS T
			     :ITEM-LIST ,*condensed-lam-menu*
			     ))
    :CONSTRAINTS
    (QUOTE
      ((DATA-PATH-CONFIG
	 (title-pane-dummy command-menu path-info-pane current-test-pane INTERACTION-PANE)
	 ((command-menu 1 :lines))
	 ((title-pane-dummy :horizontal (1 :lines title-pane)
			    (title-pane current-config)
			    ((title-pane :EVEN)
			     (current-config :EVEN))))
	 ((current-test-pane 1 :lines))
	 ((path-info-pane 5 :lines))
	 ((INTERACTION-PANE :EVEN)))
       (DATA-PATH-CONFIG-WITH-GRAPHICS
	 (title-pane-dummy command-menu path-info-pane current-test-pane  INTERACTION-WITH-GRAPHIC-PANE)
	 ((command-menu 1 :lines))
	 ((title-pane-dummy :horizontal (1 :lines title-pane)
			    (title-pane current-config)
			    ((title-pane :EVEN)
			     (current-config :EVEN))))
	 ((current-test-pane 1 :lines))
	 ((path-info-pane 5 :lines))
	 ((INTERACTION-with-graphic-PANE :HORIZONTAL (:EVEN)
					 (graphic-pane interaction-pane)
					 ((graphic-pane :EVEN)
					  (interaction-pane :EVEN)))))
       (LAM-CONFIGURATION-FOR-NOVICE
	 (DUMMY-NAME25)
	 ((DUMMY-NAME25
	    :HORIZONTAL
	    (:EVEN)
	    (DUMMY-NAME31 commands-for-lam-pane)
	    ((DUMMY-NAME31 :VERTICAL
			   (0.75001s0)
			   (TITLE-PANE-dummy COMMAND-MENU PATH-INFO-PANE
				       CURRENT-INSTRUCTION-PANE
				       INTERACTION-PANE)
			   ((TITLE-PANE-dummy :HORIZONTAL (1 :LINES title-pane)
					      (title-pane current-config)
					      ((title-pane :EVEN)
					       (current-config :EVEN)))
			    (command-menu 1 :lines)
			    (PATH-INFO-PANE 5 :LINES)
			    (CURRENT-INSTRUCTION-PANE 7. :LINES))
			   ((INTERACTION-PANE :EVEN))))
	    ((COMMANDS-FOR-LAM-PANE :EVEN)))))
       (LAM-CONFIGURATION
	 (TITLE-PANE-dummy
	   COMMAND-MENU PATH-INFO-PANE-dummy
	   MODE-LINE-PANE
	   CURRENT-INSTRUCTION-PANE
	   INTERACTION-PANE)
	 ((TITLE-PANE-dummy :HORIZONTAL (1 :LINES title-pane)
			    (title-pane current-config)
			    ((title-pane :EVEN)
			     (current-config :EVEN)))
	  (command-menu 1 :lines)
	  (mode-line-pane 2 :lines)
	  (CURRENT-INSTRUCTION-PANE 7. :LINES))
	 ((PATH-INFO-PANE-dummy :HORIZONTAL (5 :LINES PATH-INFO-PANE)
				(PATH-INFO-PANE COMMANDS-FOR-LAM-EXPERIENCED)
				((PATH-INFO-PANE 65 :CHARACTERS))
				((COMMANDS-FOR-LAM-EXPERIENCED :EVEN))))
	 ((INTERACTION-PANE :EVEN)))
       )))
 :GETTABLE-INSTANCE-VARIABLES
 :SETTABLE-INSTANCE-VARIABLES
 :INITTABLE-INSTANCE-VARIABLES)

(DEFMETHOD (diag-window :AFTER :INIT) (&REST IGNORE &aux (io-buffer (tv:make-io-buffer 1000.)))
  (FUNCALL-SELF :SET-SELECTION-SUBSTITUTE (setq *interaction-pane* (funcall-self :get-pane 'interaction-pane)))
  (funcall *interaction-pane* :set-more-p NIL)
  (setq *frame* self)
  (funcall (setq *command-pane* (funcall-self :get-pane 'command-menu))
	   :set-io-buffer io-buffer)
  (funcall (setq *current-config* (funcall-self :get-pane 'current-config))
	   :set-io-buffer io-buffer)
  (funcall (setq *current-test* (funcall-self :get-pane 'current-test-pane))
	   :set-io-buffer io-buffer)
  (funcall (setq *lam-command-menu* (funcall-self :get-pane 'commands-for-lam-pane))
	   :set-io-buffer io-buffer)
  (funcall *lam-command-menu* :set-font-map (list fonts:tr8b))
  (funcall (setq *title-pane* (funcall-self :get-pane 'title-pane))
	   :set-io-buffer io-buffer)
  (funcall (setq *path-info* (funcall-self :get-pane 'path-info-pane))
	   :set-io-buffer io-buffer)
  (funcall *path-info* :set-more-p NIL)
  (funcall (setq *graphic-pane* (funcall-self :get-pane 'graphic-pane))
	   :set-io-buffer io-buffer)
  (funcall (setq *current-instruction-pane* (funcall-self :get-pane 'current-instruction-pane))
	   :set-io-buffer io-buffer)
  (funcall *current-instruction-pane* :set-more-p NIL)
  (funcall *current-instruction-pane* :set-font-map `(,fonts:tr8b))
  (funcall *current-instruction-pane* :set-current-font fonts:tr8b)
  (funcall (setq *lam-command-pane-for-experienced* (funcall-self :get-pane 'commands-for-lam-experienced))
	   :set-io-buffer io-buffer)
  (funcall *lam-command-pane-for-experienced* :set-font-map (list fonts:tr8b))
  (funcall (setq *mode-line-pane* (funcall-self :get-pane 'mode-line-pane))
	   :set-io-buffer io-buffer)
  (funcall *title-pane* :new-message "Diagnostics")
  (funcall *current-test* :new-message "Data paths")
  (funcall *debugger-rack* :get-configuration)
  (setq *menu-choose-window-for-set-up*
	(make-instance 'setup-scroll-window
		       :inside-height 100.
		       :inside-width 770.
		       :left 10. :top 100.
		       :superior self))
  (funcall (funcall-self :get-pane 'current-test-pane) :set-process
	   (process-run-restartable-function "diag process" 'command-loop))
  )

(defun diag-command-loop (&optional (window *frame*) &aux blip item)
  (let ((*standard-output* *interaction-pane*)
	(*debug-io* *interaction-pane*)
	(*query-io* *interaction-pane*)
	(*error-output* *interaction-pane*))
    (pkg-bind 'LAM
      (setq blip (funcall (funcall window :get-pane 'current-test-pane) :any-tyi))
      (when (listp blip)
	(selectq (car blip)
	  (:MENU
	   (cond ((member :funcall (setq item (second blip)))
		  (eval (list (get item :funcall))))
		 ((member :value item)
		  (format t "is not used for now"))
		 ((member :eval item)
		  (eval (get item :eval)))))))))
  )

(defun command-loop (&optional (window *frame*))
  (funcall *title-pane* :new-message "Diagnostics")
  (funcall *current-config* :new-message "Data paths")
  (force-string-in "(pkg-goto 'lam)")
  (do-forever
    (error-restart ((sys:abort error) "Return to diag command level.")
      (diag-command-loop window)))
  )

(defun process-lam ()
  (tv:delaying-screen-management
    (funcall *frame* :set-configuration 'lam-configuration)
    (funcall *title-pane* :new-message "Diagnostics")
    (funcall *current-config* :new-message "LAM"))
  (funcall *command-pane* :set-item-list *lam-permanent-menu-items*)
  (funcall *current-config* :new-message "LAM")
  (funcall *interaction-pane* :clear-screen)
  (force-string-in "(lam-on-frame)")
  )

(defun update-mode-line-pane (item-list)
    (funcall *mode-line-pane* :set-item-list item-list)
  )

(defun process-lam-internal (&optional (experienced-user? T))
  (tv:delaying-screen-management
    (funcall *frame* :set-configuration
	     (if experienced-user?
		 (let ()
		   (funcall *command-pane* :set-item-list *lam-permanent-menu-items*)
		   'lam-configuration)
	       (funcall *command-pane* :set-item-list *lam-permanent-menu-items-for-novice*)
	       'lam-configuration-for-novice))
    (funcall *title-pane* :new-message "Diagnostics")
    (funcall *current-config* :new-message "LAM"))
  )

(defun process-lam-novice ()
  (tv:delaying-screen-management
    (funcall *frame* :set-configuration 'lam-configuration-for-novice)
    (funcall *title-pane* :new-message "Diagnostics")
    (funcall *current-config* :new-message "LAM"))
  (funcall *command-pane* :set-item-list *lam-permanent-menu-items-for-novice*)
  (funcall *current-config* :new-message "LAM")
  (funcall *interaction-pane* :clear-screen)
  (force-string-in "(lam-on-frame)")
  )

(defun process-data-path ()
  (tv:delaying-screen-management
    (funcall *frame* :set-configuration 'data-path-config)
    (funcall *title-pane* :new-message "Diagnostics")
    (funcall *current-config* :new-message "Data paths"))
  (funcall *command-pane* :set-item-list *permanent-menu-items*)
  (funcall *current-config* :new-message "Data paths")
  (funcall *interaction-pane* :clear-screen)
  )

(defun select-path ()
  ;; take all the existing paths and return a menu of
  ;; if *list-of-paths* is nil then inform user that there is no path
  ;; if length of *list-of-paths* is equal to one then ignore it and
  ;; inform user that it has only one path built and is currently selected.
  (cond ((null *list-of-paths*)
	 (format *interaction-pane* "~%~%No path have been setup yet."))
	((= (length *list-of-paths*) 1)
	 (format *interaction-pane* "~%~%Only one path exists and is currently selected."))
	(t
	 ;; more than one path exist. pop a menu up and let the user choose the path
	 ;; to talk to.
	 (let (menu-item)
	   (dolist (path *list-of-paths*)
	     (push (list (funcall path :interface)
			 :eval `(setq *current-path*  ,path)
			 :font fonts:tr10bi)
		   menu-item))
	   (tv:menu-choose menu-item '(:string "Choose a path" :font fonts:tr12bi :centered))
	     )))
  )

(tv:add-system-key #/
 'diag-window "diag frame" t)