;;; -*- 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 interface to the setup function.
;;;


(defstruct (line-to-output :NAMED-ARRAY
	     (:PRINT-FUNCTION (LAMBDA (OBJECT STREAM)
				(SYS:PRINTING-RANDOM-OBJECT (OBJECT STREAM :TYPE)
				  (FORMAT STREAM " line ~A"
					  (line-binding OBJECT)))))
	     (:conc-name line-)
	     (:alterant nil))
  (:binding nil :documentation "Symbol to bind the input to")
  (:value nil :documentation "entry for lines to ouput a value")
  (:text-to-output nil :documentation "line contents")
  (:Selected-element nil :documentation "the element selected")
  (:Default-element nil :documentation "Set the selected element to be me")
  (:default-value nil :documentation "Set value slot to default value when resetting lines")
  (:function-to-run nil :documentation "Each time that any thing has been clicked on
this line, run this function afterwards to update lines of window")
  (:operations-to-run nil :documentation "In the doit process, this is the operation
to send to the current *proc*")
  (:type nil :documentation "Type of information for this line")
  )

;;;
;;;
;;; the entry text-to-output in the line definition has the following format.
;;;
;;; (header for the line :font font-name
;;;         :mousable-elements (NIL :default-font font-name
;;;                                 :Selected-element-font font-name
;;;                                 :ITEMS
;;;                                 ((text1 :VALUE value-to-return)
;;;                                  (text2 :VALUE value-to-return :font font-name)
;;;                                   .....))
;;;
;;; The entry selected-element has the text currently selected.
;;;
;;; The entry default-element is one of the text of mousable-elements.
;;;
;;; The entry type is a keyword which indicate what type of information is carried by the line.
;;; The keyword are :
;;;          :INTERFACE : indicates the type of hardware debug interface.
;;;          :BOARD : indicates type of board to debug.
;;;          :MULTIBUS-ADDRESS : address of multibus to use.
;;;          :SLOT-NUMBER : nubus slot number for :LMI-DEBUG
;;;          :CABLE : Length of cable between two :LMI-DEBUG cards.
;;;          :MODE : :LOCAL or :REMOTE
;;;
;;;



(defflavor setup-scroll-window
	   ()
	   (tv:function-text-scroll-window
	    tv:mouse-sensitive-text-scroll-window
	    tv:text-scroll-window
	    tv:borders-mixin
	    tv:top-label-mixin
	    tv:basic-scroll-bar
	    tv:flashy-scrolling-mixin
	    tv:margin-scroll-mixin
	    tv:margin-region-mixin
	    tv:margin-choice-mixin
	    tv:dont-select-with-mouse-mixin
	    tv:window)
  (:default-init-plist
    :label '(:string "Setup environment window" :centered :font fonts:metsi)
    :margin-choices '(("Do It" nil CHOICE-DONE nil nil)
		      ("Abort" NIL CHOICE-ABORT NIL NIL))
    :flashy-scrolling-region '((20 0.30 0.70) (20 0.30 0.70))
    :margin-scroll-regions '((:top) (:bottom))
    :font-map (list fonts:cptfontb fonts:tr12
		    fonts:tr10 fonts:tr10b
		    fonts:tr10i fonts:tr10bi
		    fonts:tr12b fonts:tr8i
		    fonts:tr12i fonts:tr12bi)
    :blinker-p t
    :blinker-deselected-visibility :off
    :blinker-flavor 'tv:rectangular-blinker
    :print-function 'output-info)
  :gettable-instance-variables
  :settable-instance-variables
  :inittable-instance-variables)

(defmethod (setup-scroll-window :delete-all-elements) (&optional (index 0))
  (do ((index-of-item-to-flush index index))
      ((= (array-leader tv:items 0) index))
    (funcall-self :delete-item index-of-item-to-flush))
  )

(defmethod (setup-scroll-window :add-line-to-be-displayed) (line)
  (funcall-self ':append-item line)
  )


(defun choice-done (&rest ignore)
  (DECLARE (:SELF-FLAVOR setup-scroll-window))
  (funcall self :force-kbd-input (list ':CHOICE-BOX ':DO-IT))
  )

(defun find-line (keyword)
  (dolist (line *list-of-lines*)
    (and (equal (line-type line) keyword)
	 (return line)))
  )

(DEFUN CHOICE-ABORT (&REST IGNORE)
  (DECLARE (:SELF-FLAVOR my-choose-variable-window))
  (funcall-self :force-kbd-input (list ':CHOICE-BOX ':ABORT))
  )

(defmacro create-line (text font items default-value
		       default-font selected-font
		       default-element function-to-run type)
  `(let ((line (make-line-to-output
		 :binding (second (assoc ,default-element ,items))
		 :selected-element ,default-element
		 :default-element ,default-element
		 :default-value ,default-value
		 :value ,default-value
		 :function-to-run ,function-to-run
		 :type ,type
		 :text-to-output (list ,text :font ,font
				      :Mousable-elements
				      (list NIL
					    :default-font ,default-font
					    :selected-element-font ,selected-font
					    :ITEMS ,items)))))
     (push line *list-of-lines*)
     line)
  )


(DEFUN output-info (line arg window &rest ignore)
  "Output function for the scrolling window. the input is a segment
definition. All information about this segment will be printed. The
option of looking at some other parameters will also be supported.
Segments for a given movement will be mouse sensitive. that means
that the user can access detailed information if needed and if existing.
Remember this is only a viewing tool."
  arg
  (let* ((item (line-text-to-output line))
	 (line-header (first item))
	 (mousable-items (get item :MOUSABLE-ELEMENTS))
	 (selected-element (line-selected-element line))
	 (font (get item :font)))
    (when line-header
      (multiple-value-bind (x y) (funcall window :read-cursorpos)
	x
	(funcall window :set-cursorpos 20. y)
	;; if there is a font then use it otherwise use the default font.
	(and font (funcall window :set-current-font font))
	(format window "~A   :   " line-header))
	(let ((default-font (get mousable-items :Default-font))
	      (selected-font (get mousable-items :selected-element-font))
	      (things-to-output (get mousable-items :ITEMS))
	      (value (line-value line))
	      text)
	  (dolist (item things-to-output)
	    (setq text (first item))
	    (setq font (if (string-equal text selected-element)
			   selected-font
			 default-font))
	    (and text
		 (progn
		   (and font (funcall window :set-current-font font))
		   (or (stringp text) (setq text (format nil "~A" text)))
		   (funcall window :item1 text line #'princ)
		   (format window "   "))))
	  (when value
	    (funcall window :set-current-font fonts:tr12bi)
	    (format window "~A" value))))
    )
  )


(defun update-line-internal (line &rest ignore
			     &aux (item-no
				    (funcall *menu-choose-window-for-set-up* :number-of-item line)))
  (funcall *menu-choose-window-for-set-up* :delete-item item-no)
  (funcall *menu-choose-window-for-set-up* :insert-item item-no line)
  )

(defun update-debug-speed (line)
  (update-line-internal line)
  (set-speed-for-lmi-debug (line-binding line))
  (reset-remote-debug-board (read-debug-mode))
  )

(defun update-debug-mode (line)
  (update-line-internal line)
  (set-mode-for-lmi-debug (line-binding line))
  (reset-remote-debug-board (read-debug-mode))
  )


(defun reset-line (line &aux items)
  (setf (line-selected-element line) (line-default-element line))
  ;; also reset it variable binding
  (setq items (get (get (line-text-to-output line) :mousable-elements) :ITEMS))
  (setf (line-binding line) (second (assoc (line-default-element line) items)))
  (setf (line-value line) (line-default-value line))
  ;; now operation or operations should be the one associated with this.
  (setf (line-operations-to-run line) 'this-operation)	;for now just a dummy.
  )


(defun choose-a-board-to-debug (line &rest ignore
				&aux new-item)
  (when *boards*
    (setq new-item
	  (tv:menu-choose
	    *boards*
	    '(:string "Boards in foreign rack" :font fonts:tr12bi :centered)
	    '(:MOUSE) NIL *menu-choose-window-for-set-up*))
    (when new-item
	 (setf (line-value line) new-item)
	 (update-line-internal line)))
  )

(defun add-line-for-boards (line &aux item
			    (associated-line
			      (second (assoc :INTERFACE *lines-to-delete-if-old-selection-is*))))
  (setq *proc*
	(selectq (line-binding line)
	  (:BURR-BROWN (setq bb-address (line-binding (find-line :MULTIBUS-ADDRESS)))
		       *dummy-for-burr-brown*)
	  (:LMI-DEBUG
	   (funcall *dummy-for-lmi-debug* :set-slot-number (line-value (find-line :slot-number)))
	   (init-debug-board (line-value (find-line :SLOT-NUMBER))
			     (line-binding (find-line :CABLE))
			     (line-binding (find-line :MODE)))
	   *dummy-for-lmi-debug*)
	  (:LOCAL nil)
	  (:SERIAL *dummy-for-serial*))
	*boards* NIL)
  (when *proc*
    (funcall *proc* :interface-reset)
    (make-nubus-configuration-array)
    (dotimes (i (array-length nubus-configuration-array))
      (if (or (null (setq item (first (aref nubus-configuration-array i))))
	      (equal item 'EMPTY)
	      (equal item 'UNKNOWN))
	  NIL
	(setq *boards* (nconc *boards*
			      (ncons (list (format nil "~A in slot ~D" item i) :VALUE (list item i)
					   :documentation (format nil "~A" item) :font fonts:tr10bi))))
	;; we have now a list of boards in the other foreign rack.
	)))
  (setf (line-value associated-line)
	(or (tv:menu-choose
	      *boards*
	      '(:string "Boards in foreign rack" :font fonts:tr12bi :centered)
	      '(:MOUSE) NIL *menu-choose-window-for-set-up*)
	    (line-value associated-line)
	    (get (first *boards*) :VALUE)))
  (update-line-internal associated-line)
  )

(defun create-and-add-lines-for (keyword &aux line (new-element (ncons keyword)) items)
  (selectq keyword
    (:LMI-DEBUG
     ;; lines to create are slot number, local-or-remote speed
     (setq line (create-line "Slot number the LMI-DEBUG board is in"
			     fonts:tr12i
			     (setq items (funcall *debugger-rack* :get-debug-board-slot-numbers))
			     (cadar items)
			     fonts:tr12i fonts:tr12bi (caar items)
			     'update-line-internal :SLOT-NUMBER))
     (nconc new-element (ncons line))
     (funcall *menu-choose-window-for-set-up* :add-line-to-be-displayed line)
     (setq line (create-line "Mode the LMI-DEBUG board is in"
			     fonts:tr12i
			     `(("Remote" :REMOTE)
			       ("Local" :LOCAL))
			     NIL
			     fonts:tr12i fonts:tr12bi
			     "Remote"
			     'update-debug-mode :MODE))
     (nconc new-element (ncons line))
     (funcall *menu-choose-window-for-set-up* :add-line-to-be-displayed line)
     (push new-element *lines-to-delete-if-old-selection-is*)
     ;; now since the default is "remote" for the mode then generate the line
     ;; associated with the speed.
     (setq line (create-line "Cable length (in Ft) for LMI-DEBUG boards"
			fonts:tr12i
			`(("Short" :FAST)
			  ("Long" :SLOW))
			NIL fonts:tr12i fonts:tr12bi "Short"
			'update-debug-speed :CABLE))
     (funcall *menu-choose-window-for-set-up* :add-line-to-be-displayed line)
     (push (list :REMOTE line) *lines-to-delete-if-old-selection-is*))
    (:BURR-BROWN
     (setq line (create-line "Multibus address for Burr Brown"
			     fonts:tr12
			     `(("Primary 2FF00" #x2ff00)
			       ("Secondary 2FE00" #x2fe00))
			     NIL
			     fonts:tr12i fonts:tr12bi "Primary 2FF00"
			     'update-line-for-multibus :MULTIBUS-ADDRESS))
     (funcall *menu-choose-window-for-set-up* :add-line-to-be-displayed line)
     (nconc new-element (ncons line))
     (push new-element *lines-to-delete-if-old-selection-is*))
    )
  )

(defun update-line-for-multibus (line &rest ignore)
  (update-line-internal line)
  (let ((bb-address (line-binding line)))
    (add-line-for-boards (find-line :INTERFACE)))
  )

(defun update-mode-of-new-debug (line old-selection)
  (when (neq (line-binding line) old-selection)
    (update-line-internal line)
    (if (equal old-selection :LOCAL)
	(dolist (line-to-add (cdr (assoc :REMOTE *lines-to-delete-if-old-selection-is*)))
	  (reset-line line-to-add)
	  (funcall *menu-choose-window-for-set-up* :add-line-to-be-displayed line-to-add))
	(delete-lines-and-dependents old-selection))
    )
  )

(defun delete-lines-and-dependents (old-selection)
  (let ((lines (cdr (assoc old-selection *lines-to-delete-if-old-selection-is*)))
	item-no)
    (when lines
      ;; these are to be deleted from the window.
      (dolist (line lines)
	(setq item-no (funcall *menu-choose-window-for-set-up* :number-of-item line))
	(funcall *menu-choose-window-for-set-up* :delete-item item-no)
	(delete-lines-and-dependents (line-binding line)))))
  )

(defun add-lines-and-dependents (new-selection)
  (dolist (line (cdr (assoc new-selection *lines-to-delete-if-old-selection-is*)))
    (reset-line line)
    (funcall *menu-choose-window-for-set-up* :add-line-to-be-displayed line)
    ;; add all its dependent.
    (add-lines-and-dependents (line-binding line)))
  )

(defun update-type-interface-line (line old-selection)
  "Adds new line depending on the selection type of interface"
  (update-line-internal line)
  (delete-lines-and-dependents old-selection)
  (if (assoc (line-binding line) *lines-to-delete-if-old-selection-is*)
      (add-lines-and-dependents (line-binding line))
    ;; ohterwise create the lines and add them.
    (create-and-add-lines-for (line-binding line)))
  (add-line-for-boards line)
  )

(defun update-line (blip &aux line items old-selection)
  (setf (line-selected-element (setq line (first blip))) (second blip))
  (setq items (get (get (line-text-to-output line) :MOUSABLE-ELEMENTS) :ITEMS))
  (setq old-selection (line-binding line))
  (setf (line-binding line) (second (assoc (second blip) items)))
  ;; if selection is same as before then leave things alone.
  (and (line-function-to-run line)
       (funcall (line-function-to-run line) line old-selection))
  )

(defun process-function-setup-environment ()
  (funcall *debugger-rack* :setup)
  )


(defun get-path-and-operations (lines &aux line operations path-to-return)
  (dotimes (i (array-active-length lines))
    (selectq (line-type (setq line (aref lines i)))
      (:INTERFACE (push (list :SET-INTERFACE (line-binding line)) operations))
      (:MODE (push (list :SET-MODE (line-binding line)) operations))
      (:BOARD (push (list :SET-BOARD (line-value line)) operations))
      (:CABLE (push (list :SET-CABLE (line-binding line)) operations))
      (:MULTIBUS-ADDRESS (push (list :SET-MULTIBUS-ADDRESS (line-binding line)) operations))
      (:SLOT-NUMBER (push (list :SET-SLOT-NUMBER (line-value line)) operations))))
  (setq path-to-return
	(dolist (path *list-of-paths*)
	  (selectq (funcall path :INTERFACE)
	      (:BURR-BROWN
	       ;; multibus address should make the difference if there is more than
	       ;; one burr brown card.
	        (and (equal (second (assoc :SET-MULTIBUS-ADDRESS operations))
			    (funcall path :MULTIBUS-ADDRESS))
		     (return path)))
	      (:LMI-DEBUG
	       ;; slot number in nubus should differenciate them.
	       (and (equal (second (assoc :SET-SLOT-NUMBER operations))
			   (funcall path :SLOT-NUMBER))
		    (return path)))
	      (:SERIAL
	       ;; I don't really know
	       )
	      (:LOCAL
	       ;; I don't really know
	       ))))
  (values path-to-return operations (and path-to-return (funcall path-to-return :DEBUGGEE-RACK)))
  )

(defun setup-internal (lines  &aux path rack operations)
  (multiple-value (path operations rack)
    (get-path-and-operations lines))
  (when (null path)
    (setq rack (make-instance 'debugged-rack
			      :boards-to-debug
			      (let (boards)
				(dolist (item *boards*)
				  (push (get item :VALUE) boards))
				boards))
	  path (make-instance 'diag-path :DEBUGGER-RACK *debugger-rack*
			      :DEBUGGEE-RACK rack))
    (push path *list-of-paths*))
  (dolist (item operations)
    (funcall path (first item) (second item))
    (when (equal (first item) :set-board)
      (funcall rack :set-current-board (second item))))
  (funcall *path-info* :information-about-path path)
  (funcall path :setup)
  path
  )

(defun process-function-setup-environment-internal (&aux blip)
  ;; the knowledge in the window is set up the right way and contains information
  ;; about the present rack.
  ;; expose now the window.
  (funcall *menu-choose-window-for-set-up* :expose)
  (do-forever
    (setq blip (funcall *menu-choose-window-for-set-up* :list-tyi))
    (selectq (first blip)
      (:MOUSE-BUTTONS ())			; random clicks of the mouse
      (:CHOICE-BOX
       (funcall *menu-choose-window-for-set-up* :deactivate)
       (if (equal (second blip) :ABORT)
	   (return nil)
	 (return (setq *current-path*
		       (setup-internal
			 (funcall *menu-choose-window-for-set-up* :ITEMS))))))
      (otherwise
       (if (typep (first blip) 'line-to-output)
	   (update-line blip)
	 (progn
	   (funcall *menu-choose-window-for-set-up* :deactivate)
	   (return nil))))
      )
    )
  (funcall *interaction-pane* :select)
  )