;;; -*- Mode: Common-Lisp; Package: Zwei; Base: 10.; Patch-File: T -*-

;;; Reason: Fixes to expand-reference and find-reference to handle redisplay errors caused by network errors.

;;;                           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, M/S 2151             
;;;   AUSTIN, TEXAS 78769                 
;;;
;;; Copyright (C) 1989 Texas Instruments Incorporated.
;;; All rights reserved.

;;; Patch file for VISIDOC version 6.5
;;; Written 10/04/89 13:44:51 by BERGER,
;;; while running on ARIES from band LODX
;;; With SYSTEM 6.17, VIRTUAL-MEMORY 6.2, EH 6.5, MAKE-SYSTEM 6.1, MICRONET 6.0, LOCAL-FILE 6.1,
;;;  BASIC-PATHNAME 6.1, NETWORK-SUPPORT-COLD 6.0, BASIC-NAMESPACE 6.2, NETWORK-NAMESPACE 6.0,
;;;  DISK-IO 6.1, DISK-LABEL 6.0, BASIC-FILE 6.3, MAC-PATHNAME 6.0, NETWORK-PATHNAME 6.0,
;;;  COMPILER 6.12, TV 6.15, DATALINK 6.0, CHAOSNET 6.1, GC 6.3, MEMORY-AUX 6.0, NVRAM 6.1,
;;;  SYSLOG 6.1, STREAMER-TAPE 6.4, UCL 6.0, INPUT-EDITOR 6.0, METER 6.1, ZWEI 6.5,
;;;  DEBUG-TOOLS 6.3, NETWORK-SUPPORT 6.0, NETWORK-SERVICE 6.1, DATALINK-DISPLAYS 6.0,
;;;  FONT-EDITOR 6.1, SERIAL 6.0, PRINTER 6.3, MAC-PRINTER-TYPES 6.1, PRINTER-TYPES 6.1,
;;;  IMAGEN 6.0, SUGGESTIONS 6.0, MAIL-DAEMON 6.2, MAIL-READER 6.2, TELNET 6.0, VT100 6.0,
;;;  NAMESPACE-EDITOR 6.0, PROFILE 6.1, VISIDOC 6.4, TI-CLOS 6.24, CLEH 6.5, IP 3.50,
;;;  Experimental CLX 6.3, CLUE 6.17, X11M 6.14, Experimental BUG 11.15, VISIDOC-SERVER 6.1,
;;;   microcode 429, Band Name: Rel 6.0 + SLE 8/30

#!C
; From file DEFINITIONS.LISP#> VISIDOC; SYS:
#10R ZWEI#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "ZWEI"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* SYS:COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: VISIDOC; DEFINITIONS.#"


(DEFCOM com-expand-section "Expand a section." ()
  (tv:with-mouse-grabbed			; DAB 06-12-89 Don't allow mouse clinks to occur.
    (LET ((node (expand-reference (line-node (bp-line (point))))))
      (when (typep node 'reference-node)   ; DAB 10-04-89
	  (progn
	    (move-bp (point) (interval-first-bp node))
	    (update-history node)
	    (SETF (window-redisplay-degree *window*) DIS-TEXT)
	    (SEND *window* :redisplay :START (point) nil nil)))))
  DIS-NONE)

(DEFUN  find-dox-section (node)
  "Find the desired section from a node"
  (tv:with-mouse-grabbed			; DAB 06-15-89
    (doc-viewer-select-buffer nil (send node :climb-to-buffer))
    (send node :link-and-expose)
    ;;(unless (node-expandedp node) (expand-reference node))  ; DAB 10-04-89
    (when (or (node-expandedp node) (expand-reference node))  ; DAB 10-04-89
      (update-history node)
      (move-bp (point) (interval-first-bp node)))
    (SETF (window-redisplay-degree *window*) DIS-TEXT)
    (SEND *window* :redisplay :START (point) nil t)))

))

#!C
; From file DOCUMENT-VIEWER.LISP#> VISIDOC; SYS:
#10R ZWEI#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "ZWEI"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* SYS:COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: VISIDOC; DOCUMENT-VIEWER.#"


(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 expanded-node)     ; DAB 09-07-89
      (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))
	     (if (typep (setf expanded-node (expand-reference (node-previous node))) 'reference-node) ; DAB 09-07-89
		 (move-bp (point) (interval-first-bp expanded-node ))
		 (RETURN-FROM find-reference node)) ; DAB 09-06-89
	     (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))
	     (if (typep (setf expanded-node (expand-reference (node-next node))) 'reference-node)  ; DAB 09-07-89
		 (move-bp (point) (interval-first-bp  expanded-node ))
		 (RETURN-FROM find-reference node)) ; DAB 09-06-89
	     (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)
		 (if (typep (setf expanded-node (expand-reference (node-superior node))) 'reference-node)  ; DAB 09-07-89
		     (move-bp (point) (interval-first-bp expanded-node ))
		     (RETURN-FROM find-reference node)) ; DAB 09-06-89
		 (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 expand-reference (node &aux lnext filepos object-list) ; DAB 09-07-89
  "Given a reference NODE, display the text that is associated with it."
  (DECLARE (inline object-attribute-start object-attribute-end))
  (condition-case (condition)
  (MULTIPLE-VALUE-BIND (expanded? snode)
      (node-expandedp node)
    (UNLESS (or expanded?
		(string-equal (send node :name) ""))  ; DAB 06-12-89 Handle empty topics.
      (FORMAT *query-io* "~&Expanding text for ~s" (ht-node-name snode))
     (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)
	  (progn (SETQ lnext (delete-doc-interval snode))  ; DAB 09-07-89 zmove from above IF
		 (SEND snode :mark-as-deexposed)
		 (SETF (reference-node-expanded-p snode) t)
		 (SEND snode :link-and-expose))
	  ;;All the text is not in the buffer...
	  ;;get and insert it in contracted form. 
	  (setf object-list (get-stuff-from-doc-server (ht-node-name snode)  ; DAB 09-07-89Move from below in LET* to handle network errors.
							 :manual (manual-name snode)
							 :nth (reference-node-nth snode)
							 :forced-get t))
	  (SETQ lnext (delete-doc-interval snode))   ; DAB 09-07-89 Next 3 lines Moved from above IF, to handle redisplay errors caused by network errors.
	  (SEND snode :mark-as-deexposed)  ; DAB 09-07-89
	  (SETF (reference-node-expanded-p snode) t)
 	  (LET* ((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 (if (eql (reference-node-nth (node-superior snode)) :unbound)
							  0    ; DAB 09-08-89 Handle UNBOUND NTHs.
							  (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)
		(setf (node-inferiors snode) (DELETE n (node-inferiors snode))) ; DAB 06-08-89
		(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)
    (error (tv:notify nil "Unable to expand the reference because ~a" (send condition :report-string)))) ; DAB 09-06-89
  )


))