;;; -*- Mode:Common-Lisp; Package:ZWEI; Fonts:(CPTFONT CPTFONTB CPTFONTBI); 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
;1;; 12-21-88 MAY  Changed *doc-viewer-select-buffer 1to *(TYPEOUT-ABORT-MINI-BUFFER) 1first.*
;;; 09-12-88   DAB  Expand-reference would cause :redisplay errors when expanding a node, 
;1;;               *followed by a sibling node pointing
;;;                 to the same start and ending positions.
;;; 08-31-88   DAB  Fixed expand-reference. It was trying to take the nth of :unbound. 
;1;;               *Also fixed check-font. It was trYing to do a boundp on a structure.
;;; 10/31/87   slm  Add loops within MOVE-DOC-INTERVAL, UPDATE-SURROUNDING-BPS, and 
;;;                 DELETE-DOC-INTERVAL to get to the last physical diagram line 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  Fix Table of Contents command so it will REVERT the Visidoc buffer 
;;;                 on every iteration.

(proclaim '(optimize (safety 0)(space 0)(speed 3)))

;===============================================================================
;  BUFFER FUNCTIONS

(defun update-doc-viewer-buffer-history (old-buffer new-buffer)
  "Update lists of recently selected buffers when NEW-BUFFER is selected.
OLD-BUFFER should be the buffer that used to be selected."
   (declare (special *zmacs-doc-viewer-list*))
  (and (neq old-buffer new-buffer)
       (without-interrupts
	 (when (neq new-buffer (car *zmacs-doc-viewer-list*))
	   (setq *zmacs-doc-viewer-list*
		 (cons new-buffer
		       (remove new-buffer *zmacs-doc-viewer-list* :test #'eq)))))))


(defun check-font (font)
  "Make sure FONT is a valid font.  If it is not already loaded, go to the
system host and load the font file."
  (DECLARE (SPECIAL fonts:*use-default-mac-font*))
  (LET-IF (tv:mac-system-p)
	  ((fonts:*use-default-mac-font* t))
    (cond ((not (symbolp font)) (barf "~S is not the name of a font" font))
	  ((not (boundp font))
	   (SETf (values nil font) (SEND w:default-screen :parse-font-specifier font))
	   (or (boundp font) (barf "~S is not a defined font" font)))))
  font)


(defun change-buffer-fonts (buffer font-list)
  "Change the set of fonts to use.
This sets the fonts associated with the current buffer.
Reads a list of font names, separated by spaces, from the mini-buffer."
  (redefine-fonts *window*
		  ;;Cons up a font-alist on the side for redefine-fonts to use.
		  (do* ((l (reverse font-list) (cdr l))
			(font (check-font (car l)) (check-font (car l)))
			(font-names (list font) (cons font font-names))
			(font-alist
			  (list (cons (symbol-name font) (symbol-value font)))
			  (cons (cons (symbol-name font) (symbol-value font)) font-alist)))
		       ((null (cdr l))
			(send buffer :set-attribute :fonts font-names t)
			font-alist)))
  (update-font-name)
  dis-all)


(defun find-doc-viewer-buffer ()
  "Return a Doc Viewer buffer, or NIL if none exist."
  (declare (special *zmacs-doc-viewer-list*))
  (loop for buffer in *zmacs-doc-viewer-list*
	if (eq (node-special-type buffer) :doc-viewer)
	return buffer))


(defun find-doc-viewer-buffer-named (name)
  "Return the buffer named NAME, or NIL if none found with that name."
  (declare (special *zmacs-doc-viewer-list*))
  (unless (null name)
    (or (stringp name)
	(and (keywordp name) (setq name (string name)))
	(setq name (funcall name :string-for-editor)))
    (do ((l *zmacs-doc-viewer-list* (cdr l)))
	((null l) nil)
      (and (string-equal (buffer-name (car l)) name)
	   (return (car l))))))


(defun find-or-create-doc-viewer-buffer (&optional name &aux newbuf)
  "Return the buffer named NAME, or create one named NAME.
If NAME is NIL, then find any doc-viewer buffer, or create a generic doc viewer buffer."
  ;; The following comment may now be bogus. - pf, Apr 29, 1985
  ;; We do not use :FIND-SPECIAL-BUFFER because we can be called
  ;; while not inside ZMACS, and there may not even be a good way to
  ;; pick which ZMACS window to call.
  ;;==Be SURE to activate a new buffer!!!==
  (or (and name (or (find-doc-viewer-buffer-named name)
		    (PROGN (SETQ newbuf (make-instance 'zwei-doc-viewer-buffer
						       :name name
						       :namespace-name name))
			   (SEND newbuf :activate)
			   newbuf)))		   
      (find-doc-viewer-buffer)
      (PROGN (SETQ newbuf (make-instance 'zwei-doc-viewer-buffer
					 :name (loop for i from 1
						     as bufnam = (format nil "~A (~D)" "Doc Viewer" i)
						     unless (find-doc-viewer-buffer-named bufnam)
						     return bufnam)))
	     (SEND newbuf :activate)
	     newbuf)))


(defun doc-viewer-select-buffer (&optional name buffer fonts-list)
  "Select the ZMACS doc viewer buffer BUFFER, or the doc-viewer buffer named NAME.
If no such buffer exists, then create one named NAME."
  (TYPEOUT-ABORT-MINI-BUFFER) ;1; may 12-21-88*
  (let ((interval (or buffer (find-or-create-doc-viewer-buffer name))))
    (make-buffer-read-only interval)
    (setf (node-special-type interval) :doc-viewer
	  (buffer-saved-major-mode interval) 'doc-viewer-mode)
    (send interval :putprop t :Leave-Menus-Up)
    (send interval :select)
    ;;(send interval :activate)  ;;activate buffer at time of creation
    (and fonts-list (change-buffer-fonts interval fonts-list))
    dis-text))


(defun view-on-line-documentation (&key (selectp t))
  (let ((sheet (find-or-create-idle-zmacs-window)))
    (funcall sheet :force-kbd-input '(:execute com-select-doc-viewer-buffer))
    (when selectp
      (funcall sheet :select) 
      (tv:await-window-exposure))
    sheet))

	
(defun doc-viewer-buffer-revert (interval)
  "Re-calculate doc-viewer information and format Doc-viewer buffer."
  (setf (symbol-plist interval) nil)
  (make-buffer-read-only interval)
  (set-buffer-file-id interval (string (send interval :name)))
  (with-read-only-suppressed (interval)
    (delete-interval interval)
    (insert-moving (buffer-point interval) (format nil *doc-viewer-header*))))

;===============================================================================
;  APROPOS

(DEFUN make-doc-viewer-apropos-menu-alist (possibilities manuals types target search-method)
  "POSSIBILITES is a list of strings returned from the DOC-APROPOS-RETRIEVAL function.
All of the rest of the arguments are the same ones that were used by that function
to obtain POSSIBILITIES.  Returns a list that when evaluated, pops up a menu of the possibilities
with a label containing the other information."
  (LET ((manuals (OR (AND (CONSP manuals) manuals) (LIST manuals)))
	(target (OR (AND (CONSP target) target) (LIST target)))
	(types (OR (AND (CONSP types) types) (LIST types)))
	(pos (POSITION search-method '(:start :any :end :words :and-words))))
  (PRIN1-TO-STRING `(w:menu-choose ',possibilities
		  :columns 1
		  :item-alignment :center
		  :label ,(FORMAT nil "Apropos from the search for~{ ~s~^,~}
Type~P searched for ~:*~[were~;was~:;were~] ~{ ~a~^,~}
The names returned from the~{ ~a~^,~} manual~P~%~[match at the beginning of the word~;match anywhere within a word~;match at the end of the word~;contain any of the words~;contain all of the words~]" 
				  target (LENGTH types) types manuals (LENGTH manuals) pos)))))

(DEFUN make-apropos-menu-item (possibilities manuals types target search-method &aux str)
  "POSSIBILITES is a list of strings returned from the DOC-APROPOS-RETRIEVAL function.
All of the rest of the arguments are the same ones that were used by that function
to obtain POSSIBILITIES."
  (LIST (SETQ str (FORMAT nil "APROPOS: ~{ ~s~^,~}" (OR (AND (CONSP target) target) (LIST target))))
	:kbd `(:execute zwei:execute-apropos-menu-item
			,(make-doc-viewer-apropos-menu-alist possibilities manuals types target search-method))
	:documentation (LIST :mouse-any "pop up menu from apropos search "
			     :mouse-m-2 "delete reference from history"
			     :no-comma nil
			     :documentation str)))

(DEFUN execute-apropos-menu-item (stuff)
  ;;(BREAK "stuff is ~s" (SETQ tstuff stuff))
  (LET ((name (EVAL (READ-FROM-STRING stuff))))
    (IF (STRINGP name) (doc-viewer-top-level name)
	)))

(DEFUN add-apropos-menu-item (possibilities manuals types target search-method)
  "POSSIBILITES is a list of strings returned from the DOC-APROPOS-RETRIEVAL function.
All of the rest of the arguments are the same ones that were used by that function
to obtain POSSIBILITIES.  Adds a menu item to retrieve these values to the HISTORY window."
  (LET ((item (make-apropos-menu-item possibilities manuals types target search-method)))
    (SETQ *doc-viewer-request-history*
	  (CONS item (remove item *doc-viewer-request-history* :test #'equal)))
    (update-request-history-item-list) 
    item))


(DEFUN doc-apropos (window var old-value new-value)
  (DECLARE (IGNORE window var old-value))
  (LET ((word-list (OR (AND (NOT (equal "" target)) (LIST target)) (CAR *apropos-list*)))
	(pattern (OR (CADR *apropos-list*) :words)))
    (DECLARE (SPECIAL word-list pattern target multi-word-search))
  (IF (EQUAL new-value T)
      (CONDITION-CASE ()
	(w:choose-variable-values
	  '((word-list "Word(s) to find"
		       :documentation "Enter a list of words, separated by spaces and commas, that should be contained within the name you want."
		       :string-list)
	    (pattern "Find names that contain"
		     :menu-alist (("ANY of the above words" :value :words)
				   ("ALL of the above words" :value :and-words)))
	    )
	  :label "Compose items for complex retrieval"
 	  :margin-choices '(("Abort" (SIGNAL-CONDITION eh:*abort-object*))))
	(sys:abort (SETQ multi-word-search nil))
	(:no-error (IF (OR (NULL word-list) (EQUAL "" (CAR word-list)))
		       (PROGN (tv:notify nil "You cannot select NO words to search for.  
If you wish to quit, press the ABORT key.
If you wish to continue, simply try again")
			      (SETQ multi-word-search nil))
		       (SETQ *apropos-list* (LIST word-list pattern))))
	))
      ))

(DEFUN extract-and-execute-item (menu-item)
  (EVAL (READ-FROM-STRING (THIRD (THIRD menu-item)))))

(DEFUN doc-viewer-apropos ()
  (LET ((manuals (IF (TYPEP *interval* 'zwei-doc-viewer-buffer)
		     (LIST (SEND *interval* :namespace-name)) (list-of-manuals)))
	(types '(:function)) 
	(target (OR (CAAR *apropos-list*) ""))
	(place :any)
	(multi-word-search nil)
	(return-list nil)
	name)
    (DECLARE (SPECIAL manuals types target place multi-word-search)) 
    (CONDITION-CASE ()
	(w:choose-variable-values
	 `((manuals "Search manual(s):.........."  :multiple-menu `,(list-of-manuals))
	   (types "Search for these types of objects" :multiple-menu `,(list-of-all-types))
	   (target "string to find" :string)
	   (place "word place in string" :menu-alist (("first" :value :start)
						      ("any" :value :any)
						      ("last" :value :end)))
	   (multi-word-search "more complex retrieval"
			      :documentation "Choose YES to form a more complex list of words to find, NO to use the simplest single word search.  
Choosing a more complex search supercedes selections made for a simple search."
			      :side-effect doc-apropos
			      :boolean))
	 :label "Doc Viewer Apropos"
	 :margin-choices '(("Abort" (SIGNAL-CONDITION eh:*abort-object*))))
      (sys:abort ())
      (:no-error (IF (SETQ return-list
			     (IF multi-word-search
				 (doc-apropos-retrieval (CAR *apropos-list*) manuals types (CADR *apropos-list*))
				 (IF (EQUAL "" target)
				     (PROGN (tv:notify nil "You cannot select NO words to search for.  
No search will be made.")
					    nil)
				     (PROGN
				       (SETf (CAR *apropos-list*) (LIST target))
				       (doc-apropos-retrieval target manuals types place)))))
		   (PROGN
		     (SETQ name
			 (IF multi-word-search
			     (extract-and-execute-item
			       (add-apropos-menu-item return-list manuals types (CAR *apropos-list*) (CADR *apropos-list*)))
			     (extract-and-execute-item
			       (add-apropos-menu-item return-list manuals types target place))))
		   (WHEN (STRINGP name) (doc-viewer-top-level name)))
		   (tv:notify nil "Nothing matched the search list"))
		 )) 
    (VALUES manuals types target place multi-word-search return-list)))

;===============================================================================
;  HISTORY MANIPULATION

(DEFUN update-request-history-item-list (&optional frame)
  (UNLESS frame
    (WHEN (VARIABLE-BOUNDP *window*) (SETQ frame (window-frame *window*))))
  (WHEN frame
    (LET ((history-menu (find-or-make-history-menu frame)))
      (SEND history-menu :update-item-list))))

(DEFUN update-history (node)
  "update the VisiDoc history menu"
  (LET ((item (make-menu-item node)))
    (SETQ *doc-viewer-request-history*
	  (CONS item (REMOVE item *doc-viewer-request-history* :test #'equal)))
    (update-request-history-item-list)))

(DEFUN make-menu-item (node &aux str)
  (LIST (SETQ str (CONCATENATE 'STRING (FORMAT nil "~s " (SEND node :name)) (STRING (SEND node :ref-type))))
        :kbd `(:execute zwei:Doc-Viewer-Top-Level ,(SEND node :name) ,(manual-name node) ,(SEND node :nth))
	:documentation (LIST :mouse-any "go to and expand reference   "
			     :mouse-m-2 "delete reference from history"
			     :no-comma nil
			     :documentation (CONCATENATE 'STRING "<<" str ">>"))))

(DEFUN remove-node-from-history (node)
  "Remove NODE from the VisiDoc history menu"
  (SETQ *doc-viewer-request-history* (remove (make-menu-item node) *doc-viewer-request-history* :test #'equal))
  (update-request-history-item-list))

;===============================================================================
;  LOCATION and RELOCATION FUNCTIONS

(DEFUN find-real-line (node &optional (end? nil))
  "Searches through lines with the :diagram property until the true first or last 
line is found, and returns the line.
NODE is the visidoc viewer interval to use.
END?  T   -- start at the interval's last-bp and search LINE-NEXT.
      NIL -- start at the interval's first-bp and search LINE-PREVIOUS,"
  (IF end?
      (LET ((l (bp-line (interval-last-bp node))))
	(LOOP for ln = l then (line-next ln)
	      until (OR (NULL ln)
			(NOT (EQL (line-node ln) node))
			;;(NOT (GETF (line-plist ln) :diagram))
			)
	      do (SETQ l ln))
	l)
      (LET ((l (bp-line (interval-first-bp node))))
	(LOOP for ln = l then (line-previous ln)
	      until (OR (NULL ln)
			(NOT (EQL (line-node ln) node))
			;;(NOT (GETF (line-plist ln) :diagram))
			)

	      do (SETQ l ln))
	l)))

(DEFUN new-find-line-next (file-start file-end chapter manual name nth
		       &optional (buffer *interval*) (startnode nil) (recursion? nil))
  "Find the bp and surrounding nodes where the reference
in MANUAL pointed to by FILE-START and FILE-END in CHAPTER should be placed in BUFFER.
The five return values are:  
    node instances for the previous, next and superior nodes, respectively;
    the BP where the text denoted by FILE-START and FILE-END should be inserted;
    a list of nodes already in the buffer that are completely contained within FILE-START and FILE-END."
  (LET ((returned-next nil)
	(returned-prev nil)
	(returned-superior nil)
	(inf-list nil)
	bp-next cres)
    (UNLESS startnode
      (DOLIST (inf (node-inferiors buffer))
	(SETQ cres (- (chapter-order (reference-node-chapter inf) manual) (chapter-order chapter manual)))
	(COND ((MINUSP cres)
	       ;;nope, not yet... keep going
	       ())
	      ((ZEROP cres)
	       ;;found the chapter
	       (RETURN (SETQ startnode inf)))
	      ((PLUSP cres)
	       ;;whups! passed the place it shoulda been!
	       (SETQ startnode (add-chapter-node buffer chapter inf (node-previous inf))
		     bp-next (copy-bp (interval-last-bp startnode) :moves))
	       (RETURN-FROM new-find-line-next nil nil startnode bp-next nil))))
      (UNLESS startnode
	(RETURN-FROM new-find-line-next
	  nil nil (SETQ startnode (add-chapter-node buffer chapter nil)) (copy-bp (interval-last-bp startnode)) nil)
	))
    (DOLIST (inf (node-inferiors startnode))
      (UNLESS (OR (EQ :header (ht-node-type inf)) (EQ :ask-superior (reference-node-expanded-p inf)))
      ;;if FILE-END is pointing to a part of the file that is 
      ;;before the section already in the buffer, we're done.
      (COND ((<= file-end (reference-node-start inf))
	     (SETQ returned-superior startnode
		   returned-next inf
		   returned-prev (node-previous inf))
	     (RETURN))
	    ;;pointing to a buffer entry that's completely contained within this new section?
	    ((AND (< (reference-node-end inf) file-end) (< file-start (reference-node-start inf)))
	     (SETQ returned-superior startnode
		   returned-next (PROGN (PUSH inf inf-list)
					(DO ((nxt (node-next inf) (node-next nxt)))
					    ((NULL nxt) (RETURN nil))
					  (IF (<= file-end (reference-node-start nxt))
					      (RETURN nxt)
					      (PUSH-END nxt inf-list))))
		   returned-prev (node-previous inf))
	     (RETURN))
	    ;;If FILE-START and FILE-END are pointing to an entry that is contained within
	    ;;this section already in the buffer, search through the inferiors.
	    ((AND (< file-end (reference-node-end inf)) (< (reference-node-start inf) file-start))
	     (MULTIPLE-VALUE-SETQ (returned-prev returned-next returned-superior bp-next inf-list)
	       (new-find-line-next file-start file-end chapter manual name nth buffer inf t))
	     (RETURN))
	    ;;If FILE-START and FILE-END are pointing to an entry that points to the SAME text,
	    ;;the entry MUST come before or after this new entry.  Figure out which one, and return
	    ;;the appropriate values.
	    ((AND (= file-end (reference-node-end inf)) (= (reference-node-start inf) file-start))
	     (LET ((prevname name)
		   nextname nextnth nresults elist atlist)
	       ;;Look for a match in the NEXT name
	       (LOOP for nextname = (doc-object-next prevname manual nth)
		     then (doc-object-next prevname manual nextnth)
		     until (OR (null nextname)
			       returned-next)
		     do
		     (LOOP for n from 0 to (1- (LENGTH (SETQ elist (entries-alist nextname manual))))
			   when (STRING-EQUAL prevname (doc-object-previous nextname manual n))
			   do (PUSH n nresults))
		     (IF (EQ 1 (LENGTH nresults))
			 (SETQ returned-next (node-in-namespace-p nextname manual (SETQ nextnth (CAR nresults))))
			 (DOLIST (e elist)
			   (SETQ atlist (SECOND e))
			   (WHEN (AND (= (chapter-order (object-attribute-chapter atlist) manual)
					 (chapter-order chapter manual))
				      (= (object-attribute-start atlist) file-start)
				      (= (object-attribute-end atlist) file-end))
			     (RETURN (SETQ nextnth (THIRD e)
					   returned-next (node-in-namespace-p nextname manual nextnth))))))
		     (SETQ prevname nextname))
	       (WHEN returned-next
		 (SETQ returned-superior startnode
		       returned-prev (node-previous returned-next))
		 (RETURN))
	       ;;Not a NEXT?  Then look for a match in the PREVIOUS name
	       (LOOP for prevname = (doc-object-previous (SETQ nextname name) manual nth)
		     then (doc-object-previous nextname manual nextnth)
		     until (OR (null prevname)
			       returned-prev)
		     do
		     (LOOP for n from 0 to (1- (LENGTH (SETQ elist (entries-alist prevname manual))))
			   when (STRING-EQUAL nextname (doc-object-next prevname manual n))
			   do (PUSH n nresults))
		     (IF (EQ 1 (LENGTH nresults))
			 (SETQ returned-prev (node-in-namespace-p prevname manual (SETQ nextnth (CAR nresults))))
			 (DOLIST (e elist)
			   (SETQ atlist (SECOND e))
			   (WHEN (AND (= (chapter-order (object-attribute-chapter atlist) manual)
					 (chapter-order chapter manual))
				      (= (object-attribute-start atlist) file-start)
				      (= (object-attribute-end atlist) file-end))
			     (RETURN (SETQ nextnth (THIRD e)
					   returned-prev (node-in-namespace-p prevname manual nextnth))))))
		     (SETQ nextname prevname))
	       (WHEN returned-prev
		 (SETQ returned-superior startnode
		       returned-next (node-next returned-prev))
		 (RETURN))))) ;;cond
      (WHEN returned-superior (RETURN))))
    (UNLESS returned-superior
      (SETQ returned-superior startnode
	    returned-next nil
	    returned-prev (FIRST (LAST (node-inferiors startnode)))))
    (UNLESS recursion?
      (SETQ bp-next (OR (AND returned-next (create-bp (find-real-line returned-next) 0 :moves))
			(AND returned-prev (create-bp (line-next (find-real-line returned-prev t)) 0 :moves))
			(IF (EQ (interval-first-bp returned-superior) (interval-last-bp returned-superior))
			    (copy-bp (interval-last-bp returned-superior) :moves)
			    (create-bp (line-next (bp-line (interval-last-bp returned-superior))) 0 :moves))))) 
    (VALUES returned-prev returned-next returned-superior bp-next inf-list)))


(defun find-reference (node key &optional known-name)
  "Given a NODE, find its related node based on KEY.
KEY can be either :PREVIOUS, :NEXT, or :SUPERIOR."
  (multiple-value-bind (ignore node)
      (node-expandedp node)
    (let ((manual (manual-name node))
	  (nodename (SEND node :name))
	  (supname (doc-node-superior node))
	  name nth nresults)    
      (case key
	(:previous
	 (UNLESS (SETQ name (OR known-name (doc-node-previous node)))
	   (LOOP until (OR name (NULL nodename))
		 do (WHEN
		      (SETQ nodename (doc-object-superior nodename manual (SEND node :nth)))
		      (SETQ name (doc-object-previous nodename manual 0))))
	   (UNLESS nodename
	     (tv:notify nil "There is no previous reference")
	     (RETURN-FROM find-reference node)))
	   (IF (AND (node-previous node) (STRING-EQUAL (SEND (node-previous node) :name) name))
	     (move-bp (point) (interval-first-bp (expand-reference (node-previous node))))
	     (PROGN 
	       (LOOP for n from 0 to (1- (LENGTH (entries-alist name manual)))
		     when (STRING-EQUAL nodename (doc-object-next name manual n))
		     do (PUSH n nresults))
	       (IF (EQ 1 (LENGTH nresults))
		   (doc-viewer-top-level name manual (CAR nresults))
		   (PROGN
		     (DOLIST (n nresults)
		       (WHEN (STRING-EQUAL supname (doc-object-superior name manual n))
			 (RETURN (SETQ nth n))))
		     (WHEN nth (doc-viewer-top-level name manual nth)))))))
	(:next
	 (UNLESS (SETQ name (OR known-name (doc-node-next node)))
	   (LOOP until (OR name (NULL nodename))
		 do (WHEN
		      (SETQ nodename (doc-object-superior nodename manual (SEND node :nth)))
		      (SETQ name (doc-object-next nodename manual 0))))
	   (UNLESS nodename
	     (tv:notify nil "There is no next reference")
	     (RETURN-FROM find-reference node))) 
	 (IF (AND (node-next node) (STRING-EQUAL (SEND (node-next node) :name) name))
	     (move-bp (point) (interval-first-bp (expand-reference (node-next node))))
	     (PROGN 
	       (LOOP for n from 0 to (1- (LENGTH (entries-alist name manual)))
		     when (STRING-EQUAL nodename (doc-object-previous name manual n))
		     do (PUSH n nresults))
	       (IF (EQ 1 (LENGTH nresults))
		   (doc-viewer-top-level name manual (CAR nresults))
		   (PROGN
		     (DOLIST (n nresults)
		       (WHEN (STRING-EQUAL supname (doc-object-superior name manual n))
			 (RETURN (SETQ nth n))))
		     (WHEN nth (doc-viewer-top-level name manual nth)))))))
	(:superior
	 (IF (SETQ name (OR known-name (doc-node-superior node)))
	     (IF (STRING-EQUAL (SEND (node-superior node) :name) name)
		 (move-bp (point) (interval-first-bp (expand-reference (node-superior node))))
		 (PROGN (LOOP for n from 0 to (1- (LENGTH (entries-alist name manual)))
			      when (MEMBER nodename (doc-object-inferiors name manual n) :test #'STRING-EQUAL)
			      do (PUSH n nresults))
			(IF (EQ 1 (LENGTH nresults))
			    (doc-viewer-top-level name manual (CAR nresults))
			    (tv:notify nil "there is a problem... tell the Doc Viewer person to fix bug named \"oops!\""))))
	     (get-table-of-contents manual)))
	(:inferior
	 (WHEN known-name
	   (LOOP for n from 0 to (1- (LENGTH (entries-alist known-name manual)))
		 when (STRING-EQUAL nodename (doc-object-superior known-name manual n))
		 do (PUSH n nresults))
	   (IF (EQ 1 (LENGTH nresults))
	       (doc-viewer-top-level known-name manual (CAR nresults))
	       (tv:notify nil "there's a problem... multiple inferiors of ~s with name ~s!" nodename known-name))
	   ))
	)))
  (multiple-value-bind (ignore node)
      (node-expandedp (line-node (bp-line (point))))
    node))


(DEFUN move-doc-interval (node prev next bp &optional (sup *interval*))
  "Move the lines and pointers of NODE.  SUP, PREV and NEXT are the node instances of the
new superior, previous and next nodes.  BP is the bp of the line where NODE's lines should
be inserted.  (The lines are inserted before BP.)"
  (LET* ((fline (find-real-line node))
	 (lline (find-real-line node t))
	 (lnext (bp-line bp))
	 (lprev (line-previous lnext))
	 (tlnext (line-next lline))
	 (nsup (node-superior node)))
    ;;Don't do anything if the node is REALLY already where we want it!!!
    ;;(which also means, don't move lines if the first-bp and BP are the same,
    ;;or if BP is somewhere within NODE!)
    (UNLESS (OR (EQ lline lprev) (EQ fline lnext) (EQ node (bp-node bp)))
      (with-read-only-suppressed (*interval*)
	
	(delete-doc-interval node)
	
	;;(without-interrupts
	  (WHEN lprev (SETF (line-next lprev) fline))
	  (psetf (line-previous lnext) lline
		 (line-next lline) lnext
		 (line-previous fline) lprev)
	  (DO ((line (OR lprev fline) (line-next line)))
	      (())
	    (SETF (line-tick line) (tick))
	    (WHEN (EQ line lnext) (RETURN)))));;)
    
  	;;Update the BPs of the old superior
	(LET ((f (SEND nsup :find-first-exposed-inferior))
	      (l (SEND nsup :find-last-exposed-inferior))
	      (p (SEND node :exposed-previous-leaf-node))
	      (n (SEND node :exposed-next-leaf-node)))
	  (WHEN (EQ f (SEND node :find-first-exposed-inferior))
	    (IF n (SEND nsup :change-superiors-first-bp (interval-first-bp n))
		(SEND nsup :change-superiors-first-bp (create-bp tlnext 0 :normal))))
	  (WHEN (EQ l (SEND node :find-last-exposed-inferior))
	    (IF (AND p (SEND p :climb-to-superior nsup))
		(SEND nsup :change-superiors-last-bp (interval-last-bp p))
		(SEND nsup :change-superiors-last-bp (interval-first-bp nsup)))))
    
    (WHEN (node-previous node) (SETF (node-next (node-previous node)) (node-next node)))
    (WHEN (node-next node) (SETF (node-previous (node-next node)) (node-previous node)))
    (SETF (node-inferiors nsup) (DELETE node (node-inferiors nsup))
	  (node-inferiors sup) (insert-before next node (node-inferiors sup))
	  (node-previous node) prev
	  (node-next node) next
	  (node-superior node) sup)
    (WHEN prev (SETF (node-next prev) node))
    (WHEN next (SETF (node-previous next) node))
    (send node :link-and-expose)
    (update-surrounding-bps node)
    ;;update bps of OLD surrounding nodes too!
    ))


(defun update-surrounding-bps (node)
  "Make the bps of this NODE and its neighbors point to the right places"
  (when node
    (let ((prevline (line-previous (bp-line (interval-first-bp node))))
	  (nextline (line-next (bp-line (interval-last-bp node)))))
      (when (AND prevline (NOT (GETF (line-plist prevline) :diagram)))
	(send (line-node prevline) :change-superiors-last-bp
	      (create-bp prevline (length prevline) :normal)))
      (send node :change-superiors-first-bp (interval-first-bp node))
      (send node :change-superiors-last-bp (interval-last-bp node))
      (when (AND nextline (NOT (GETF (line-plist nextline) :diagram))
		 (NOT (TYPEP (line-node nextline) 'zwei-doc-viewer-buffer)))
	(send (line-node nextline) :change-superiors-first-bp
	      (create-bp nextline 0 :moves))))))


;================================================================================
;  DELETION FUNCTIONS

(defun delete-doc-interval (node)
  "Delete all the lines contained within NODE.  Do NOT do anything to
the node's links to other nodes.  Returns the line that used to follow
this node."
  (let* ((first-line (find-real-line node))
	 (last-line (find-real-line node t))
	 (line-next (line-next last-line))
	 (line-prev (line-previous first-line)))
    ;;do something only when there are lines to be deleted
    (unless (bp-= (interval-first-bp node) (interval-last-bp node))
      (with-read-only-suppressed (*interval*)
	(without-interrupts
	  (when line-prev
	    (setf (line-next line-prev) line-next))
	  (WHEN line-next
	    (setf (line-previous line-next) line-prev))
	  (SETF (line-previous first-line) nil
		(line-next last-line) nil))))
    line-next))

;===============================================================================
;  SELECTION and INSERTION FUNCTIONS

(defun pick-the-right-one (fname entry-list &aux menu-item-list elist man)
  "Given the name of an object with multiple entries to choose from,
ask the user to make a selection and extract the NTH and MANUAL of the correct reference.
FNAME is the string name of the object(s).
ENTRY-LIST is either a list of namespace objects, or
ENTRY-LIST is an alist returned by (ENTRIES-ALIST..),.
Returns multiple values: the NTH position of the selected item from the object's (ENTRIES-ALIST..) value,
and the MANUAL of the chosen object if ENTRY-LIST is a list of namespace-objects and LIST-OF-OBJECTS-P is T)." 
  (declare (inline object-attribute-superior object-manual-name))
  (COND ((CONSP (CAR entry-list))
	 (dolist (attribute entry-list)
	   (push-end `(,(FORMAT nil "~a~:[ ~; under ~:*~a~:;~]"
				(FIRST attribute) (object-attribute-superior (SECOND attribute)))
		       :value ,(THIRD attribute)) menu-item-list)))
	(t (DOLIST (obj entry-list)
	     (SETQ elist (entries-alist fname (SETQ man (object-manual-name obj))))
	     (dolist (attribute elist)
	       (push-end `(,(FORMAT nil "~a~:[ ~; under ~:*~a ~:;~]in the ~a manual"
				    (FIRST attribute) (object-attribute-superior (SECOND attribute)) man)
			   :value (,(THIRD attribute) ,man)) menu-item-list)))))
  (multiple-value-bind (choice ignore)
      (w:menu-choose
	menu-item-list
	:label
	(format nil "The name ~s has multiple references. ~%Please choose one of the following:" fname))
    (IF (CONSP choice)
	(VALUES (FIRST choice) (SECOND choice))
	choice)))


(DEFUN choose-a-node (node-list &aux (menu-list nil))
  "returns the node instance from NODE-LIST that a user selects from a menu-choose."
  (w:menu-choose (PROGN (DOLIST (n node-list) 
			  (push-end `(,(FORMAT nil "~a~:[ ~; under ~:*~a ~:;~]in the ~a manual"
					       (reference-node-ref-type n) (doc-node-superior n) (manual-name n))
				      :value ,n) menu-list))
			menu-list)
		 :label (FORMAT nil "~s has multiple entries.~%Please choose one of the following:"
				(SEND (CAR node-list) :name))))
	   

(DEFUN select-buffer-and-expand-node (node)
  "Select the buffer associated with NODE, expand and expose NODE if necessary, and
position (point) to the first BP of NODE."
  (doc-viewer-select-buffer (manual-name node) (send node :climb-to-buffer))
  (MULTIPLE-VALUE-BIND (EXP? node)
      (node-expandedp node)
    (update-history node)
    (IF exp? (SEND node :link-and-expose) (expand-reference node))
    (move-bp (point) (interval-first-bp node))
    (redisplay *window* :start (point) nil t)
    (show-page node)))


(defun insert-and-select (fname entry-list nth ref-list manual buffer)
  "Insert a reference for FNAME into BUFFER.
FNAME is the string name of what we want displayed in the document viewer buffer.
ENTRY-LIST is the list returned by GET-STUFF-FROM-DOC-SERVER.
NTH is the position within the (ENTRIES-ALIST..) that points to ENTRY-LIST.
REF-LIST is the list of strings and inferior objects contained within FNAME.
MANUAL is the name of the manual that contains FNAME, or NIL.
BUFFER is the buffer instance associated with MANUAL, or NIL.
***MANUAL and BUFFER should not both be NIL***"
  (let (reference-node)
    (if buffer
	(doc-viewer-select-buffer nil buffer)
	(doc-viewer-select-buffer manual nil (manual-fonts manual)))
    (setf reference-node (put-contracted-reference-in-viewer fname entry-list nth ref-list *interval*))
    ;;;Here's where we update the local namespace with the buffer node object
    (store-node-in-namespace reference-node)
    (update-history reference-node)
    (move-bp (point) (interval-first-bp reference-node))
    (redisplay *window* :start (point) nil t)
    (show-page reference-node)))

(defun add-chapter-node (buffer chapter-number next-chapt &optional prev-chapt &aux inf)
  "Add a node for CHAPTER-NUMBER linked in the correct order in the BUFFER instance.
If NEXT-CHAPT is non-nil, it is the reference-node instance that should follow the new chapter. "
  (let* ((line-next (bp-line (or (and next-chapt 
				      (setq inf (or (send next-chapt :find-first-exposed-inferior)
						    (send next-chapt :exposed-next-leaf-node)
						    next-chapt))
				      (interval-first-bp inf))
 				 (copy-bp (interval-last-bp buffer)))))
	 (new-chapter (make-instance 'reference-node)))
    (SETQ prev-chapt (OR prev-chapt
			 (and next-chapt (node-previous next-chapt))
			 (car (last (send buffer :inferiors)))))
    (setf (ht-node-name new-chapter) chapter-number
	  (reference-node-chapter new-chapter) chapter-number
	  (interval-first-bp new-chapter) (create-bp line-next 0 :normal)
	  (interval-last-bp new-chapter) (create-bp line-next 0 :moves)
	  (node-superior new-chapter) buffer
	  (node-inferiors buffer) (insert-before next-chapt new-chapter (send buffer :inferiors))
	  (node-next new-chapter) next-chapt
	  (node-previous new-chapter) prev-chapt
	  (reference-node-start new-chapter) 0
	  (reference-node-end new-chapter) most-positive-fixnum
	  (reference-node-ref-type new-chapter) :unbound
	  (ht-node-exposed-p new-chapter) nil)
    (when prev-chapt (setf (node-next prev-chapt) new-chapter))
    (when next-chapt (setf (node-previous next-chapt) new-chapter))
    new-chapter))


(DEFUN splice-lines (at-line fline &optional lline node)
  "Insert a set of linked lines  before AT-LINE.
FLINE points to the first line to be linked.
LLINE optionally points to the last line to be linked.
If LLINE is NIL, the last line is found by traversing links 
from FLINE until the (line-next..) array leader is NIL.
NODE optionally specifies the node owner of the lines.
No meaningful value is returned, and NO BP HACKING OCCURS."
  (unless lline (setq lline (do ((line fline (line-next line)))
				((eq (line-next line) nil) (return line))
			      ()))) 
  (let ((lprev (line-previous at-line)))
    (when lprev (setf (line-next lprev) fline))
    (setf (line-previous at-line) lline
	  (line-next lline) at-line
	  (line-previous fline) lprev)
    
    (do ((line fline (line-next line)))
	((eq line at-line) (return)) 
      (setf (line-tick line) (tick)
	    (line-node line) node))))
	    

(defun insert-string-into-node (node bp-next text)
  "Insert TEXT at buffer position BP-NEXT in NODE.
Returns buffer pointers to the beginning and end of the inserted text."
  (let ((saved-bp (copy-bp bp-next :normal))
	(moved-bp (copy-bp bp-next :moves))
	firstline lastline)
    (with-read-only-suppressed (*interval*) 
      (with-editor-stream
	(buffer-stream :interval node :start moved-bp :hack-fonts t)
	(send buffer-stream :string-out text)
	(unless (or (string-equal "" text)
		    (eql #\newline (aref text (1- (length text)))))
	  (terpri buffer-stream))))
    (setf firstline (bp-line saved-bp)
	  lastline (bp-line moved-bp))
    (do ((line firstline (line-next line)))
	((eq line lastline) (return)) 
      (setf (line-node line) node
	    (line-tick line) (tick)))
    (COND ((EQL 0 (LENGTH text))
	   (VALUES saved-bp moved-bp))
	  ((GETF (line-plist (line-previous (bp-line moved-bp))) :diagram)
	   (VALUES saved-bp (create-bp (line-previous (bp-line moved-bp)) (LENGTH (bp-line moved-bp)) :moves)))
	  (t
	   (values saved-bp (dbp moved-bp t))))))


(defun insert-before (before-entity entity insert-list)
  "Inserts ENTITY into a copy of INSERT-LIST before the first occurrence of BEFORE-ENTITY.
If BEFORE-ENTITY is NIL or not a member of INSERT-LIST, ENTITY is appended onto the end of
the returned list.
The second value returned is the position index for ENTITY in the returned list."
  (let* ((returnlist (copy-list insert-list))
	 (pos (position before-entity returnlist :test #'equal)))
    (if (null pos)
	(progn (setq returnlist (append returnlist (list entity)))
	       (setq pos (1- (length returnlist))))
	(setq returnlist (append (subseq returnlist 0 pos)
				 (cons entity (subseq returnlist pos)))))
  (values returnlist pos)))


(defun insert-file-reference (fname text-string node-type prev-node next-node bp-next &optional (superior *interval*))
  "Returns the new interval/node that just had the TEXT-STRING for FNAME displayed within.
FNAME is a symbol or a string that becomes the NAME of the node.
TEXT-STRING is the string of text for FNAME.
NODE-TYPE is a keyword (either :contents, :header, or :superior).
PREV-NODE is the node instance that comes before this node.
NEXT-NODE is the node instance that comes after this node.
BP-NEXT is the BP of the line that is to follow this new node.
SUPERIOR is the instance of the node that completely contains this new sub-node.
     (default is *INTERVAL*). "
  (setq fname (or (and (symbolp fname) (string fname)) fname))
  (let* ((refnode (make-instance 'reference-node
				 :name fname
				 :superior superior
				 :type node-type)))
    
    ;;Do node linking here. That means:
    ;;   link NEXT-NODE and REFNODE (if any), and
    ;;   link REFNODE and PREV-NODE (if any);
    ;;   add REFNODE to the list of SUPERIOR's inferiors.
    (WHEN next-node
      (SETF (node-previous next-node) refnode
	    (node-next refnode) next-node))
    (WHEN prev-node
      (SETF (node-previous refnode) prev-node
	    (node-next prev-node) refnode))
    (setf (node-inferiors superior) (insert-before next-node refnode (node-inferiors superior)))

    ;;Set up the bp's for the new reference node, and insert the text string into
    ;;the right place...
    (multiple-value-bind (firstbp lastbp)
	(insert-string-into-node refnode bp-next text-string)
      (setf (interval-first-bp refnode) (copy-bp firstbp :normal)
	    (interval-last-bp refnode) (copy-bp lastbp :moves)))
    ;;...then update bps. 
    (update-surrounding-bps refnode)
    refnode))


(DEFUN make-grandchildren (node infs)
  "A generalized way to move INFS that are indirect inferiors of NODE into the correct hierarchical position."
  ;;First, sort and remove nodes that may now be direct descendants of NODE
  (LET* ((nodes-to-move (SORT (REMOVE-IF #'(lambda (x) (OR (EQ (node-superior x) node) (EQ x node))) infs)
			      #'< :key #'reference-node-start))
	 (move (CAR nodes-to-move))
	 (more-to-move nil)
	 start end)
    (DOLIST (n (node-inferiors node))
      ;;If no more nodes to move, EXIT
      (COND ((NULL nodes-to-move)
	     (RETURN))
	    ;;If the inferior comes before all the nodes to move,
	    ;;or this inferior is a HEADER, go to the next inferior
	    ((OR (EQ :header (ht-node-type n))
		 (<= (SETQ end (reference-node-end n)) (reference-node-start move)))
	     ())
	    ;;If the nodes are EQ, then go to the NEXT node in each list
	    ;;(this should only happen if the sort procedure didn't work correctly)
	    ;;Also, if we get this far, the node linking is messed up... if MOVE is
	    ;;in the inferiors list, the only way we get to this point is if MOVE does
	    ;;not point to NODE yet.
	    ((EQ n move)
	     (SETF (node-superior move) node)
	     (SETQ nodes-to-move (CDR nodes-to-move)
		   move (CAR nodes-to-move)))
	    ;;If node to move is BEFORE this inferior, link it here
	    ;;(this case is should only be possible during a recursive call)
	    ((<= (reference-node-end move) (SETQ start (reference-node-start n)))
	     (LOOP while (AND nodes-to-move
			      (<= (reference-node-end move) start))
		   do (PROGN (move-doc-interval
			       move (node-previous n) n (copy-bp (interval-first-bp n) :moves) n)
			     (SETQ nodes-to-move (CDR nodes-to-move)
				   move (CAR nodes-to-move)))))
	    ;;This is the case where nodes actually become grandchildren
	    (t
	     ;;If this inferior has inferiors, the nodes to move may REALLY be GREAT-grandchildren!!!
	     (IF (AND (node-inferiors n) (REMOVE-IF #'(lambda (x) (OR (EQ (ht-node-type x) :header)
								      (EQ (ht-node-type x) :contents)))
						    (node-inferiors n)))
		 (PROGN (LOOP while (AND nodes-to-move
					 (<= start (reference-node-start move))
					 (<= (reference-node-end move) end))
			      do (PROGN (PUSH-END move more-to-move)
					(SETQ nodes-to-move (CDR nodes-to-move)
					      move (CAR nodes-to-move))))
			(make-grandchildren n more-to-move))
		 ;;else, make grandchildren 
		 (LOOP while (AND nodes-to-move
				  (<= start (reference-node-start move))
				  (<= (reference-node-end move) end))
		       do (PROGN
			    (move-doc-interval
			      move (CAR (LAST (node-inferiors n))) nil
			      (create-bp (line-next (find-real-line n t)) 0 :moves) n)
			    (SETQ nodes-to-move (CDR nodes-to-move)
				  move (CAR nodes-to-move)))))) 
	    ))
    ;;If there are any nodes left, they should be siblings.
    ;;(again, this should only even be possible during a recursive call)
    (WHEN nodes-to-move
      (LOOP while nodes-to-move
	    do (PROGN (move-doc-interval
			move (CAR (LAST (node-inferiors node))) nil
			(create-bp (line-next (find-real-line node t)) 0 :moves) node) 
		      (SETQ nodes-to-move (CDR nodes-to-move)
			    move (CAR nodes-to-move)))))))


(DEFUN insert-inferiors (sup list-of-references ret-next bp-next &optional node-type)
  "Insert all the inferior nodes of SUP, and link them properly.
SUP is a node instance that is the SUPERIOR of all these inferiors.
LIST-OF-REFERENCES is a list of strings and lists where these lists are pairs of namespace
   objects and an integer representing the NTH entry in that object's (ENTRIES-ALIST..)
   that goes to this pariticular node.
RET-NEXT is the node instance of the leaf that should come after all the subordinates, or NIL.
BP-NEXT is the BP before which lines should be inserted."
  (DECLARE (inline object-name object-attribute-start object-attribute-end))
  (LET ((chapter-num (reference-node-chapter sup))
	(fname (SEND sup :name))
	(NTH (reference-node-nth sup))
	(max-nth (reference-node-max-nth sup))
	(manual (manual-name sup))
	(ref-type (reference-node-ref-type sup))
	inf-refnode inf-name prev-inf entry-list e-list)
    (IF (OR (STRINGP list-of-references)
	    (AND (= 1 (LENGTH list-of-references))
		 (STRINGP (CAR list-of-references))
		 (SETQ list-of-references (CAR list-of-references))))
	(PROGN
	  (SETQ inf-refnode (insert-file-reference
				   (STRING-UPCASE fname) list-of-references (OR node-type :contents)
				   prev-inf ret-next bp-next sup))
	  (SETF (reference-node-chapter inf-refnode) chapter-num
		     (reference-node-expanded-p inf-refnode) :ask-superior
		     (ht-node-exposed-p inf-refnode) T
		     (reference-node-start inf-refnode) (reference-node-start sup)
		     (reference-node-end inf-refnode) (reference-node-end sup)
		     (reference-node-ref-type inf-refnode) ref-type
		     (reference-node-max-nth inf-refnode) max-nth
		     (reference-node-nth inf-refnode) nth)
	  (update-surrounding-bps inf-refnode))
      (DOLIST (ref list-of-references)
	(FORMAT *query-io* "..")
	(COND ((STRINGP ref)
	       (SETQ inf-refnode (insert-file-reference
				   (format nil "text for ~s" fname) "" :superior
				   prev-inf ret-next bp-next sup))
	       (SETF (reference-node-chapter inf-refnode) chapter-num
		     (reference-node-expanded-p inf-refnode) :ask-superior
		     (ht-node-exposed-p inf-refnode) T
		     (reference-node-start inf-refnode) (OR (AND prev-inf (reference-node-end prev-inf))
							    (reference-node-start sup))
		     (reference-node-end inf-refnode) (+ (reference-node-start inf-refnode) (1- (LENGTH ref)))
		     (reference-node-ref-type inf-refnode) ref-type
		     (reference-node-max-nth inf-refnode) max-nth
		     (reference-node-nth inf-refnode) nth)
	       (insert-inferiors inf-refnode ref ret-next bp-next (OR node-type :contents)))
	      ((CONSP ref)
	       (SETF inf-name (STRING-UPCASE (object-name (CAR ref))))
	       (COND ((SETQ inf-refnode
			    (node-in-namespace-p inf-name manual (SECOND ref)))
		      (move-doc-interval inf-refnode prev-inf nil bp-next sup))
		     (t
		      (SETQ entry-list (entries-alist inf-name manual)
			    e-list (NTH (SECOND ref) entry-list))
		      (SETF
			inf-refnode (insert-file-reference inf-name "" :superior
							   prev-inf ret-next bp-next sup)
			(reference-node-chapter inf-refnode) chapter-num
			(reference-node-expanded-p inf-refnode) nil
			(ht-node-exposed-p inf-refnode) T
			(reference-node-start inf-refnode) (object-attribute-start (SECOND e-list))
			(reference-node-end inf-refnode) (object-attribute-end (SECOND e-list))
			(reference-node-ref-type inf-refnode) (FIRST e-list)
			(reference-node-max-nth inf-refnode) (1- (LENGTH entry-list))
			(reference-node-nth inf-refnode) (SECOND ref))
		      (insert-inferiors inf-refnode
					  (make-fat-string 
						(FORMAT nil "<<~s ~a>>" inf-name (first e-list))
						(OR (POSITION *contracted-line-font*
							      (LISTARRAY (SEND *window* :font-map))) 0))
					nil bp-next :header)
		      (store-node-in-namespace inf-refnode))))
	      (t (FORMAT t "~%There's a REAL problem here... ~%the reference is ~a~%it's superior is ~a~%"
			 ref sup)))
	(update-surrounding-bps inf-refnode)
	(SETQ prev-inf inf-refnode)))))

;================================================================================
;  EXPANSION FUNCTIONS
(defun expand-reference (node &aux lnext filepos)
  "Given a reference NODE, display the text that is associated with it."
  (DECLARE (inline object-attribute-start object-attribute-end))
  (MULTIPLE-VALUE-BIND (expanded? snode)
      (node-expandedp node)
    (UNLESS expanded?
      (FORMAT *query-io* "~&Expanding text for ~s" (ht-node-name snode))
      (SETQ lnext (delete-doc-interval snode))
      (SEND snode :mark-as-deexposed)
      (SETF (reference-node-expanded-p snode) t)
      (IF (PROGN (SETQ filepos (reference-node-start snode))
		 (DOLIST (inf (node-inferiors snode))
		   (UNLESS (EQ :header (ht-node-type inf))
		     (IF (<= (reference-node-start inf) (1+ filepos))
			 (SETQ filepos (reference-node-end inf))
			 (RETURN (SETQ filepos nil)))))
		 (UNLESS (AND filepos (<= (reference-node-end snode) (1+ filepos)))
		   (SETQ filepos nil))
		 filepos)
	  (SEND snode :link-and-expose)
	  ;;All the text is not in the buffer...
	  ;;get and insert it in contracted form. 
	  (LET* ((object-list (get-stuff-from-doc-server (ht-node-name snode)
							 :manual (manual-name snode)
							 :nth (reference-node-nth snode)
							 :forced-get t))
		 (list-of-references (FOURTH object-list))
		 (bp-next (create-bp lnext 0 :moves))
		 (potential-grandchildren nil)
		 (inf-list nil)) 
	    (insert-inferiors snode list-of-references nil bp-next)
	    ;;Now, find any nodes that should be GRANDCHILDREN that are
	    ;;still in the hierarchy as siblings.
	    (DOLIST (sib (REMOVE-IF #'(lambda (x) (OR (EQ (ht-node-type x) :header)
						      (EQ (ht-node-type x) :contents)
						      (EQ x snode)))	;;don't check against yourself 09-01-88 DAB SB
				    (node-inferiors (node-superior snode))))
	      (LET ((superior-children (object-attribute-children
					 (SECOND (NTH (reference-node-nth (node-superior snode))
						      (entries-alist (ht-node-name (node-superior snode))
                                                                     (manual-name snode))))))) 

		(WHEN (AND ;;(NOT (EQ sib snode))
			   (NOT (MEMBER (ht-node-name sib) superior-children :test #'string-equal))
			   (<= (reference-node-start snode) (reference-node-start sib))
			   (<= (reference-node-end sib) (reference-node-end snode)))
		  (PUSHNEW sib potential-grandchildren))))
	    ;;Now, find any nodes that should be GREAT-GRANDCHILDREN that are
	    ;;still in the hierarchy as children.
	    (SETQ inf-list (REMOVE-IF #'(lambda (x) (OR (EQ (ht-node-type x) :header)
							(EQ (ht-node-type x) :contents)))
				    (node-inferiors snode)))
	    (DOLIST (c inf-list)
	      (DOLIST (n inf-list)
		(WHEN (AND (NOT (eq c n))
			   (<= (reference-node-start n) (reference-node-start c))
			   (<= (reference-node-end c) (reference-node-end n))
			   (not (and (= (reference-node-start n) (reference-node-start c)) ;09-12-88 DAB and not the same.
				     (= (reference-node-end c) (reference-node-end n))))
			   )
		  
		  (PUSHNEW c potential-grandchildren))))
	    (WHEN potential-grandchildren 
	      (DOLIST (n potential-grandchildren)
		(DELETE n (node-inferiors snode))
		(WHEN (node-next n) (SETF (node-previous (node-next n)) (node-previous n)))
		(WHEN (node-previous n) (SETF (node-next (node-previous n)) (node-next n)))
		(SETF (node-next n) nil
		      (node-previous n) nil
		      (node-superior n) (node-superior snode)))
	      (make-grandchildren snode potential-grandchildren)))))
    snode))


;================================================================================
;  CONTRACTION FUNCTIONS

(defun put-contracted-reference-in-viewer (fname entries-alist nth list-of-references buffer)
  "Places the contents of the doc-viewer namespace for the string FNAME into
the buffer instance BUFFER in contracted form.
OBJECT is the namespace object.
NTH is the number within the attribute list that refers to the contents of FNAME.
LIST-OF-REFERENCES is the list of text strings and pointers to
     subordinate references within FNAME's definition."
  (declare (inline object-attribute-end object-attribute-chapter object-attribute-start))
  (let* ((*interval* buffer)
	 (attributes (nth nth entries-alist))
	 (chapter-num (object-attribute-chapter (second attributes)))
	 (startptr (object-attribute-start (SECOND attributes)))
	 (endptr (object-attribute-end (second attributes)))
	 (manual (SEND buffer :namespace-name))
	 refnode bp-next inf-list ret-next ret-prev ret-superior)
    ;;Find the place to insert this reference
    (MULTIPLE-VALUE-SETQ (ret-prev ret-next ret-superior bp-next inf-list)
      (new-find-line-next startptr endptr chapter-num manual fname nth))
    (SETQ bp-next (copy-bp bp-next :moves))
    (setf refnode (insert-file-reference (STRING-UPCASE fname) "" :superior
					 ret-prev ret-next bp-next ret-superior))
    (setf 
      (reference-node-chapter refnode) chapter-num
      (reference-node-end refnode) endptr
      (reference-node-start refnode) startptr
      (reference-node-expanded-p refnode) T
      (reference-node-ref-type refnode) (first attributes)
      (ht-node-exposed-p refnode) T
      (reference-node-nth refnode) nth
      (reference-node-max-nth refnode) (1- (LENGTH entries-alist))
      )
    (FORMAT *query-io* "~&Inserting text for ~s" (STRING-UPCASE fname))
    (insert-inferiors refnode list-of-references ret-next bp-next)
    (WHEN inf-list (make-grandchildren refnode inf-list))
    (update-surrounding-bps refnode) 
    refnode))


(DEFUN contract-reference (node &aux flag lnext)
  "Given a reference NODE, contract the text that is associated with it."
  (MULTIPLE-VALUE-BIND (expanded? snode)
      (node-expandedp node)
  (when expanded?
      (FORMAT *query-io* "~&Contracting text for ~s" (ht-node-name snode))
    ;;There should be a (without-interrupts.. form wrapped around this code
    (with-read-only-suppressed (*interval*)
      (SETQ lnext (delete-doc-interval snode))
	(SEND snode :mark-as-deexposed)
	(SETF (reference-node-expanded-p snode) nil)
	(SETQ flag nil)
	(DOLIST (inf (node-inferiors snode))
	  (WHEN (EQ :header (ht-node-type inf))
	    (SEND inf :link-and-expose)
	    (RETURN (SETQ flag t))))
	(UNLESS flag
	  (insert-inferiors snode (make-fat-string
				    (FORMAT nil "<<~s ~a>>" (ht-node-name snode)
					    (reference-node-ref-type snode))
				    (OR (POSITION *contracted-line-font*
						  (LISTARRAY (SEND *window* :font-map))) 0))
			    (CAR (node-inferiors snode)) (create-bp lnext 0 :moves) :header))
	(update-surrounding-bps snode)))
  snode))


;================================================================================
;  SYSTEM SYMBOL DOCUMENTATION FUNCTIONS

(defun doc-viewer-describe-variable-internal (var &optional stream)
  (let* ((decl (getl var '(special compiler::system-constant)))
	 (bound (boundp var))
	 (doc (documentation var 'variable))
	 (stream (if doc stream *query-io*)))
    (cond ((or decl bound doc)
	   (format stream "~&~s has ~:[no~;a~] value" var bound)
	   (if (eq (car decl) 'special)
	       (format stream " and is declared special ~:[by file ~a~]" (eq (cadr decl) t)
		       (cadr decl)))
	   (if (eq (car decl) 'compiler::system-constant)
	       (format stream " and is a system-constant"))
	   (if doc (format stream "~%~a" doc)) t))))


(defun doc-viewer-long-documentation (fname &optional (stream t))
   "Print long documentation for the specified function.
Reads the name of the function from the mini-buffer (the default is
the \"current\" function from the buffer) and displays the
function's arguments and documentation"  ;OREN/STENGER. Patched in by gsl
   (let (doc temp)
     (cond-every ((functionp fname t)
		  (multiple-value-bind (args return macro-p) (arglist fname)
		    (if (setq temp (get fname 'si::defstruct-slot))
			(format stream "~%~s is a defstruct accessor macro for ~s" fname (car temp))
			(format stream "~%~s is a ~:[function~;macro~]" fname macro-p))
		    (format stream "~%arguments  ~a~%" args)
		    (when return
		      (format stream "returns  ~{~a  ~}~%" return)))
		  (when (setq doc (documentation fname))
		    (format stream "~a~%" doc)))
		 ((setq temp (get fname 'si:flavor))
		  (format stream "~%~s is a flavor~%" fname)
		  (when (and (setq temp (si:flavor-plist temp))
			     (setq doc (second (member :documentation temp :test #'eq))))
		    (format stream "~a~%" doc)))
		 ((setq temp (get fname 'si::defstruct-description))
		  (format stream "~%~s is a structure~%" fname)
		  (when (and (setq temp (si::defstruct-description-property-alist temp))
			     (setq doc (rest (assoc :documentation temp :test #'eq))))
		    (format stream "~a~%" doc)))
		 ((and (setq temp (get fname :documentation)) (neq doc temp))
		  (format stream "~%~s is a ~a~%" fname (type-of fname))
		  (format stream "~a~%" temp))
		 ((and (symbolp fname) (boundp fname))
		  (format stream "~%~s is a variable" fname)
		  (doc-viewer-describe-variable-internal fname stream)
		  (if (consp (setq temp (symbol-value fname)))
		      (format stream "~%value is a ~a~%" (type-of temp))
		      (format stream "~%value is ~s~%" temp))
		  (when (setq doc (get fname :value-documentation))
		    (format stream "~a~%" doc)))
		 ((setq temp (get fname 'eh::make-condition-function))
		  (format stream "~%~s is an ~:[undocumented ~]error condition~%" fname
			  (setq doc (documentation temp)))
		  (when doc
		    (format stream "~a~%" doc)))
		 (otherwise (format stream "~&~s was not found." fname)))
     (FORMAT stream "~%~%")
     (FORMAT stream w:*remove-typeout-standard-message*)))

;===============================================================================
;  TABLE OF CONTENTS

(DEFUN get-table-of-contents (&optional manual &aux manual-list)
  "Put the top level topics of MANUAL in a buffer.  
If MANUAL is NIL or not valid, pull up a menu of the online documents 
and have the user select a name."
  (SETQ manual-list (list-of-manuals))
    (UNLESS (memeq manual manual-list)
      (SETQ manual (w:menu-choose manual-list :label "Get the table of contents ~%for which manual?"
				  :item-alignment :center :columns 1)))
      (WHEN manual
	(doc-viewer-select-buffer manual nil (manual-fonts manual))
	(LET ((buffer *interval*)
	      (object-list (table-of-contents manual))
	      (prev-inf nil)
	      (inf-list nil))
	  (SEND buffer :revert)
	  (SEND *query-io* :clear-screen)
	  (FORMAT *query-io* "~&Retrieving Table of Contents for ~a manual" manual)
	  (DOLIST (item object-list)
	    (LET* ((object (CAR item))
		   (nth (SECOND item))
		   (name (STRING-UPCASE (object-name object)))
		   (entry-list (entries-alist name manual))
		   (attributes (nth nth entry-list))
		   (chapter-num (object-attribute-chapter (second attributes)))
		   (startptr (object-attribute-start (SECOND attributes)))
		   (endptr (object-attribute-end (second attributes)))
		   (manual (SEND buffer :namespace-name))
		   refnode bp-next ret-next ret-prev ret-superior
		   tinfs)
	      (FORMAT *query-io* "..")
	      (IF (SETQ refnode (node-in-namespace-p name manual nth))
		  (SEND refnode :link-and-expose)
		  ;;Find the place to insert this reference
		  (MULTIPLE-VALUE-SETQ (ret-prev ret-next ret-superior bp-next inf-list)
		    (new-find-line-next startptr endptr chapter-num manual name nth))
		  (SETQ bp-next (copy-bp bp-next :moves))
		  (COND
		    ((SETQ tinfs (node-inferiors ret-superior))
		     (SETF (node-inferiors ret-superior) nil
			   refnode (insert-file-reference name "" :superior
							  prev-inf nil bp-next ret-superior)
			   (reference-node-chapter refnode) chapter-num
			   (reference-node-expanded-p refnode) nil
			   (ht-node-exposed-p refnode) T
			   (reference-node-start refnode) startptr
			   (reference-node-end refnode) endptr
			   (reference-node-ref-type refnode) (FIRST attributes)
			   (reference-node-max-nth refnode) (1- (LENGTH entry-list))
			   (reference-node-nth refnode) nth
			   (node-inferiors refnode) tinfs)
		     (DOLIST (inf tinfs)
		       (SETF (node-superior inf) refnode))
		     (insert-inferiors refnode
				       (LIST (make-fat-string 
					       (FORMAT nil "<<~s ~a>>" name (FIRST attributes))
					       (OR (POSITION *contracted-line-font*
							     (LISTARRAY (SEND *window* :font-map))) 0)))
				       (CAR (node-inferiors refnode))
				       (interval-first-bp (SEND refnode :find-first-exposed-inferior)) ;;bp-next
				       :header)
		     (SEND refnode :change-superiors-first-bp
			   (interval-first-bp (SEND refnode :find-first-exposed-inferior)))
		     (SEND refnode :change-superiors-last-bp
			   (interval-last-bp (SEND refnode :find-last-exposed-inferior)))
		     (store-node-in-namespace refnode))
		    (t 
		     (SETF
		       refnode (insert-file-reference name "" :superior
						      prev-inf nil bp-next ret-superior)
		       (reference-node-chapter refnode) chapter-num
		       (reference-node-expanded-p refnode) nil
		       (ht-node-exposed-p refnode) T
		       (reference-node-start refnode) (object-attribute-start (SECOND attributes))
		       (reference-node-end refnode) (object-attribute-end (SECOND attributes))
		       (reference-node-ref-type refnode) (FIRST attributes)
		       (reference-node-max-nth refnode) (1- (LENGTH entry-list))
		       (reference-node-nth refnode) nth)
		     (insert-inferiors refnode
				       (LIST (make-fat-string 
					       (FORMAT nil "<<~s ~a>>" name (FIRST attributes))
					       (OR (POSITION *contracted-line-font*
							     (LISTARRAY (SEND *window* :font-map))) 0)))
				       nil bp-next :header)
		     (store-node-in-namespace refnode))))
	      (update-surrounding-bps refnode)
	      (SETQ prev-inf refnode)
	      (WHEN inf-list (make-grandchildren refnode inf-list)))))))


 
;===============================================================================
;  TOP LEVEL FUNCTION

(defun doc-viewer-top-level (fname &optional (manual nil) (nth nil) &aux index)
  "Top level function to enter the Document Server.  
FNAME is the name of what we want to document.
MANUAL is the keyword (ie. :LISP, :IO, :WINDOWS) identifying the manual in which FNAME is found.
NTH is the index into the list returned from the (ENTRIES-ALIST) function for FNAME."
  (DECLARE (inline object-manual-name))
  (PKG-BIND (FIND-PACKAGE 'zwei)	;;prevent wierdness when constructing diagram lines
    (SETQ FNAME (STRING-UPCASE (STRING-TRIM '(#\SPACE) FNAME)))
    (WHEN (AND (SETQ index (STRING-SEARCH-SET '(#\:) fname))
	       (<  0 index)
	       (FIND-PACKAGE (READ-FROM-STRING fname t nil :end index)))
      (SETQ fname (SUBSEQ fname (1+ index))))
    (LET* ((info-list (get-stuff-from-doc-server fname :manual manual :nth nth))
	   object buffer node key)
      ;;Get-stuff-from-doc-server returns a list where the CAR is a keyword,
      ;;and the CDR is one of five values:
      ;;
      ;;    keyword                          rest of list
      ;;   --------              -----------------------------------------------------------------------
      ;;1) :NODE                 a node instance if nth was specified and that reference has been created before
      ;;2) :NODES                a list of nodes if ALL multiple references for a manual have been viewed before
      ;;3) :ITEM                 a list of the object, its nth position in the name's own (ENTRIES-ALIST..) 
      ;;                           value, and a list of lists of subordinate object and nth pairs
      ;;4) :MULTIPLE-ATTRIBUTES  a list of the object, and the object's (ENTRIES-ALIST..) value
      ;;5) :MULTIPLE-OBJECTS     a list of the OBJECTS
      ;;
      ;;   A return value of NIL means no object was found.
      
      (SETQ key (CAR info-list)
	    info-list (CDR info-list))
      ;;If there is no entry, go to the local machine and pull up any internal documentation.
      (CASE key
	(NIL
	 (format t "~%~%There is no on-line Manual Documentation for ~a~%" fname)
	 (if (position #\space (the string fname) :test #'CHAR=)
	     (format t "~&~s was not found~%" fname)
	     (doc-viewer-long-documentation (READ-FROM-STRING (STRING fname)))))
	;;;This is a BRAND NEW ENTRY and needs to be put into a node 'n linked 'n stuff.
	(:item
	 (SETQ object (CAR info-list)
	       manual (OR manual (object-manual-name object))
	       buffer (find-doc-viewer-buffer-named manual))
	 (insert-and-select fname (entries-alist fname manual) (SECOND info-list) (THIRD info-list) manual buffer))
	;;A single node was returned
	(:node
	 (select-buffer-and-expand-node (CAR info-list)))
	;;;All references have been pulled into the doc viewer before.
	;;;Do something to pick and go to the right node.
	(:nodes
	 (SETQ info-list (CAR info-list))
	 (IF (< 1 (LENGTH info-list))
	     (WHEN (SETQ node (choose-a-node info-list)) (select-buffer-and-expand-node node))
	     (select-buffer-and-expand-node (CAR info-list))))
	;;;There are multiple references
	(:multiple-attributes
	 (SETQ nth (pick-the-right-one fname (SECOND info-list)))
	 (WHEN nth (doc-viewer-top-level fname (object-manual-name (CAR info-list)) nth)))
	;;There are multiple OBJECTS!!!
	(:multiple-objects
	 (MULTIPLE-VALUE-SETQ (nth manual)
	   (pick-the-right-one fname (CAR info-list)))
	 (WHEN (AND manual nth) (doc-viewer-top-level fname manual nth)))
	))
    dis-none))