;;;-*- Mode:LISP; Package: (browser global); Base:10.; fonts: cptfontb -*- 
;;;
;;; $header: /ct/browser/browser.l,v 1.5 84/02/23 18:58:21 jmiller Exp $
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                    BROWSER (formerly DB-WALKER)                  ;;;
;;; James R. Miller					May 3, 1983  ;;;
;;;                                                                  ;;;
;;; Ungeneralized to use simple flavor representation for text       ;;;
;;; nodes only -- jrm, 2/1/84                                        ;;;
;;;                                                                  ;;;
;;;   modifications by John Shelton to interface to                  ;;;
;;;       Tutor Module  5-May-83                                     ;;;
;;;                                                                  ;;;
;;; Generalized to handle arbitrary node graphs                      ;;;
;;;        by Tutor Group  12 May to 14 May 83                       ;;;
;;;								     ;;;
;;; Further generalized for standalone operation, next/previous      ;;;
;;; operation, automatic selection of menu fonts: jrm, 5/20-24/83    ;;;
;;;								     ;;;
;;; Menu labels, multiple documents added: jrm, 5/25/83		     ;;;
;;;                                                                  ;;;
;;; This file is part of a proprietary software project.  Source     ;;;
;;; code and documentation describing implementation details are     ;;;
;;; available on a confidential, non-disclosure basis only.  These   ;;;
;;; materials, including this file in particular, are trade secrets  ;;;
;;; of Computer * Thought Corporation.                               ;;;
;;;                                                                  ;;;
;;; (c) Copyright 1982 and 1983,  Computer * Thought Corporation.    ;;;
;;;     All Rights Reserved.                                         ;;;
;;;                                                                  ;;;
;;; Reference materials:                                             ;;;
;;;   Foderaro and Sklower, The FRANZ LISP Manual, September 1981.   ;;;
;;;   Weinreb and Moon, LISP MACHINE MANUAL, Symbolics, July 1981.   ;;;
;;;   Charniak et al., 1980.  Artificial Intelligence Programming.   ;;;
;;;   Miller, 1982.  The C*T Ada Tutor: Guide to the Implementation. ;;;
;;; The following code assumes familiarity with these materials.     ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Ensure presence of needed files. 
;;; Assumes ct_load and some suitable file-map are present

(eval-when (load eval compile)

  ;;Necessary files:

  (ct_load 'user:charmac)		  ;CT char set extensions.
  (ct_load 'user:aip)			  ;AIP macros pkg. 
  (ct_load 'user:compat)		  ;Franz/LM compat pkg.
  (ct_load 'user:ctflav)		  ;flavor tools
  (ct_load 'user:menufix)		  ;John's menu fix:
  (ct_load 'user:leftmenu)		  ;John's left-justified-menu stuff
  (ct_load 'user:protect)		  ;PROTECT software


  ;;Load the browser/view window fonts

  (ct_load 'user:brchars)
  (ct_load 'user:cttr12i)
  (ct_load 'user:cthl12)
  (ct_load 'user:cthl12i)
  (ct_load 'user:cthl12b)

   ;;Use the new version of VIEW, which, at this point, is not in the filemap.

  (ct_load 'user:newview)

  ;;Load fonts not on 3600...

  (ct_load 'user:ct18)
  (ct_load 'user:ct18b)
  (ct_load 'user:25fr3)
  (ct_load 'user:cttr18)
  (ct_load 'user:cttr18b)
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Compiler Declarations and Global Variables -- 

(declare (special *all-known-documents* *browser-window* *xref-menu*
		  *old-browser-menu* *db-walker-types* user:*browser-release*
		  *browser-release-string*))

;;;Globals:

;;;*DB-WALKER-TYPES contains the description of db-walker types.

(setq *db-walker-types*
	  '((documents
	      (:children  "Documents:"))
	    (document
	      (:parent    "Up to Document Collection:")
	      (:children  "Down to Chapters:"))
	    (chapter
	      (:parent    "Up to Containing Document:")
	      (:children  "Down to Sections:")
	      (:priornode "Back to Previous Chapter:")
	      (:nextnode  "Forward to Next Chapter:"))
	    (section
	      (:parent    "Up to Containing Chapter:")
	      (:children  "Down to Subsections:")
	      (:priornode "Back to Previous Section:")
	      (:nextnode  "Forward to Next Section:"))
	    (subsection
	      (:parent    "Up to Containing Section:")
	      (:priornode "Back to Previous Subsection:")
	      (:nextnode  "Forward to Next Subsection:")
	      (:children  "Down to Paragraphs:"))
	    (paragraph
	      (:parent    "Up to Containing Subsection:")
	      (:priornode "Back to Previous Paragraph:")
	      (:nextnode  "Forward to Next Paragraph:"))))


;;;*FONT-SIZE-LIST*:

(defvar *font-size-list*
	'((12 fonts:tr10b fonts:tr10)
	  (16 fonts:tr12b fonts:tr12)
	  (20 fonts:cttr18b fonts:cttr18))

  "An a-list of fonts and sizes, used by COMPUTE-LARGEST-POSSIBLE-FONT to
   find the largest font capable of showing a certain amount of information.
   The first font is bold (for menu entries); the second is normal (for
   menu headers.  This should ultimately be replaced with italics).")
(defvar *naughty_window*
	(tv:make-window 'tv:window
			':character-height 10.
			':width 700.
			':font-map '(fonts:cptfontb)
			':save-bits nil
			':deexposed-typeout-action ':permit
			':label '(:top :string "Warning Window"
				  :font fonts:cptfontb)))

;;;*BROWSER-RELEASE(-STRING)*: The string is automatically updated by
;;;RCS; USER:*BROWSER-RELEASE* then gets the number following the "$Revision: "
;;;part of the string.  Use SETQs for the moment (at least) to make sure
;;;this thing works.

(setq *browser-release-string* "$Revision: 1.39 $")

;;;EXTRACT-REVISION-NUMBER: given a RCS revision string, skip past the
;;;"$Revision:" label (to avoid package complaints) and read and return
;;;the revision number.  Semi-ugly, but it'll do.  Define this in an 
;;;EVAL-WHEN so the function will be defined when the file is compiled,
;;;and USER:*BROWSER-RELEASE* is given its value.  Note that for this to
;;;work properly, you should first check the file in (so that the revision
;;;number gets updated) and THEN compile the version in LATEST.

(eval-when (load eval compile)
  (defun extract-revision-number (string)
    (read-from-string
      (with-input-from-string (str string)
	(loop for i from 1 to 100000
	      until (eq (send str ':tyi) #/:)
	      finally (return (substring string i)))))))

(setq user:*browser-release*
	(extract-revision-number *browser-release-string*))

;;;*MANUAL-DIRECTORY-ALIST*:

(defvar *manual-directory-alist* nil
  "An a-list of document types and host/directory locations.  This global
   can be changed by a site, and the system will look in the appropriate
   place at runtime.")


;;;*DOCUMENT-TYPE-HIERARCHY*:

(defvar *document-type-hierarchy*
	'(top-of-tree documents document chapter section subsection paragraph)
  "The types of document type entries known to the system, in top-to-bottom
    order.")


;;;LEFT-MOMENTARY-MENU: A momentary menu with left-justified items

(defflavor left-momentary-menu
	()
	(tv:left-menu-mixin tv:momentary-menu))


;;;XREF-MENU: The cross-reference menu

(setq *xref-menu*
	(tv:make-window
	  'left-momentary-menu
	  ':borders 2
	  ':font-map '(fonts:ct18b)
	  ':label '(:string
	      "Pick a cross-reference, or move away to stay where you are"
		    :font fonts:ct18)))


;;;OLD-BROWSER-MENU: The menu for selecting old browsers

(defvar *old-browser-menu*
	(tv:make-window
	  'left-momentary-menu
	  ':borders 2
	  ':font-map '(fonts:ct18b)
	  ':label '(:string
"Pick an old browser to return to, or move away to stay in the current browser."
		    :font fonts:ct18)))

;;;This change to the BEFORE CHOOSE method has the effect of centering a
;;;popped-up menu around the mouse's Y position, but not the X position.
;;;This repairs the rather annoying trait of the mouse getting yanked out of
;;;position in the browser's vertical menus -- after you leave the menu
;;;(either by selecting or moving off), the mouse cursor will still be near
;;;the menu items that you were just working with.  Obviously, the code is
;;;adapted from TV:BASIC-MOMENTARY-MENU.

tv:(DEFMETHOD (browser:left-MOMENTARY-MENU :BEFORE :CHOOSE) ()
     (COND ((NOT EXPOSED-P)
	    (MULTIPLE-VALUE-BIND (X-OFF Y-OFF)
		(SHEET-CALCULATE-OFFSETS SUPERIOR MOUSE-SHEET)
	      (MULTIPLE-VALUE-BIND (X Y)
		  (FUNCALL-SELF ':CENTER-AROUND
				(- MOUSE-X X-OFF) (- MOUSE-Y Y-OFF))
		x			  ;keep compiler messages quiet
		(MOUSE-WARP mouse-x	  ;used to be (+ X X-OFF)
			    (+ Y Y-OFF))))
	    ;; Expose self, and seize the mouse.
	    (WITH-MOUSE-GRABBED
	      (FUNCALL-SELF ':EXPOSE)
	      (COND ((NEQ SELF (LOWEST-SHEET-UNDER-POINT
				 MOUSE-SHEET MOUSE-X MOUSE-Y
				 NIL ':EXPOSED))
		     (FUNCALL-SELF ':DEACTIVATE)
		     (*THROW 'ABORT NIL)))))))


;;;*DOCUMENT-LONG-LABELS*:

(defvar *document-long-labels* nil
  "This holds the labels used in the 'You are now at ...' part of the menu.")

;;;*DOCUMENT-SHORT-LABELS*:

(defvar *document-short-labels* nil
  "This holds the labels used in the MAJOR-SUBHEADS menu.")


;;;Menu flavor definitions and changes:

;;;LEFT-COMMAND-MENU: A menu with items left-justified

(defflavor left-command-menu
    ()
    (tv:pop-up-notification-mixin tv:line-truncating-mixin
     tv:left-menu-mixin tv:command-menu-pane
     #+LMI tv:stream-mixin #+LMI tv:select-mixin)
  (:default-init-plist :truncate-line-out-flag 1))


;;;LEFT-COMMAND-MENU-WITH-TYPEOUT supports BREAK/RESUME in the middle of 
;;;a browser session.

(defflavor left-command-menu-with-typeout ()
	   (left-command-menu tv:window-with-typeout-mixin
	    #+LMI tv:stream-mixin #+LMI tv:select-mixin)
  (:default-init-plist :typeout-window
   '(tv:typeout-window
      :deexposed-typeout-action (:expose-for-typeout) :io-buffer nil)))

(defmethod (left-command-menu-with-typeout :after :init) (&rest ignore)
  (send (send self ':typeout-window) ':set-io-buffer (send self ':io-buffer)))



;;;UNSCROLLING-COMMAND-MENU-PANE is a command menu that doesn't scroll; do 
;;;this by defining away the SCROLL-BAR method.

(defflavor unscrolling-command-menu-pane
	()
	(tv:line-truncating-mixin tv:command-menu-pane #+LMI tv:stream-mixin)
  (:default-init-plist :truncate-line-out-flag 1))

(defmethod (unscrolling-command-menu-pane :scroll-bar-p) ()
  nil)

;;;SCROLLING-COMMAND-MENU-PANE is a command menu that does scroll

(defflavor scrolling-command-menu-pane
	()
	(tv:line-truncating-mixin tv:command-menu-pane #+LMI tv:stream-mixin)
  (:default-init-plist :truncate-line-out-flag 1))


;;;Internal macros (that have to be defined here):

;;;INTERNED-GENSYM: **********************************************************
;;;Intern a gensym'ed symbol

(defmacro interned-gensym (&optional arg)
  (cond (arg `(intern (gensym ,arg)))
	(t `(intern (gensym)))))



;;;BROWSER-ENVIRONMENT: ******************************************************
;;;A flavor describing a browser environment -- for now, this is little more
;;;than a record

(defflavor browser-environment
	((browser)
	 (name)
	 (number)
	 (current-node)
	 (nodestack))
	()
  :gettable-instance-variables
  :settable-instance-variables
  :initable-instance-variables)


;;;AFTER INIT: Set up the NUMBER pointer to this environment.

(defmethod (browser-environment :after :init) (&rest ignore)
  (send self ':set-number (1+ (length (send browser ':existing-browsers))))
  (user:protect 'browser))



;;; Database walker: **********************************************************

(defflavor browser
	((current-node)
	 (previous-node)
	 (browser-selection-menu)
	 (subhead-menu)
	 (nodestack-menu)
	 (node-text-menu)
	 (textwindow)
	 (nodestack)
	 (major-subheads)
	 (current-browser-environment)
	 (existing-browsers)
	 (refresh-the-screen-p))	  ;if t, force a refresh 
	(tv:any-tyi-mixin tv:process-mixin tv:select-mixin
	  tv:stream-mixin tv:bordered-constraint-frame-with-shared-io-buffer)
	(:default-init-plist :save-bits t)
	(:documentation :special-purpose "The Browser Window")
	:settable-instance-variables
	:gettable-instance-variables
	:initable-instance-variables)


(defmethod (browser :before :init) (&rest ignore)
  
  ;;Initialize stuff
  
  (setq tv:process '(browser-top-level :regular-pdl-size 8000
				       :special-pdl-size 6000)
	tv:panes `((browser-selection-menu unscrolling-command-menu-pane
					   :item-list nil
					   :borders 2
					   :columns 1
					   :label (:string "Browser selection"
						   :font fonts:cptfontb))
		   (subhead-menu scrolling-command-menu-pane
				 :item-list nil
				 :borders 2
				 :columns 1
				 :label (:string "Documents"
					 :font fonts:cptfontb))
		   (nodestack-menu left-command-menu
				   :borders 2
				   :item-list nil
				   :label (:string "Previous positions"
					   :font fonts:cptfontb))
		   (message-window tv:window-pane
				   :borders 2
				   :font-map (fonts:metsi))
		   (textwindow user:viewing_frame :borders 2)
		   (node-text-menu left-command-menu-with-typeout
				   :item-list nil
				   :borders 2
				   :label
				   (:string
				    ,(format
				      nil
                "The Computer * Thought Documentation Browser: Version ~a"
				      user:*browser-release*)
				    :font fonts:tr12b
				    :bottom)))
	tv:constraints '((command-and-node-window
			   (topstrip node-text-menu)
			   ((topstrip :horizontal (175)
				      (nodestack-menu subhead-and-selection)
				      ((nodestack-menu 0.7)
				       (subhead-and-selection
					 :vertical (0.3)
					 (browser-selection-menu
					   subhead-menu)
					 ((browser-selection-menu 0.4)
					  (subhead-menu 0.6))))))
			   ((node-text-menu :even)))
			 (messages-only (message-window)
					((message-window :even)))
			 (text-display-only (textwindow)
					    ((textwindow :even))))))

(defmethod (browser :after :init) (&rest ignore)
  (setq browser-selection-menu (send self ':get-pane 'browser-selection-menu))
  (setq subhead-menu (send self ':get-pane 'subhead-menu))
  (setq nodestack-menu (send self ':get-pane 'nodestack-menu))
  (setq textwindow (send self ':get-pane 'textwindow))
  (setq node-text-menu (send self ':get-pane 'node-text-menu)))


;;;(BROWSER :BROWSER-TOP-LEVEL): ***************************************
;;;The top-level function and method.  (BROWSER-TOP-LEVEL) is called when
;;;the process is started up or when ABORT is hit during execution.

(defun browser-top-level (terminal-io) 
    (send terminal-io ':browser-top-level))

(defmethod (browser :browser-top-level) ()
  
  ;;Just in case...
  
  (setq base 10.
	ibase 10.
	*nopoint t)
  
  ;;Select the browser and walk it, starting at *ALL-KNOWN-DOCUMENTS*.
  
  (setq *browser-window* self)

  ;;Clear PREVIOUS-NODE, so that the screen will still get redrawn
  ;;after an abort.

  (setq previous-node nil)
  (send self ':select)
  (send self ':walk-database *all-known-documents*))


;;;(BROWSER :CLEAR-SCREEN): ******************************************
;;;Clear the three menu panes of the db walker.

(defmethod (browser :clear-screen) ()
   (loop for pane in '(nodestack-menu subhead-menu node-text-menu)
	  do
	  (send self ':send-pane pane ':set-item-list nil)))


;;;(BROWSER :MENU-SELECT): **********************************
;;;Get a menu item from any of the three menus.

(defmethod (browser :after :select) (&rest ignore)
  (send node-text-menu ':select))

(defmethod (browser :menu-select) ()
 (send terminal-io ':clear-input)
 (send node-text-menu ':select)
 (loop as response = (send terminal-io ':any-tyi) doing

       ;;Return the three values RAWMENUITEM, ITEM-PNAME, and MENU-PANE).

       (cond ((listp response)
	      (return (second response)
		      (string-trim '(#\sp) (first (second response)))
		      (fourth response)))
	     ((memq response '(#\c-L #\clear-screen))
	      (send self ':refresh)))))


(comment
 ;;; Oh yuck.  Need to do these to make Shift-Right-Click work.
 ;;; Won't do them for now, but we may want to add them later.
 ;;; Soley & JRM, 8/15/84

(DEFMETHOD (browser:left-command-menu :MOUSE-BUTTONS) (BD X Y)
  BD X Y			    ;;ignored, we don't care where the 
  				    ;;mouse is, the :MOUSE-MOVES method
  				    ;;took care of that
  (LET ((BUTTONS (MOUSE-BUTTON-ENCODE BD)))
    (COND ((= BUTTONS #\MOUSE-R-2)
	   (MOUSE-CALL-SYSTEM-MENU))
	  (CURRENT-ITEM				;Any button, select item.
	   (SETQ LAST-ITEM CURRENT-ITEM
		 CHOSEN-ITEM CURRENT-ITEM)
	   (COND ((AND (LISTP CHOSEN-ITEM)
		       ( (LENGTH CHOSEN-ITEM) 3)
		       (EQ (SECOND CHOSEN-ITEM) ':BUTTONS))
		  (SETQ CHOSEN-ITEM (NTH (1- (HAULONG BD))
					 (THIRD CHOSEN-ITEM))))))
	  ((AND ( X (SHEET-INSIDE-LEFT)) (< X (SHEET-INSIDE-RIGHT))
		( Y (SHEET-INSIDE-TOP)) (< Y (SHEET-INSIDE-BOTTOM))))
	  (T
	   ;; Here, clicked on the window, but outside of the window proper.
	   ;; Send a :MOUSE-CLICK message so things like margin regions can
	   ;; work.
	   (FUNCALL-SELF ':MOUSE-CLICK BD X Y)))))

(DEFMETHOD (browser:left-command-menu-with-typeout :MOUSE-BUTTONS) (BD X Y)
  BD X Y			    ;;ignored, we don't care where the 
  				    ;;mouse is, the :MOUSE-MOVES method
  				    ;;took care of that
  (LET ((BUTTONS (MOUSE-BUTTON-ENCODE BD)))
    (COND ((= BUTTONS #\MOUSE-R-2)
	   (MOUSE-CALL-SYSTEM-MENU))
	  (CURRENT-ITEM				;Any button, select item.
	   (SETQ LAST-ITEM CURRENT-ITEM
		 CHOSEN-ITEM CURRENT-ITEM)
	   (COND ((AND (LISTP CHOSEN-ITEM)
		       ( (LENGTH CHOSEN-ITEM) 3)
		       (EQ (SECOND CHOSEN-ITEM) ':BUTTONS))
		  (SETQ CHOSEN-ITEM (NTH (1- (HAULONG BD))
					 (THIRD CHOSEN-ITEM))))))
	  ((AND ( X (SHEET-INSIDE-LEFT)) (< X (SHEET-INSIDE-RIGHT))
		( Y (SHEET-INSIDE-TOP)) (< Y (SHEET-INSIDE-BOTTOM))))
	  (T
	   ;; Here, clicked on the window, but outside of the window proper.
	   ;; Send a :MOUSE-CLICK message so things like margin regions can
	   ;; work.
	   (FUNCALL-SELF ':MOUSE-CLICK BD X Y)))))

...end of commented-out mouse-buttons methods

)

;;;(BROWSER :SELECT-A-NEW-BROWSER) *******************************************
;;;Pop up a menu describing the browser environments in existence, and
;;;let the user select one.  Don't show the browser corresponding to the
;;;current position.

(defmethod (browser :select-a-new-browser) ()
  (let ((browser-list (loop for item in existing-browsers
			    unless (equal (send item ':name)
					  (send current-browser-environment
						':name))
			    collect (list (send (send item ':current-node)
						':longlabel)
					  item)))
	(response))
    (cond 
      
      ;;If there's only one other browser, go to it, making sure the screen
      ;;is re-displayed.
      
      ((= (length browser-list) 1)
       (setq refresh-the-screen-p t)
       (second (first browser-list)))
      
      ;;If there is more than one browser, build a menu list of the
      ;;existing browsers...
      
      (t
       (send *old-browser-menu* ':set-item-list 
	     (loop for item in (reverse browser-list)
		   with docname = nil
		   do (setq docname (send (send (second item)
						':current-node)
					  ':documentname))
		   collect `(,(format nil "Browser ~d: ~a~a~a"
				      (send (second item) ':number)
				      (get-document-abbr docname)
				      (cond (docname ": ")
					    (t ""))
				      (first item))
			     :value ,(send (second item) ':name))))
       
       ;;...pop up a menu of the items, and look for the selected item
       ;;on BROWSER-LIST; return the selected node.
       
       (cond ((setq response (send *old-browser-menu* ':choose))
	      (loop for item in browser-list
		    when (equal response (send (second item) ':name))
		    do
		    (setq refresh-the-screen-p t)
		    (return (second item))))
	     
	     ;;If :CHOOSE returns NIL -- if no selection was made --
	     ;;return NIL, and don't bother redrawing the screen.
	     
	     (t (setq refresh-the-screen-p nil)
		nil))))))


;;;(BROWSER :SET-UP-MENUS) *******************************************
;;;Set up the window menus to correspond to the user's current position 
;;;and history in the system.

(defmethod (browser :set-up-menus) (node nodecont)

  ;;NODESTACK-MENU contains the nodes visited in this incarnation of the
  ;;database walker.  Notice that the list of fonts passed to 
  ;;BUILD-FONTED-MENU-LIST is faked (i.e., the bold font is supposed to be 
  ;;first) so that the items in the nodestack menu will be in uppercase.
  
  (send nodestack-menu ':set-item-list
	(build-fonted-menu-list
	  (loop for node in nodestack
		collect
		(list (string-append
			(get-document-abbr
			  (send node ':documentname))
			(cond ((send node ':documentname) ": ")
			      (t ""))
			(send node ':shortlabel))
		      ':value
		      (send node ':shortlabel)))
	  '(fonts:cttr18 fonts:cttr18b)))
  
  ;;...SUBHEAD-MENU gets the accessible major topics.  Recompute them,
  ;;using the names of the network's first-level children, each time
  ;;in case they have changed.

  (send subhead-menu ':set-item-list
	(cond ((setq major-subheads
		     (loop for child in (send *all-known-documents*
					      ':children)
			   collect
			   (list (send child ':documentname)
				 (get-document-abbr (send child ':name))
				 (send child ':longlabel)
				 child)))
	       (loop with subheadlabel = nil
		     for subhead in major-subheads
		     do (setq subheadlabel (second subhead))
		     unless (equal subheadlabel "")
		     collect
		     `(,subheadlabel
		       :value ,subheadlabel
		       :font fonts:cttr18b
		       :documentation
		       ,(format nil "Browse through ~a (Version ~a)"
				(third subhead)
				(get (first subhead) 'release-number)))))))

  ;;BROWSER-SELECTION-MENU lets the user drop into a fresh browser and
  ;;return to other existing browsers (if any exist).

  (send browser-selection-menu ':set-item-list
	`(("Create New Browser"
	   :value "Create New Browser"
	   :font fonts:cttr18b
	   :documentation
	   "Drop into a new browser, starting at the current position.")
	  
	  ;;If more than one browser exists, allow the selection of them.
	  
	  ,@(cond ((> (length existing-browsers) 1)
		   `(("Select Old Browser"
		      :value "Select Old Browser"
		      :font fonts:cttr18b
		      :documentation
		  "Select one of the browsers created earlier in this session"
		      ))))))
  
  ;;...and NODE-TEXT-MENU contains the nodes that can be visited or files
  ;;that can be viewed.
  
  (send node-text-menu ':set-item-list
	(create-topic-menu
	  node nodecont node-text-menu current-browser-environment)))


;;;(BROWSER WALK-DATABASE): *****************************************
;;;Given a pointer to a database structure, let the user wander around in
;;;this structure as he likes.  

(defmethod (browser :walk-database) (tree)

  ;;The master control loop:
    
  (loop with instructions-and-node = nil
	  
	  initially

	  ;;Clear the menu system and set it up for deexposed-typeout.

	  (send self ':clear-screen)
	  (send self ':set-deexposed-typeout-action 'permit)

	  ;;Start walking the tree at either CURRENT-NODE or TREE.
	  ;;(CURRENT-NODE will have a value when re-entering this
	  ;;method after hitting ABORT).

	  (cond ((null current-node)
		 (setq current-node tree)))

	  ;;Initialize EXISTING-BROWSERS and CURRENT-BROWSER-ENVIRONMENT, but
	  ;;be careful about this, since we can get here either by starting
	  ;;a fresh browser or by hitting ABORT during execution.  Only do the
	  ;;following when a fresh browser is being built -- when there isn't
	  ;;anything in CURRENT-BROWSER-ENVIRONMENT.

	  (cond ((null current-browser-environment)
		 
		 ;;Create EXISTING-BROWSERS as this browser environment, and 
		 ;;set up CURRENT-BROWSER-NAME as this environment's name.
		 
		 (setq existing-browsers
		       (list
			 (setq current-browser-environment
			       (make-instance 'browser-environment
					      ':browser self
					      ':name (interned-gensym 'b)
					      ':current-node current-node
					      ':nodestack nil))))))

	  ;;Start the (infinite) loop:

	  do

	  ;;De-expose the typeout window if it happens to be up, and refresh
	  ;;the browser.

	  (if (eq tv:selected-window (send node-text-menu ':typeout-window))
	      (progn
		(send (send node-text-menu ':typeout-window) ':deexpose)
		(send self ':refresh)))

	  ;;The main loop:
	  ;;Send CURRENT-NODE a SHOW-YOURSELF message -- this will
	  ;;display the 3-pane menu and return one of the following three
	  ;;things:
	  ;;
	  ;;  (DISPLAY <node>): Switch the node menu to show <node>
	  ;;  (SHOW-TEXT-FILE <node>): Show <node>'s text file
	  ;;  (BUILD <node>):   push the current environment onto 
	  ;;			EXISTING-BROWSERS and start up a fresh
	  ;;			browser displaying <node>

	  (setq instructions-and-node
		(send current-node ':show-yourself self))

	  ;;Save the current node in PREVIOUS-NODE before...

	  (setq previous-node current-node)

	  ;;...checking INSTRUCTIONS-AND-NODE's first element for what to do:

	  (setq current-node 
		(selectq (first instructions-and-node)
		  
		  ;;DISPLAY: CURRENT-NODE becomes the node returned by the
		  ;;SHOW-YOURSELF message.  Update the nodestack so that
		  ;;We can get back to here by clicking on the top of the
		  ;;node stack.
		  
		  (display (send self ':update-nodestack
					(second instructions-and-node))
			   (second instructions-and-node))

		  ;;SHOW-TEXT-FILE: Show the text file corresponding to this
		  ;;node, as well as any other text files that the user may
		  ;;jump to.  Keep doing this until SHOW-YOUR-TEXT-FILE
		  ;;returns (DISPLAY <newnode>) -- <newnode> then becomes the
		  ;;new node to be shown.  Also, update the nodestack so that
		  ;;We can get back to here by clicking on the top of the
		  ;;node stack.

		  (show-text-file
		     (loop with next-display = nil
			 and node-to-display = current-node
			 do
			 (setq next-display
			       (send node-to-display
				     ':show-your-text-file self))
			 (setq node-to-display (second next-display))
			 until (eq (first next-display) 'display)
			 finally 
			 #+LMI (let ((main-browser-menu (send self :get-pane 'node-text-menu)))
				 (send self :set-selection-substitute main-browser-menu)
				 (send main-browser-menu :select))
			 (unless (eq current-node node-to-display)
			   (send self ':update-nodestack current-node))
			 (return node-to-display)))
		  
		  ;;BUILD: Save the CURRENT-NODE and the current NODESTACK
		  ;;on EXISTING-BROWSERS and display the node returned by the
		  ;;SHOW-YOURSELF message.
		  
		  (build
		   (loop for b in existing-browsers
			 when (equal (send current-browser-environment ':name)
				     (send b ':name))
			 do
			 (send b ':set-current-node current-node)
			 (send b ':set-nodestack nodestack))
		   (push (setq current-browser-environment
			       (make-instance 'browser-environment
					':browser self
					':name (interned-gensym 'b)
					':current-node current-node
					':nodestack nil))
			 existing-browsers)
		   (setq nodestack nil)

		   ;;Set REFRESH-THE-SCREEN-P to T so that the new browser
		   ;;will be re-displayed at the top of the loop.

		   (setq refresh-the-screen-p t)

		   ;;Return the node pointed to by the new browser.

		   (second instructions-and-node))

		  ;;SELECT: the second element of this list is a browser
		  ;;environment; switch to it if it's not the same as the
		  ;;current one.  Otherwise, stay where you are.  Before doing
		  ;;all this, though, modify the current environment's
		  ;;representation on EXISTING-BROWSERS by replacing it with
		  ;;the current state of this environment.

		  (select
		    (let ((newenv (second instructions-and-node)))
		      (cond ((null newenv) current-node)
			    (t (loop for b in existing-browsers
				     when (equal
					    (send current-browser-environment
						  ':name)
					    (send b ':name))
				     do
				     (send b ':set-current-node current-node)
				     (send b ':set-nodestack nodestack))
			       (setq current-browser-environment newenv
				     nodestack (send newenv ':nodestack))
			       (send newenv ':current-node)))))
		  
		  ;;Error trap...
		  
		  (otherwise
		   (break `("SHOW-YOURSELF returned funny value: "
			    ,instructions-and-node)))))))

		
;;;(BROWSER :UPDATE-NODESTACK):  ************************************
;;;Update the nodestack after a selection.

(defmethod (browser :update-nodestack) (new-node)
  
  ;;If the newly selected node is on NODESTACK, remove it before doing
  ;;anything else.
  
  (cond ((member new-node nodestack)
	 (setq nodestack (delete new-node nodestack))))
  
  ;;Add NEW-NODE to NODESTACK, trimming the list if necessary.
  
  (setq nodestack
	(cond ((member current-node nodestack)
	       (cons current-node
		     (delete current-node nodestack)))
	      (t (remove nil (firstn 7 (cons current-node nodestack)))))))



;;;Flavor definitions for document nodes

;;;DOCUMENT-NODE -- the things the network is made out of.

(defflavor document-node
	((name nil)
	 (type nil)
	 (documentname nil)
	 (longlabel nil)
	 (shortlabel nil)
	 (parent nil)
	 (children nil)
	 (priornode nil)
	 (nextnode nil)
	 (xrefs nil)
	 (readable t)		       ;;default: all nodes are readable
	 (startingbyte 0)
	 (endingbyte 0))
	()
  :gettable-instance-variables
  :settable-instance-variables
  :initable-instance-variables)


;;;(DOCUMENT-NODE :FIND-NODECONTENTS): ***************************************
;;;Retrieves the type information for this node from *DB-WALKER-TYPES* and
;;;puts together lists of the form (:CHILDREN (<list of children>)) for each
;;;such entry.

(defmethod (document-node :find-nodecontents) ()
  (let* ((type-entry (cdr (assq type *db-walker-types*))))
    
    ;;Create a menu entry of the form (:CHILDREN <list of children>) from 
    ;;each element in TYPE-ENTRY, whose elements are of the form
    ;;(:CHILDREN <label for :children menu section>).  The procedure
    ;;and the form of the result is dependent on whether it's a
    ;;folder component or an action item.  
    
    (loop with indicatednode = nil
	  for item in type-entry
	  when (setq indicatednode (send self (first item)))
	  collect (list (first item) (second item) indicatednode))))


;;;(DOCUMENT-NODE :SELECT-XREF): *********************************************
;;;Get the labels out of the cross-references, pop up a menu, and return 
;;;either the selected node or NIL if NIL came back from the menu.

;;>>>>>>>>>>change this to work at "compile time"?????

(comment
  (cond ((stringp
	   (send item ':label))
	 (send item ':label))
	((eq (send item ':label)
	     'longlabel)
	 (send
	   (send
	     item
	     ':referenced-node)
	   ':longlabel))
	(t (ferror
	     "Bad XREF label"))))

(defmethod (document-node :select-xref) ()
  (let ((item-node-alist (loop for item in xrefs
			       collect (list (send item ':label) 
					     (send item ':referenced-node))))
	(response))
    (send *xref-menu* ':set-item-list
	  (reverse (loop for item in item-node-alist
			 collect `(,(first item) :value ,(first item)))))
    (cond ((setq response (send *xref-menu* ':choose))
	   (second (assoc response item-node-alist)))
	  (t nil))))


;;;(DOCUMENT-NODE :SHOW-YOUR-TEXT-FILE): *************************************
;;;Switch to the text display configuration and display the appropriate file.
;;;Return this file's DOCUMENT-NODE, requesting DISPLAY.

(defmethod (document-node :show-your-text-file) (browser)
  (let ((textwindow (send browser ':get-pane 'textwindow))
	(next-node))
    
    (#+Symbolics progn #+LMI tv:delaying-screen-management
    
     ;;Display the appropriate portion of the document file in a
     ;;user-scrolled view window.

      (send textwindow ':get_file_segment
	    (string-append
	      (second (assoc documentname 
			     *manual-directory-alist*))
	      (with_ct_load_subdir "" (ct_load_get 'user:docfilname)))
	    startingbyte endingbyte nil longlabel t t)

      #+LMI (send browser :set-selection-substitute textwindow)

      ;;Switch to the TEXT-DISPLAY-ONLY configuration (if necessary).
      (cond ((not (eq (send browser ':configuration)
		      'text-display-only))
	     (send browser ':set-configuration 'text-display-only))))

    ;;Catch the value returned by LET_USER_SCROLL in NEXT-NODE for
    ;;use below.
    
    (setq next-node (send textwindow ':let_user_scroll self))
    (send textwindow ':clear_screen)
    
    ;;Check NEXT-NODE to determine what node should be returned as the next
    ;;thing to be viewed.  NEXT-NODE will usually be NIL, but it may be
    ;;PREVIOUS, NEXT, or XREFS, in which case we go directly to the
    ;;appropriate text file. 
    
    (cond
      
      ;;NEXT: show the text file corresponding to the document node
      ;;right after this one.
      
      ((eq next-node 'user:next)
       (list 'show-text-file (first nextnode)))
      
      ;;PREVIOUS: show the text file corresponding to the document node
      ;;right before this one.
      
      ((eq next-node 'user:previous)
       (list 'show-text-file (first priornode)))
      
      ;;A successful cross-reference access yields the list
      ;;(XREF <document-file>) is returned -- display the
      ;;corresponding text file.
      
      ((and (listp next-node)
	    (eq (first next-node) 'user:xref)
	    (second next-node))
       (list 'show-text-file (second next-node)))
      
      ;;An aborted cross-reference access yields the list
      ;;(XREF NIL) is returned -- just display the current node.
      
      ((and (listp next-node)
	    (eq (first next-node) 'user:xref))
       (list 'show-text-file self))
      
      ;;This is the "normal" termination -- return to displaying
      ;;the document-file's document node.
      
      (t (list 'display self)))))


;;;(DOCUMENT-NODE :SHOW-YOURSELF): *******************************************
;;;Display the 3-pane menu corresponding to this node and let the user
;;;select something.  Return the selected node, requesting DISPLAY.
(defun notify_user (window string)
  (let ((query-io window)
	(error-output window)
	(prompt (format nil "~%Type any character to proceed~%"))
	(tv:kbd-tyi-hook nil))
    (send window ':expose-near '(:mouse))
    (send window ':clear-screen)
    (send window ':select)
    (condition-case ()
	(unwind-protect
	  (prompt-and-read :character (string-append string prompt))
	  (send window ':bury))
      (sys:abort))));We catch it if the user types abort. Suspend can still squeak through.

(defmethod (document-node :show-yourself) (browser)
  
    (let ((nodecontents (send self ':find-nodecontents))
	(full-item)
	(long-label)
	(selected-menu)
	(browser-selection-menu (send browser ':browser-selection-menu))
	(nodestack-menu (send browser ':nodestack-menu))
	(node-text-menu (send browser ':node-text-menu))
	(subhead-menu   (send browser ':subhead-menu))
	(selected-xref))

    ;;Check out the protection of this document; bomb out if this document is
    ;;not licensed.

    (let ((protectval (user:soft-protect documentname)))
      (cond ((not (stringp protectval))
	     (notify_user
	       *naughty_window*
	       (format nil
		       "~2%You are not authorized to look at the ~A document~2%"
		       documentname))
	     (send (send browser ':previous-node) ':show-yourself))    
    ;;If we're not already looking at the COMMAND-AND-NODE-WINDOW,
    ;;configuration, switch to it.

	    (t
    
    ;;If we're not already looking at the COMMAND-AND-NODE-WINDOW,
    ;;configuration, switch to it.
	   
    (cond ((not (eq (send browser ':configuration)
		    'command-and-node-window))
	   (send browser ':set-configuration 'command-and-node-window)))

    ;;Set up the menus as a function of the nodes and files available
    ;;inside this node.  Do this only if the node has changed over what
    ;;is already on the screen, or if a new browser has been spawned.

    (cond ((or (cond ((send browser ':refresh-the-screen-p)
		      (send browser ':set-refresh-the-screen-p nil)
		      t))
	       (not (eq self (send browser ':previous-node))))
	   (send browser ':set-up-menus self nodecontents)))
    
    ;;Let the user choose from one of the menus, and return the full menu item,
    ;;its label (which is an item's LONGLABEL), and the selected menu.
    
    (multiple-value
      (full-item long-label selected-menu)
      (send browser ':menu-select))
    
    ;;What is to be done depends on the menu in which the selection was made.
    
    (cond

      ;; *****  SUBHEAD-MENU  *****

      ((eq subhead-menu selected-menu)
       
       ;;Selection from the SUBHEAD PANE: it's one of the
       ;;items on MAJOR-SUBHEADS.  Find it on MAJOR-SUBHEADS and return
       ;;the appropriate node, which is already on MAJOR-SUBHEADS as
       ;;the third element of the a-list.
	 
       `(display
	  ,(third (assoc long-label
			  (mapcar #'cdr (send browser ':major-subheads))))))
      
      ;; *****  BROWSER-SELECTION-MENU  *****

      ((eq selected-menu browser-selection-menu)

       ;;Selection from the BROWSER-SELECTION-MENU: It's either
       ;;"Create New Browser" or "Select Old Browser"

       (cond
	 
	 ;;"Create New Browser": Enter an embedded call to the system, starting
	 ;;at the current position.

	 ((equal long-label "Create New Browser")
	  `(build ,self))

	 ;;"Select Old Browser": Pop up a menu describing all browser
	 ;;environments (except the current one) and let the user select one
	 ;;(or move away).  Switch control to the new one or stay in the
	 ;;current browser, depending.

	 ((equal long-label "Select Old Browser")
	  `(select ,(send browser ':select-a-new-browser)))))

      ;;  *****  NODESTACK-MENU  *****

      ((eq nodestack-menu selected-menu)

      ;;Selection from the NODESTACK menu: find the corresponding
      ;;item on the nodestack and go to it.

       (loop for node in (send browser ':nodestack)
	     do
	     (cond ((equal (third full-item)
			(send node ':shortlabel))
		    (return `(display ,node))))))
      
      ;;  *****  NODE-TEXT-MENU  *****

      ((eq node-text-menu selected-menu)

      ;;Selection from the NODE-TEXT-MENU: figure out what kind of
      ;;reference it is, and return the corresponding node
      
       (or
	 
	 ;;Is it a DOCUMENT-NODE?  Look down the list of accessible nodes; if
	 ;;a match between LONG-LABEL and the node's label is found, 
	 ;;go to that node.
	 
	 (loop for node in (loop for entry in nodecontents
				 when (first (third entry))
				 append (third entry)) 
	       do
	       (cond ((equal long-label (send node ':longlabel))
		      (return `(display ,node)))))
	 
	 ;;Is it a TEXTFILE?  Look for this thing's LONG-LABEL in the
	 ;;set of textfiles, and display that one if it's found.

	 (cond ((equal long-label longlabel)
		`(show-text-file ,self)))

	 ;;Is it a cross-reference announcement?  If so, pop up a menu 
	 ;;containing the cross-references's labels, let the user
	 ;;select one, and return it.  If he moves off the menu and returns
	 ;;NIL, stay where you are.

	 (cond ((equal long-label "Cross references")
		(cond ((setq selected-xref (send self ':select-xref))
		       `(display ,selected-xref))
		      (t `(display ,self)))))))))))))



;;;DOCUMENT-XREF: ************************************************************
;;;A cross-reference node: these nodes contain the xref label that shows up in
;;;the pop-up menu and a pointer to the referenced node.

(defflavor document-xref
	((label)
	 (referenced-node))
	()
  :gettable-instance-variables
  :settable-instance-variables
  :initable-instance-variables)



;;;Installation functions:


;;;BUILD-BASIC-NODES: Given a directory, read the node definitions file and
;;;build instance variables corresponding to each.

(defun build-basic-nodes (directory)
  (let (treetop
	all-nodes
	(first-node-p t))
    (with-open-file (f (string-append
			 directory
			 (with_ct_load_subdir
			   "" (ct_load_get 'user:nodedefname))) ':in)
      (loop with item = nil
	    and nodetype = nil
	    and nodename = nil
	    and itemargs = nil
	    and newnode = nil
	    until (null (setq item (pkg-bind "BROWSER" (read f nil))))
	    do
	    
	    ;;Cache up a few parts of ITEM.
	    
	    (setq nodetype (first item)
		  itemargs (cdr item)		
		  nodename (get-property-from-itemargs 'name itemargs))
	    
	    ;;Build NEWNODE for this entry.  The REVERSEs insure that multiple
	    ;;items come out right .
	    
	    (setq newnode
		  (make-instance
		    'document-node
		    ':type nodetype
		    ':name nodename
		    ':documentname (get-property-from-itemargs
				     'documentname itemargs)
		    ':longlabel (get-property-from-itemargs
				  'longlabel itemargs)
		    ':shortlabel (get-property-from-itemargs
				   'shortlabel itemargs)
		    ':parent (get-property-from-itemargs
			       'parent itemargs)
		    ':children (reverse
				 (get-property-from-itemargs
				   'children itemargs))
		    ':xrefs (reverse
			      (get-property-from-itemargs
				'xrefs itemargs))))
	    
	    ;;Push NEWNODE onto ALL-NODES for pointer
	    ;;determination below
	    
	    (push newnode all-nodes)
	    
	    ;;Give NODENAME a DOCUMENT-NODE property
	    
	    (putprop nodename newnode 'document-node)
      
	    ;;If this is the first node, save a pointer to it in TREETOP
      
	    (cond (first-node-p
		   (setq treetop newnode)
		   (setq first-node-p nil)))))
    
    ;;Return the multiple values of TREETOP and ALL-NODES.
    
    (values treetop all-nodes)))


;;;BUILD-TEXT-NETWORK: *******************************************************
;;;Read the node definitions in FILE (which is probably passed the value of
;;;OLD-RM-DEFS) and build flavor instances for each.  These are linked up so
;;;that the contents of the PARENT instance variable is a pointer to the 
;;;parent node.  The parent node of this tree structure is passed in as 
;;;TOP-NODE-NAME.  Return a pointer to the top of the created tree.

(defun build-text-network (directory)
  (let ((treetop)
	(all-nodes))

    ;;Part I: Open the NODEDEFS file -- NODEDEFS.L in the named directory --
    ;;and build DOCUMENT-NODE instances (without pointers) for each.

    (multiple-value
      (treetop all-nodes)
      (build-basic-nodes directory))

    ;;Part II: Sweep over the list of ALL-NODES and, for each node, replace
    ;;properties that are really pointers to other nodes with those pointers.

    (set-up-inter-node-pointers all-nodes)

    ;;Part IIb: Walk through the network (according to the CHILDREN
    ;;property), and set up the NEXTNODE/PRIORNODE links.

    (set-up-next-and-prior-links treetop)

    ;;Part III: Read through the whole document, find the starting
    ;;and ending byte positions for the sections, and install these positions
    ;;in the appropriate instance variables.

    (set-up-byte-pointers directory)

    ;;Part IV: Check all the nodes and look for any whose byte pointers
    ;;might not have gotten set up properly.

    (check-byte-pointers all-nodes)

    ;;All done -- return the pointer to the created node.

    treetop))

;;;CHECK-BYTE-POINTERS: ******************************************************
;;;Look through all the nodes on NODELIST and make sure that each readable
;;;node has a non-zero STARTINGBYTE.  If such a thing is found, warn the
;;;user (but keep on checking the rest of the list).

(defun check-byte-pointers (nodelist)
  (loop for node in nodelist
	do
	
	;;Check the starting and ending bytes of this node -- if this node is
	;;readable and its STARTINGBYTE is 0, the marker for this sections is
	;;almost certainly masked by a font marker.  Alert the user.
	
	(cond ((and (send node ':readable)
		    (zerop (send node ':startingbyte)))
	       (format t "~2%Warning: ~~a~"
		       (format
			 nil
			 "There is a problem with the section marker ~a.
Either there is a font-change character sequence on the same line
as the section marker in the document file, or all the other nodes 
in the nodedefs file are referring to this node by some other name.
Check the files, correct the problem, and reinstall the document."
			 (send node ':name)))))))


;;;GET-PROPERTY-FROM-ITEMARGS: ***********************************************
;;;Given a key and an alist, return just the item associated with the key.

(defun get-property-from-itemargs (prop itemarglist)
  (second (assoc prop itemarglist)))


;;;INSTALL-NEW-DOCUMENT: *****************************************************
;;;In the named directory, there are several files, including:
;;;
;;;	NODEDEFS.L: Node definitions to be processed by BUILD-TEXT-NETWORK
;;;	DOCUMENT.TXT: The document to be displayed.
;;;
;;;This function will run BUILD-TEXT-NETWORK over the NODEDEFS and DOCUMENT
;;;files, creating database entries for the document.  The pointer returned by
;;;BUILD-TEXT-NETWORK is then stuffed into *ALL-KNOWN-DOCUMENTS*'s CHILDREN
;;;property.  Note that the directory name must NOT have "//" at the end...
;;;The document's provided LONGLABEL and SHORTLABEL are stuffed into
;;;*DOCUMENT-LONG-LABELS* and *DOCUMENT-SHORT-LABELS*, respectively.
;;;
;;;This must be executed inside the BROWSER package, either explicitly
;;;(by doing a pkg-goto) or implicitly (by being in the BROWSER package
;;;in the editor or by loading this file which specifies the BROWSER
;;;package

;;;The POINTER-NAME argument will have the tree pointer stuffed into it; this
;;;may be useful only for debugging once the installation is over.

(defun install-new-document (label longlabel shortlabel directory pointer-name
			     release-number)
  (let ((evaled-pointer-name)
	(existing-document-entry (assoc label *manual-directory-alist*)))
    
    ;;Before doing anything else, see if LABEL has already been defined.
    ;;If it has, allow the user option of re-installing the
    ;;document, which requires modifying some of the globals.  If the
    ;;user doesn't want to redefine, then do an FERROR.
    
    (cond (existing-document-entry
	   (cond ((equal label (first existing-document-entry))
		  (format t "The directory ~s already contains the document ~a.~
			  ~&If you continue, you will redefine ~a."
			  (second existing-document-entry)
			  (first existing-document-entry)
			  label))
		 ((not (equal label (first existing-document-entry)))
		  (format t "The directory ~s already contains the document ~a. ~
			  ~&If you continue, you will clobber ~a with ~a."
			  (second existing-document-entry)
			  (first existing-document-entry)
			  label
			  (first existing-document-entry))))
	   (cond ((yes-or-no-p
		    (format nil "Do you want to continue? ")
		    terminal-io)
		  
		  ;;Reinstallation: get rid of the pointer to this
		  ;;document in *ALL-KNOWN-DOCUMENTS*, remove any
		  ;;information about this document in *DOCUMENT-LONG-LABELS*,
		  ;;*DOCUMENT-SHORT-LABELS*, and *MANUAL-DIRECTORY-ALIST*,
		  ;;and let the session continue.
		  
		  (send *all-known-documents* ':set-children
			(loop for kid in (send *all-known-documents*
					       ':children)
			      unless (equal (send kid ':name) label)
			      collect kid))
		  (setq *document-long-labels*
			(loop for item in *document-long-labels*
			      unless (equal (first item) label)
			      collect item))
		  (setq *document-short-labels*
			(loop for item in *document-short-labels*
			      unless (equal (first item) label)
			      collect item))
		  (setq *manual-directory-alist*
			(loop for item in *manual-directory-alist*
			      unless (equal (first item) label)
			      collect item)))
		 
		 ;;Here, the user has chosen against reinstallation, which
		 ;;means that he's trying to put two documents into the
		 ;;same directory, which means that he doesn't know what
		 ;;he's doing.  FERROR him out.
		 
		 (t (beep)
		    (ferror "You seem to be trying to install two documents ~
			     in the same directory.~
			     ~%Please read the Browser installation ~
 			     instructions to find out why you ~
			     ~%can't do this.")))))
    
    ;;We can proceed with (re)installation here.  Build the network and
    ;;install it.
    
    (setq evaled-pointer-name
	  (set pointer-name (build-text-network directory)))
    (send evaled-pointer-name
	  ':set-parent (list *all-known-documents*))
    (send *all-known-documents* ':set-children
	  (cons evaled-pointer-name
		(send *all-known-documents* ':children)))
    
    ;;Insert the long and short labels into the appropriate global
    ;;lists.
    
    (push (list label longlabel) *document-long-labels*)
    (push (list label shortlabel) *document-short-labels*)
    
    ;;Insert the appropriate directory information onto
    ;;*MANUAL-DIRECTORY-ALIST*
    
    (setq *manual-directory-alist*
	  (cons (list label directory)
		(remove (assoc label *manual-directory-alist*)
			*manual-directory-alist*)))
    
    ;;Hang the release number off LABEL's plist
    
    (putprop label release-number 'release-number)
    
    ;;Return the pointer to the new tree
    
    evaled-pointer-name))


;;;LINK-UP-CHILDREN: *********************************************************
;;;Called by SET-UP-NEXT-AND-PRIOR-LINKS; does the dirty work of actually
;;;installing the NEXT/PRIOR links between nodes.

(defun link-up-children (list-of-kids)
  (let* ((first-kid (first list-of-kids))
	 (second-kid (second list-of-kids))
	 (middle-kids (cdr (reverse (cdr (reverse list-of-kids)))))
	 (next-to-last-kid (second (reverse list-of-kids)))
	 (last-kid (car (last list-of-kids))))

    ;;Build a NEXTNODE / PRIORNODE link between the first and second kid.

    (send first-kid ':set-nextnode (list second-kid))
    (send second-kid ':set-priornode (list first-kid))

    ;;If there is more than one middle kid (which there may not be, as if
    ;;there are 2 or 3 kids in LIST-OF-KIDS), set up NEXTNODE / PRIORNODE
    ;;links between each, consecutively.

    (cond ((> (length middle-kids) 1)
	   (loop for kid-sublist on middle-kids
		 while (> (length kid-sublist) 1)
		 do
		 (send (first kid-sublist)
		       ':set-nextnode (list (second kid-sublist)))
		 (send (second kid-sublist)
		       ':set-priornode (list (first kid-sublist))))))

    ;;Finally, set up links between the NEXT-TO-LAST kid and the last KID.

    (send next-to-last-kid ':set-nextnode (list last-kid))
    (send last-kid ':set-priornode (list next-to-last-kid))))


;;;LOWER-OR-EQUAL-ORDER-MARKER-P: *******************************************
;;;Non-null if MARKER1 is "lower or equal order" than MARKER2:
;;;(LOWER-ORDER-MARKER-P 'SUBSECTION 'CHAPTER) => T and
;;;(LOWER-ORDER-MARKER-P 'SUBSECTION 'SUBSECTION) => T

(defun lower-or-equal-order-marker-p (marker1 marker2)
  (cond ((not (member marker1 *document-type-hierarchy*))
	 (ferror "~a not a member of *DOCUMENT-TYPE-HIERARCHY*" marker1))
	((not (member marker2 *document-type-hierarchy*))
	 (ferror "~a not a member of *DOCUMENT-TYPE-HIERARCHY*" marker2))
	(t (member marker1
		     (member marker2 *document-type-hierarchy*)))))


;;;MAKE-A-LIST: *************************************************************
;;;If OBJ isn't already a list, put it in one.

(defun make-a-list (obj)
  (cond ((or (null obj) (listp obj)) obj)
	(t (list obj))))


;;;READ-SECOND-ITEM-FROM-STRING: **********************************************
;;;Read the second thing out of a string; returns the thing and the starting
;;;position of the third item (if any).  VAL appears just to keep the compiler 
;;;quiet.

(defun read-second-item-from-string (string)
  (pkg-bind "BROWSER"
    (multiple-value-bind
      (val start)
	(read-from-string string)
      val
      (read-from-string string nil start))))


;;;READ-THIRD-ITEM-FROM-STRING: **********************************************
;;;Read the third thing out of a string; returns the thing and the starting
;;;position of the fourth item (if any).  VAL appears just to keep the
;;;compiler quiet.

(defun read-third-item-from-string (string)
  (pkg-bind "BROWSER"
    (multiple-value-bind
      (val start)
	(read-second-item-from-string string)
      val
      (read-from-string string nil start))))


;;;SET-UP-BYTE-POINTERS: ******************************************************
;;;Find the starting and ending byte positions for the sections, and install 
;;;these positions in the appropriate instance variables.

(defun set-up-byte-pointers (directory)
  (let ((counter 0)
	(entrystack nil))
    
    ;;Open the file.
    (with-open-file (f (string-append
			 directory
			 (with_ct_load_subdir
			   "" (ct_load_get 'user:docfilname))) ':in)
      
      ;;Read each of the lines in the file:
      
      (loop with line = nil
	    and newcounter = 0
	    and markertype = nil
	    and markingobject = nil		     
	    until (null (setq line (readline f nil)))
	    do
	    
	    ;;Get the length of this line, and add it into
	    ;;NEWCOUNTER.  Add one to take care of the newline
	    ;;ignored by READLINE.
	    
	    (setq newcounter (+ counter (string-length line) 1))
	    
	    ;;Is this a marker line?
	    
	    (cond ((user:marker-line-p line)
		   
		   ;;Yes -- get the marker type and marking object
		   ;;out of the line.
		   
		   (setq markertype
			 (read-second-item-from-string line))
		   (setq markingobject
			 (read-third-item-from-string line))

		   ;;If MARKINGOBJECT has no STARTINGBYTE property,
		   ;;something is definitely wrong.  Chances are
		   ;;that the name of the node in the document file's
		   ;;section marker is wrong.  Since we can't continue
		   ;;from here, do an explanatory FERROR.

		   (cond ((null (get markingobject 'document-node))
			  (ferror "The document node /"~a/" is unknown.  ~
				  You have probably either~
				  ~%misspelled this node in the NODEDEFS ~
				  file, or you have forgotten to define~
				  ~%/"~a/".  Correct the spelling of this ~
 				  name and try the installation ~
				  ~%again."
				  markingobject
				  markingobject)))
		   
		   ;;Set MARKINGOBJECT's STARTINGBYTE pointer to
		   ;;NEWCOUNTER -- start with the line just
		   ;;after past the marker.
		   
		   (send (get markingobject 'document-node)
			 ':set-startingbyte newcounter)
		   
		   ;;Close out all entries on ENTRYSTACK of equal or
		   ;;lower priority: set its ENDINGBYTE to COUNTER --
		   ;;end with the line before the marker.
		   
		   (loop with entry = nil
			 and closed-out-node = nil
			 while (and (setq entry (first entrystack))
				    (lower-or-equal-order-marker-p
				      (first entry) markertype))
			 do
			 (setq closed-out-node
			       (get (second entry) 'document-node))
			 (send closed-out-node ':set-endingbyte counter)

			 ;;Pop the stack and try the next item.

			 (pop entrystack))

		   ;;Push the new entry -- (MARKERTYPE MARKINGOBJECT) --
		   ;;onto ENTRYSTACK, and quit the COND.

		   (push (list markertype markingobject) entrystack)))
	    
	    ;;In any case, move NEWCOUNTER into COUNTER and read
	    ;;the next line.
	    
	    (setq counter newcounter))
      
      ;;We're at end of file -- close up all pending entries.
      
      (loop until (null entrystack)
	    do
	    (send (get (second (first entrystack)) 'document-node)
		  ':set-endingbyte counter)		     
	    (pop entrystack)))))


;;;SET-UP-INTER-NODE-POINTERS: ***********************************************
;;;Build the pointers between the nodes on ALL-NODES.

(defun set-up-inter-node-pointers (nodelist)
  (loop for node in nodelist
	do
	
	;;For this DOCUMENT-NODE, replace the PARENT, CHILDREN, PRIORNODE,
	;;and NEXTNODE properties with the appropriate pointers.
	;;These are LISTS of the pointers, even if there is only
	;;thing in the list.		 
	
	(loop for prop in '(:parent :children :priornode :nextnode)
	      for setprop in '(:set-parent :set-children
			       :set-priornode :set-nextnode)
	      do
	      (send node setprop
		    (reverse
		      (loop for item in (make-a-list (send node prop))
			    when item
			    append (cond ((get item 'document-node)
					  (list (get item 'document-node)))
					 (t (format
					      t "~2%Warning: ~~a~"
					      (format nil
"In the nodedefs file, the node ~a refers to the node /"~a/"
in its ~a field.  However, no node with this name has been defined.
/"~a/" is probably a misspelling of the name of a node that has been
defined.  Check the definition of ~a in the nodedefs file, correct
the error, and reinstall the document."
					      (send node ':name)
					      item
					      prop
					      item
					      (send node ':name)))
					    nil))))))
	
	;;Install the cross-references (if any): replace the (label pointer)
	;;list with a pointer to a DOCUMENT-XREF node containing the
	;;appropriate information.
	
	(cond ((first (send node ':xrefs))

	       ;;First, instantiate the list of cross-references...

	       (send node ':set-xrefs
		     (loop for item in (send node ':xrefs)
			   do
			   (cond ((not (get (first item)
					    'document-node))
				  (format
					      t "~2%Warning: ~~a~"
					      (format nil
"In the nodedefs file, the node ~a refers to the node /"~a/"
in its XREFS field.  However, no node with this name has been defined.
/"~a/" is probably a misspelling of the name of a node that has been
defined.  Check the definition of ~a in the nodedefs file, correct
the error, and reinstall the document."
						(send node ':name)
						(first item)
						(first item)
						(send node ':name)))))
			   when
			   (get (first item) 'document-node)
			   collect (make-instance
				     'document-xref
				     ':label (second item)
				     ':referenced-node
				     (get (first item) 'document-node))))

	       ;;...then instantiate any labels that might need to have
	       ;;their LONGLABEL labels by the actual label.

	       (loop for xref in (send node ':xrefs)
		     when (equal (send xref ':label) 'longlabel)
		     do (send xref ':set-label
			      (send (send xref ':referenced-node)
				    ':longlabel)))))))


;;;SET-UP-NEXT-AND-PRIOR-LINKS: **********************************************
;;;For the given tree, see if the current top node has more than one
;;;child.  If it does, set up NEXTNODE and PRIORNODE links among them
;;;Then, recurse down the tree -- recurse even if the current child
;;;doesn't need to have any links created.

(defun set-up-next-and-prior-links (top-of-tree)
  (let ((kids (send top-of-tree ':children)))
    
    ;;Does TOP-OF-TREE have more than one child?
    
    (cond ((> (length kids) 1)
	   
	   ;;Yes: set up the links between the kids, assuming that the
	   ;;kids are in order.
	   
	   (link-up-children kids)))
    
    ;;If there are any children at all, call this function on each one.
    
    (loop for kid in kids
	  do (set-up-next-and-prior-links kid))))



;;;Assorted functions:


;;;BUILD-FONTED-MENU-LIST: ***************************************************
;;;Given a list of menu items and a font, create a list of entries for a
;;;call to SET-ITEM-LIST that will font the items appropriately.  Sublists
;;;probably have :NO-SELECT information in them; tack the font information
;;;onto the end.  FONTLIST is a list of (normal-item-font header-item-font).

(defun build-fonted-menu-list (l fontlist)
    (loop for item in l
	  collect
	  (cond ((listp item)
		 (append item
			 (list ':font (second fontlist)
			       ':documentation "Move to this item.")))
		(t `(,item
		     :value ,item
		     :font ,(first fontlist)
		     :documentation "Move to this item.")))))


;;;COMPUTE-LARGEST-POSSIBLE-FONT: ********************************************
;;;Given a list of items, compute the largest possible font that will allow 
;;;all the items to be displayed on one page, undershooting if necessary.
;;;Note the forcing to floating arithmetic....

(defun compute-largest-possible-font (itemlist pane)
  (let* ((number-of-items (length itemlist))
	 (pane-pixels (send pane ':inside-height))
	 (vsp (send pane ':vsp))
	 (n-pixels (quotient (difference (float pane-pixels)
					 (times vsp number-of-items))
			     number-of-items)))
    
    ;;The number of pixels needed for a character is:
    ;; [ PANE-PIXELS - [VSP * NUMBER-OF-ITEMS]] / NUMBER-OF-ITEMS.
    ;;Compute this and find the best-fitting font from *FONT-SIZE-LIST*
    
    (loop with first-font = nil
	  and second-font = nil
	  for font-list on *font-size-list*
	  do
	  (setq first-font (first font-list)
		second-font (second font-list))
	  (cond

	    ;;If we're looking at the first item on *FONT-SIZE-LIST* and
	    ;;N-PIXELS is already smaller than that, we have to use that
	    ;;(smallest) font.

	    ((and (eq first-font (first *font-size-list*))
		  (greaterp (first first-font) n-pixels))
	     (return (cdr first-font)))

	    ;;If N-PIXELS is greater than that of the first item, but less than
	    ;;that of the second, use the first font.
	    
	    ((and (greaterp n-pixels (first first-font))
		  (numberp (first second-font))
		  (greaterp (first second-font) n-pixels))
	     (return (cdr first-font)))

	    ;;If we're looking at the last item, there's room to spare: use the
	    ;;largest font.

	    ((eq first-font (car (last *font-size-list*)))
	     (return (cdr first-font)))))))


;;;CREATE-TOPIC-MENU: *******************************************************
;;;Convert a list of menu items obtained from GET-ACCESSIBLE-NODES-AND-FILES
;;;into a real menu item list, with major unselectable headings and spacing.
;;;These items will be displayed in MENU-PANE, which is needed for 
;;;COMPUTE-LARGEST-POSSIBLE-FONT.

(defun create-topic-menu (fold itemlist menu-pane browserenv)
  (let* ((docname (send fold ':documentname))
	 (iteml (append
		  `((,(format nil "This is Browser ~a."
			      (send browserenv ':number)
			      user:*browser-release*)
			    :no-select nil))
		  (cond ((send fold ':documentname)
			 `((,(format
			       nil "You are currently in ~a (Version ~a)."
			       (get-document-pname docname)
			       (get (send fold ':documentname)
				    'release-number))
			    :no-select nil))))
		  `((,(string-append "You are currently at " '!"
			  (send fold ':shortlabel) '!" ".")
		     :no-select nil))
		  `(("" :no-select nil))
		  (loop for item in itemlist
			when (first (third item))
			append
			`((,(second item) :no-select nil)
			  ,@(loop for subitem in (third item)
				  collect
				  (string-append
				    "     "
				    (send subitem ':longlabel)))
			  ("" :no-select nil)))
		  (cond ((send fold ':readable)
			 `((,(format nil "Read the text (~d characters):"
				     (1+ (- (send fold ':endingbyte)
					    (send fold ':startingbyte))))
			    :no-select nil)
			   ,(string-append "     " (send fold ':longlabel))
			   ("" :no-select nil))))
		  (cond ((send fold ':xrefs)
			 `("Cross references"))))))
    (build-fonted-menu-list
      iteml
      (compute-largest-possible-font iteml menu-pane))))


;;;GET-DOCUMENT-ABBR: ********************************************************
;;;Given a document name, return a short abbreviation for the nodestack menu.
;;;The list this uses is built up from calls to INSTALL-NEW-DOCUMENT.

(defun get-document-abbr (doc)
  (cond ((second (assoc doc *document-short-labels*)))
	(t "")))


;;;GET-DOCUMENT-PNAME: *******************************************************
;;;Given a document name, return a print name for display as the "current
;;;document".  The list this uses is built up from calls to 
;;;INSTALL-NEW-DOCUMENT.

(defun get-document-pname (doc)
  (cond ((second (assoc doc *document-long-labels*)))
	(t "")))


;;;MASSQ: *******************************************************************
;;;Do an ASSQ on each of the things in KEYS against ASSOCLIST, and return as
;;;soon as something is found.

(defun massq (keys assoclist)
  (loop for item in keys
	with val = nil
	do
	(cond ((setq val (assoc item assoclist))
	       (return val)))))


;;;PARENT-TYPE: *************************************************************
;;;Look up the list of document levels and find the one BEFORE the level in
;;;TYPE.

(defun parent-type (type)
    (cadr (member type (reverse *document-type-hierarchy*))))




;;;PROCESS ADDITIONS: 3/19/84
;;;

;;;Compile the flavor methods...

(compile-flavor-methods
  document-node browser browser-environment left-command-menu-with-typeout
  unscrolling-command-menu-pane scrolling-command-menu-pane left-command-menu)

(defun find-me-a-browser ()
  (if (typep tv:selected-window 'browser) (tv:beep)
      (let ((found (tv:find-window-of-flavor 'browser)))
	(if found (send found ':select)
	    (send (tv:make-window 'browser ':activate-p t) ':select)))))

(declare (special user:*release* user:*db%release* zwei:*adamode-release*))

;;;Install the interpreter debugger manual
(defun install-intd-document (directory)
  (format t "~%Installing Interpreter//Debugger User Manual...")
  (install-new-document
    'interpdebug
    "the Interpreter//Debugger User Manual"
    "Interp//Debug"
    directory
    '*interpdebug-pointer*
    (if (and (boundp 'user:*release*) (boundp 'user:*db%release*))
	(string-append "Beta " user:*release* "//" user:*db%release*)
      "Beta release")))
    
;;;Install the Browser user manual
(defun install-browser-document (directory)
  (format t "~%Installing Browser User Manual...")
  (install-new-document
    'browser
    "the Browser User Manual"
    "Browser"
    directory
    '*browser-pointer*
    user:*browser-release*))
    
(defvar user:*lrm-release*);this should really be in the lrm document itself
;;;Install the lrm
(defun install-lrm-document (directory)
  (format t "~%Installing Ada Language Reference Manual...")
  (install-new-document
    'lrm
    "the Ada Language Reference Manual"
    "LRM"
    directory
    '*lrm*
    (if (and (boundp 'user:*lrm-release*) (stringp user:*lrm-release*))
	user:*lrm-release*
	"Test")))
    
;;;Install the editor
(defun install-editor-document (directory)
  (format t "~%Installing Ada Mode Editor Manual...")
  (install-new-document
    'editor
    "the Ada Mode Editor Manual"
    "EDITOR"
    directory
    '*editor*
    (if (and (boundp 'zwei:*adamode-release*) (stringp zwei:*adamode-release*))
	zwei:*adamode-release*
	"Test")))
    
(defvar *all-known-documents*)
(defun init-browser (system-key browser-man-directory)
  
  (tv:add-system-key
      (char-upcase (character system-key))
      'browser "Documentation Browser"
      '(cond ((not (tv:find-window-of-flavor 'browser))
	      (send (tv:make-window 'browser ':activate-p t) ':select))))
 
  (tv:add-to-system-menu-programs-column
    "Browser"
    '(find-me-a-browser)
    "Computer * Thought Documentation Browser")

  ;;Instantiate a network node of flavor TEXTNODE for the top of the 
  ;;"Available documents" node.  Additional documents can then be built 
  ;;from their top node and tacked onto the CONTAINS-DOCUMENTS instance
  ;;variable of this node.  Note that the defvar insures that the old
  ;;value of *ALL-KNOWN-DOCUMENTS* will be used if it exists.
  
  (setq *all-known-documents*
	  (make-instance 'document-node
			 ':documentname 'browser
			 ':type 'documents
			 ':name '*all-known-documents*
			 ':longlabel "Available Documents"
			 ':shortlabel "Available Documents"
			 ':readable nil
			 ':parent nil
			 ':children nil))
  
  ;;Activate the browser window/process

  (tv:make-window 'browser ':activate-p t)
  (install-browser-document browser-man-directory)

;; added by NIC 3/4/86

  (install-lrm-document "ct:doc;ada;")
  (install-intd-document "ct:doc;interp;")
  (install-editor-document "ct:doc;editor;")
  
;; end additions

  )

;;; eof
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;