;;; -*- Mode:Common-Lisp; Package:ZWEI; Fonts:(CPTFONT CPTFONTB CPTFONTI); Base:10 -*-

;;;                           RESTRICTED RIGHTS LEGEND

;;;Use, duplication, or disclosure by the Government is subject to
;;;restrictions as set forth in subdivision (c)(1)(ii) of the Rights in
;;;Technical Data and Computer Software clause at 52.227-7013.
;;;
;;;                     TEXAS INSTRUMENTS INCORPORATED.
;;;                              P.O. BOX 2909
;;;                           AUSTIN, TEXAS 78769
;;;                                 MS 2151
;;;
;;; Copyright (C) 1987-1989 Texas Instruments Incorporated. All rights reserved.

;;; CHANGE HISTORY started on 10/22/87
;;; 10/31/87   slm  Add loops within :LINK-AND-EXPOSE to get to the last physical diagram
;;;                 line of the preceding node when obtaining the surrounding lines to use.
;;;                 This is part of the fix to keep from "losing" the chapter's number diagram
;;;                 during expansion/contraction of superior references.
;;; 10/31/87   slm  Change case of VISIDOC to Visidoc in the message that gets printed in the
;;;                 minibuffer during a REVERT.

;================================================================================
;  ZWEI:ZMACS-FRAME METHODS

(DEFMETHOD (zmacs-frame :suggestions-on-message) ()
  (WHEN (AND tv:exposed-p
	     (MEMBER 'zwei:doc-viewer-command-menu tv:inferiors
		     :test #'(lambda (x y) (TYPEP y x))))
    (DOLIST (wind tv:inferiors)
      (SEND editor-closure #'EVAL
	    `(SEND ,wind :send-if-handles :suggestions-on-message self)))
    (SEND (SEND editor-closure #'EVAL '*window*) :select)))


(DEFMETHOD (zmacs-frame :suggestions-off-message) ()
  (WHEN (AND tv:exposed-p
	     (MEMBER 'zwei:doc-viewer-command-menu tv:inferiors
		     :test #'(lambda (x y) (TYPEP y x))))
    (DOLIST (wind tv:inferiors)
      (SEND editor-closure #'EVAL
	    `(SEND ,wind :send-if-handles :suggestions-off-message self)))
    (SEND (SEND editor-closure #'EVAL '*window*) :select)))

;================================================================================
;  ZWEI:ZMACS-WINDOW-PANE METHODS

(DEFMETHOD (zmacs-window-pane :suggestions-on-message) (&rest ignore)
  (WHEN tv:exposed-p
    (SEND (window-interval self) :send-if-handles :suggestions-on-message self)))


(DEFMETHOD (zmacs-window-pane :suggestions-off-message) (&rest ignore)
  (WHEN tv:exposed-p
    (SEND (window-interval self) :send-if-handles :suggestions-off-message self)))

;================================================================================
;  BUFFER METHODS

(DEFMETHOD (zwei-doc-viewer-buffer :after :init) (&rest ignore)
  (setf pathname nil)
  (setf saved-major-mode 'doc-viewer-mode)
  (setf read-only-p t)
  (setf plist nil)
  (setf undo-status :dont)
  (setf (node-inferiors self) nil))


(DEFMETHOD (zwei-doc-viewer-buffer :exit-special-buffer)
	   (&optional mark-clean buffer-being-exited)
  (declare (special *zmacs-doc-viewer-list*))
  (let ((special-buffer (or buffer-being-exited *interval*)))
    (and mark-clean (not-modified special-buffer))
    (if (eq special-buffer *interval*)
	(send 
	  (or (car (member special-buffer (history-list (send *window* :buffer-history))
			   :test #'neq))
	      *interval*) :select))
    (without-interrupts
      (setq *zmacs-doc-viewer-list* 
	    (append (remove special-buffer *zmacs-doc-viewer-list* :test #'eq)
		    (list special-buffer))))
    (point-pdl-purge special-buffer))
  dis-text)


(DEFMETHOD (zwei-doc-viewer-buffer :suggestions-off-message) (window)
  (SEND self :remprop :leave-menus-up)
  (configure-window-pane-with-menus window)
  nil)


(DEFMETHOD (zwei-doc-viewer-buffer :suggestions-on-message) (window)
  (send self :putprop :leave-menus-up t)
  (configure-window-pane-WITHOUT-menus window)
  nil)


(DEFMETHOD (zwei-doc-viewer-buffer :after :select) (&rest ignore)
  "Make SELF the current ZMACS buffer in the selected window.
PRESERVE-BUFFER-HISTORY non-NIL says do not reorder the buffers for C-M-L, etc."
  ;;Don't do anything to the windows if Suggestions are on!!!
  (declare (special *bold-font-names*)) ;06-13-88 DAB
  (UNLESS (AND (FIND-PACKAGE "SUGG")
	       (FBOUNDP 'sugg:suggestions-on-for-this-window?)  ;;Add conditions for FBOUNDP functions...
	       (FBOUNDP 'sugg:climb-to-recognized-window)       ;;some load bands may not contain Suggestions!
	       (sugg:suggestions-on-for-this-window?
		 (type-of (sugg:climb-to-recognized-window w:selected-window))))
    ;; Make the window pane be the constraint frame
    (SEND self :remprop :Leave-Menus-Up)
      (Configure-Window-Pane-with-Menus *window*))
  (SEND *INTERVAL* :SET-ATTRIBUTE :TAB-WIDTH 8 nil)
  (SEND self :putprop (SEND *window* :tab-nchars) :old-tab-nchars)
  (REDEFINE-WINDOW-TAB-NCHARS *WINDOW* 8)
  (UNLESS (GET '*bold-font-names* :parsed-font-specs)                 ;;All this 'parse-font-specs' stuff is for
    (SETF (GET '*bold-font-names* :parsed-font-specs)                 ;;compatibility with non-Explorer monitors...
          (LOOP for font in *bold-font-names*                         ;;fonts do NOT map one-to-one!
                with scr = (w:sheet-get-screen *window*)
                collect (SEND scr :parse-font-specifier font)))
    (SETF *bold-font-names* (GET '*bold-font-names* :parsed-font-specs))
    (SETF *contracted-line-font*
	  (send (w:sheet-get-screen *window*) :parse-font-specifier *contracted-line-font*)))
  nil)


(DEFMETHOD (zwei-doc-viewer-buffer :after :deselect) (&rest ignore &aux n)
  (WHEN (SETQ n (SEND self :get-attribute :old-tab-nchars))
    (redefine-window-tab-nchars *window* n))
  (UNLESS (SEND self :get-attribute :Leave-Menus-Up)
    (Configure-Window-Pane-WITHOUT-Menus *window*)))


(DEFMETHOD (zwei-doc-viewer-buffer :before :kill) (&rest ignore)
  (point-pdl-purge self)
  (without-interrupts
    (let ((element (rassoc self *zmacs-doc-viewer-buffer-name-alist* :test #'equal)))
      (and element
	   (setq *zmacs-doc-viewer-buffer-name-alist*
		 ;; Make a new list so old buffers get gc'd.
		 (COPY-LIST (delete element  *zmacs-doc-viewer-buffer-name-alist* :test #'equal)))))
    (setq *zmacs-doc-viewer-list* (remove self *zmacs-doc-viewer-list* :test #'equal)))
  (FORMAT *query-io* "~&Killing Visidoc buffer for ~a manual" namespace-name)
  (dolist (node inferiors)
    (FORMAT *query-io* "..")
    (send node :remove-from-namespace-and-unlink-all self))
  (setf inferiors nil)
  t)


(DEFMETHOD (zwei-doc-viewer-buffer :activate) (&optional ask-for-new-name)
  (without-interrupts
    ;; First, if buffer is not already on name alist, put it on,
    ;; getting a new name if necessary and appropriate.
    (unless (rassoc self *zmacs-doc-viewer-buffer-name-alist* :test #'eq)
      (do () ((not (assoc name *zmacs-doc-viewer-buffer-name-alist* :test #'equalp)))
	(if ask-for-new-name
	    (let ((inhibit-scheduling-flag nil))
	      (if (and pathname
		       (not (buffer-pathname
			      (cdr (assoc name *zmacs-doc-viewer-buffer-name-alist*
					  :test #'equalp)))))
		  ;; This is visiting a file and the other is not.
		  (send (cdr (assoc name *zmacs-doc-viewer-buffer-name-alist* :test #'equalp))
			:rename
			(do ((name1 (typein-line-readline
				      "There is a non-file buffer ~A.  Rename it to: "
				      name)
				    (typein-line-readline
				      "~A is in use too.  Try again." name1)))
				    (())
				  (unless
				    (assoc name1 *zmacs-doc-viewer-buffer-name-alist* :test #'equalp)
				    (return name1))))
		  (setq name
			(typein-line-readline
			  "There is already a buffer named ~A.  Specify another name:"
			  name))))
	    (barf "There is already a buffer named ~A." name)))
      (push (cons name self) *zmacs-doc-viewer-buffer-name-alist*)
      (setq *zmacs-doc-viewer-buffer-name-alist*
	    (copy-alist *zmacs-doc-viewer-buffer-name-alist*))
      (dolist (elt *zmacs-doc-viewer-buffer-name-alist*)
	(setf (car elt) (si:copy-object (car elt)))))
    ;; Put the buffer on the other lists, if not already there.
    (unless (member self *zmacs-doc-viewer-list* :test #'eq)
      (setq *zmacs-doc-viewer-list* (append *zmacs-doc-viewer-list* (list self))))))


(DEFMETHOD (zwei-doc-viewer-buffer :revert) (&rest ignore) 
  "Re-calculate doc-viewer information and format Doc-viewer buffer."
  (setf read-only-p t)
  (FORMAT *query-io* "~&Reverting buffer for ~a manual" namespace-name)
  (DOLIST (node inferiors)
    (FORMAT *query-io* "..")
    (SEND node :revert namespace-name))
  (WHEN (EQ (window-interval *window*) self)
    (move-bp (point) first-bp)
    (SETF (window-redisplay-degree *window*) DIS-TEXT)
    (SEND *window* :redisplay :START (point) nil nil)))


(DEFMETHOD (zwei-doc-viewer-buffer :window) ()
  (DOLIST (window (SEND self ':windows) nil)
    (AND (EQ (window-interval window) self)
	 (RETURN window))))


(DEFMETHOD (zwei-doc-viewer-buffer :find-last-exposed-inferior) ()
  (WHEN inferiors
    (SEND (CAR (LAST inferiors)) :find-last-exposed-inferior)))


(DEFMETHOD (zwei-doc-viewer-buffer :find-first-exposed-inferior) ()
  (WHEN inferiors
    (SEND (CAR inferiors) :find-first-exposed-inferior)))


(DEFMETHOD (zwei-doc-viewer-buffer :change-superiors-first-bp) (bp &optional (inf nil given?))
  (and given? (OR (eq (CAR inferiors) inf) (EQ inf (SEND self :find-first-exposed-inferior)))
	    (move-bp first-bp bp)))

(DEFMETHOD (zwei-doc-viewer-buffer :change-superiors-last-bp)  (&rest ignore) ;;(bp &optional (inf nil given?))
  nil)

(DEFMETHOD (zwei-doc-viewer-buffer :step-up-to-superior) (&rest ignore)
  nil)

(DEFMETHOD (zwei-doc-viewer-buffer :set-superiors-first-bp-type) (&rest ignore)
  ())

(DEFMETHOD (zwei-doc-viewer-buffer :set-superiors-last-bp-type) (&rest ignore)
  ())

(DEFMETHOD (zwei-doc-viewer-buffer :climb-to-buffer) ()
  self)

(DEFMETHOD (zwei-doc-viewer-buffer :climb-to-superior) (&rest ignore)
  nil)

(DEFMETHOD (zwei-doc-viewer-buffer :climb-up-node-hierarchy) (&rest ignore)
  nil)

;================================================================================
;  REFERENCE-NODE METHODS

(DEFMETHOD (reference-node :change-superiors-first-bp) (bp &optional (inf nil given?))
  (when (or (not given?)
	    (EQ (CAR inferiors) inf)
	    (eq (SEND self :find-first-exposed-inferior) inf))
    (move-bp first-bp bp)
    (send superior :change-superiors-first-bp bp (OR inf self))))


(DEFMETHOD (reference-node :change-superiors-last-bp) (bp &optional (inf nil given?))
  (when (or (not given?)
	    (EQ (CAR (LAST inferiors)) inf)
	    (eq (SEND self :find-last-exposed-inferior) inf))
    (move-bp last-bp bp)
    (send superior :change-superiors-last-bp bp (OR inf self))))


(DEFMETHOD (reference-node :mark-inferiors-as-deexposed) ()
  (dolist (node inferiors)
    (send node :mark-as-deexposed)))


(DEFMETHOD (reference-node :mark-as-deexposed) ()
  (when inferiors
    (dolist (node inferiors)
      (SEND node :mark-as-deexposed)))
  (setf exposed-p nil))


(DEFMETHOD (reference-node :link-and-expose) ()
  ;;Move this reference-node from its unexposed neighbors and hook it up
  ;;to it's exposeded/visible neighbors.
  ;;Notice that we want to leave the unexposed neighbors' lines pointing to 
  ;;the lines of this newly exposed node.
  (COND ((memeq (ht-node-type self) '(:contents :header))
	 (let* ((fline (find-real-line self))
		(exposed-prev (send self :exposed-previous-leaf-node))
		(lline-exp-prev (when exposed-prev (find-real-line exposed-prev t)))
		(lline (find-real-line self t))
		(exposed-nxt (send self :exposed-next-leaf-node))
		(fline-exp-nxt (if exposed-nxt (find-real-line exposed-nxt)
				   (bp-line (interval-last-bp *interval*)))))
	   (setf exposed-p t)
	   (without-interrupts
	     ;;relink lines of unexposed previous and exposed-prev nodes if necessary
	     (when lline-exp-prev
	       (setf (line-next lline-exp-prev) fline))
	     (setf (line-previous fline) lline-exp-prev)
	     ;;relink lines of unexposed next and exposed-nxt nodes if necessary
	     (when fline-exp-nxt
	       (setf (line-previous fline-exp-nxt) lline))
	     (setf (line-next lline) fline-exp-nxt)))
	 (update-surrounding-bps self))
	((and inferiors (node-expandedp self))
	 (dolist (inf inferiors)
	   (UNLESS (EQ :header (ht-node-type inf))
	     (send inf :link-and-expose)))
	 (SETF exposed-p t))
	(inferiors
	 (DOLIST (inf inferiors)
	   (WHEN (EQ :header (ht-node-type inf))
	     (SEND inf :link-and-expose)
	     (RETURN)))
	 (SETF exposed-p t))))


(DEFMETHOD (reference-node :revert) (manual)
  (IF (EQ type :unbound)
      (DOLIST (node inferiors)
	(SEND node :revert manual)) 
      (contract-reference self))) ;;)cc


(DEFMETHOD (reference-node :remove-from-namespace) ()
  (remove-node-from-namespace self))


(DEFMETHOD (reference-node :remove-from-namespace-and-unlink-all) (buffer)
  (DOLIST (node inferiors)
    (SEND node :remove-from-namespace-and-unlink-all buffer))
    (remove-node-from-namespace self)
    (remove-node-from-history self)
  )


(DEFMETHOD (reference-node :remove-all-from-namespace) (buffer)
  (dolist (node inferiors)
    (send node :remove-all-from-namespace buffer)) 
  (remove-node-from-namespace self)
  (remove-node-from-history self)
  (with-read-only-suppressed (buffer)
    (delete-interval self)))


(DEFMETHOD (reference-node :climb-to-buffer) ()
  (send superior :climb-to-buffer))


(DEFMETHOD (reference-node :climb-to-superior) (sup)
  (IF (EQ superior sup)
      self
      (SEND superior :climb-to-superior sup)))


(DEFMETHOD (reference-node :find-last-exposed-inferior) ()
      (IF inferiors
	(SEND (CAR (LAST inferiors)) :find-last-exposed-inferior)
        (OR (AND exposed-p self)
	    (SEND self :exposed-previous-leaf-node))))


(DEFMETHOD (reference-node :find-first-exposed-inferior) ()
      (IF inferiors
	(SEND (CAR inferiors) :find-first-exposed-inferior)
        (OR (AND exposed-p self)
	    (SEND self :exposed-next-leaf-node))))


(DEFMETHOD (reference-node :after :init) (&rest ignore)
  (setf expanded-p nil
	exposed-p nil
	start :unbound
	end :unbound
	ref-type :unbound
	nth :unbound
	max-nth 0)
  (unless superior (setf superior *interval*)))

;================================================================================
;  HT-NODE METHODS

(DEFMETHOD (ht-node :print-self) (stream depth slashify)
  depth
  (IF slashify (FORMAT stream "#<~A ~S ~O>" (SEND self :type) name (sys:%POINTER self))
      (PRINC name stream)))


(DEFVAR s-delim1 (make-fat-string "<S|" 3))
(DEFVAR s-delim2 (make-fat-string "|S>" 3))
(DEFVAR h-delim1 (make-fat-string "<H|" 3))
(DEFVAR h-delim2 (make-fat-string "|H>" 3))
(DEFVAR h-remain 'YES)
(DEFVAR d-remain 'YES)

(DEFMETHOD (ht-node :exposed-previous-node) ()
  (LOOP for node first self then (node-previous node)
	until (NULL node)
	when (ht-node-exposed-p node)
	return node
	finally (RETURN nil)))

(DEFMETHOD (ht-node :exposed-next-node) ()
  (LOOP for node first self then (node-next node)
	until (NULL node)
	when (ht-node-exposed-p node)
	return node
	finally (RETURN nil)))

(DEFMETHOD (ht-node :exposed-previous-leaf-node) ()
  (DO ((prev-node (SEND self :previous-leaf-node) (SEND prev-node :previous-leaf-node)))
      ((OR (NULL prev-node)
	   (ht-node-exposed-p prev-node))
       prev-node)))

(DEFMETHOD (ht-node :exposed-next-leaf-node) ()
  (DO ((next-node (SEND self :next-leaf-node) (SEND next-node :next-leaf-node)))
      ((OR (NULL next-node)
	   (ht-node-exposed-p next-node))
       next-node)))

(DEFMETHOD (ht-node :previous-leaf-node) (&aux top-node)
  (SETQ top-node (SEND self :climb-up-node-hierarchy t))
  (IF top-node
      (SEND top-node :step-down-node-hierarchy t)
      nil))

(DEFMETHOD (ht-node :next-leaf-node) (&aux top-node)
  (SETQ top-node (SEND self :climb-up-node-hierarchy nil))
  (IF top-node
      (SEND top-node :step-down-node-hierarchy nil)
      nil))

(DEFMETHOD (ht-node :climb-up-node-hierarchy)  (prev &aux siblings pos bound switch)
  (SETQ siblings (node-inferiors superior))
  (COND (prev
	 (SETQ bound 0
	       switch #'1-))
	(t
	 (SETQ bound (1- (LENGTH siblings))
	       switch #'1+)))
  (COND ((= bound (SETQ pos (OR (POSITION self siblings) bound)))
	 (SEND superior :climb-up-node-hierarchy prev))
	(t
	 (NTH (FUNCALL switch pos) siblings))))

(DEFMETHOD (ht-node :step-down-node-hierarchy)  (prev &aux index)
  (COND (inferiors 
	 (SETQ index (IF prev (1- (LENGTH inferiors)) 0))
	 (SEND (NTH index inferiors) :step-down-node-hierarchy prev))
	(t
	 self)))

;================================================================================

(compile-flavor-methods zwei-doc-viewer-buffer ht-node doc-viewer-interval reference-node)