;;; -*- Mode:Common-Lisp; Package:ZWEI; Fonts:(CPTFONT CPTFONTB CPTFONTI); Base:10 -*- ;;; ;;; RESTRICTED RIGHTS LEGEND ;;;Use, duplication, or disclosure by the Government is subject to ;;;restrictions as set forth in subdivision (c)(1)(ii) of the Rights in ;;;Technical Data and Computer Software clause at 52.227-7013. ;;; ;;; TEXAS INSTRUMENTS INCORPORATED. ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; MS 2151 ;;; ;;; Copyright (C) 1987-1989 Texas Instruments Incorporated. All rights reserved. ;;; File contains the flavor, global variable, and command table definitions ;;; used by the Document Viewer Client. ;;; CHANGE HISTORY started on 10/22/87 ;1;; 12-21-88 MAY Changed *com-find-previous1, *com-find-next1, *com-find-superior1,* ;1;; *com-show-page1, and *com-list-of-manuals1 to deexpose the mini-buffer.* ;;; 10/31/87 slm Change COM-LIST-OF-MANUALS and COM-TABLE-OF-CONTENTS to move (point) ;;; to the beginning of the buffer when they are through. Avoids error-handler ;;; due to (point) being left outside the window. ;;; 10/31/87 slm Change case of "VISIDOC" to "Visidoc" in all documentation strings, ;;; COM-DOC-VIEWER-HELP, and the item in the System Menu. ;================================================================================ ; PARAMETERS AND VARIABLES (defparameter *doc-viewer-header* "Visidoc Utility~%") (defvar *user-request-history-file* nil) (defvar *zmacs-doc-viewer-list* nil) (defvar *zmacs-doc-viewer-buffer-name-alist* nil) (defvar *apropos-list* '(())) (defvar *doc-viewer-request-history* nil) (DEFVAR *contracted-line-font* fonts:hl10b "The font to use when displaying a mouseable 'contracted-text line'.") (DEFVAR *minimum-pixel-width-for-text* 774 "This is the number of pixels needed by the viewer to display a translated line of text on the screen without wrapping. You get this number by calculating the following: (* (* width-of-printed-text-in-inches viewing-adjustment) number-pixels-per-inch) where width-of-printed-text-in-inches = 6.35 viewing-adjustment (from translation process) = 1.4 number-pixels-per-inch = 87 Hopefully, we'll get this number from the namespace instead of keeping the translator's viewing adjustment parameter.") (defconstant doc-viewer-general-mouse-menu-alist '(("Get New Documentation" . com-doc-viewer-2) ("List of Manuals" . com-list-of-manuals) ("Table of Contents" . com-table-of-contents) ("Find..." . com-doc-viewer-apropos) ("" :no-select ignore) ("View Next Topic" . com-find-next) ("View Previous Topic" . com-find-previous) ("View Surrounding Topic" . com-find-superior) ("View Request History" . com-view-reference-history) ("" :no-select ignore) ("Show Buffer Hierarchy" . com-show-buffer-hierarchy) ("Show Page Number" . com-show-page) ("Show Overview" . com-show-overview) ("" :no-select ignore) ("Expand Section" . com-expand-section) ("Contract Section" . com-contract-section) ("Save Request History" . com-save-history) ("Restore Request History" . com-restore-history) ("List Visidoc buffers" . com-list-doc-viewer-buffers) ("List All Buffers" . com-list-buffers) ("Kill or Save Buffers" . com-kill-or-save-buffers) ("" :no-select ignore) ("HELP" . com-doc-viewer-documentation) ("EXIT" . com-doc-viewer-exit))) ;================================================================================ ; FLAVORS (DEFFLAVOR ht-node ((name nil) (link nil) (exposed-p nil) (type :unbound)) (node) :settable-instance-variables (:ordered-instance-variables first-bp last-bp tick next previous superior inferiors undo-status read-only-p si:property-list name link exposed-p type) :outside-accessible-instance-variables) zwei:(defflavor zwei-doc-viewer-buffer (pathname saved-major-mode read-only-p first-bp last-bp plist namespace-name ) (zmacs-buffer) :settable-instance-variables) (defflavor doc-viewer-interval () (node) :settable-instance-variables) (defflavor reference-node (expanded-p ;; instance variable values set in :after :init method ref-type chapter start end nth max-nth) (ht-node) :settable-instance-variables (:ordered-instance-variables first-bp last-bp tick next previous superior inferiors undo-status read-only-p si:property-list name link exposed-p type expanded-p ref-type chapter start end nth max-nth) :outside-accessible-instance-variables) ;================================================================================ ; DEFMAJOR "Visidoc" (DEFMAJOR com-doc-viewer-mode doc-viewer-mode "Visidoc" "Setup for Viewing Documentation Information" () (set-comtab *zmacs-control-x-comtab* '(#\r com-no-toggle-read-only)) (set-comtab *mode-comtab* '(#\sp com-down-real-line #\rubout com-up-real-line #\help com-doc-viewer-documentation #\undo com-beep ;;;;#\meta-control-l com-select-current-buffer #\abort com-doc-viewer-exit #\end com-doc-viewer-exit #\A com-doc-viewer-apropos #\a (0 #\A) #\E com-expand-section #\e (0 #\E) #\C com-contract-section #\c (0 #\C) #\H com-show-buffer-hierarchy #\h (0 #\H) #\L com-list-of-manuals #\l (0 #\L) #\O com-show-overview #\o (0 #\O) #\S com-toggle-section-expansion #\s (0 #\S) #\T com-table-of-contents #\t (0 #\T) #\V com-view-reference-history #\v (0 #\V) #\N com-find-next #\n (0 #\N) #\P com-find-previous #\p (0 #\P) #\U com-find-superior #\u (0 #\U) #\# com-show-page #\mouse-l-1 com-doc-viewer-find-highlighted-string #\mouse-r-1 com-doc-viewer-general-mouse-menu )) (set-mode-line-list (mode-line-list)) (set-mouse-documentation)) (DEFPROP doc-viewer-mode doc-viewer-mouse-highlight-function highlight-function) ;================================================================================ ; COMTABS ;;;Hypertext-ish commands (DEFCOM com-contract-section "Contract a section." () (LET ((node (contract-reference (line-node (bp-line (point)))))) (move-bp (point) (interval-first-bp node)) (update-history node) (SETF (window-redisplay-degree *window*) DIS-TEXT) (SEND *window* :redisplay :ABSOLUTE nil nil nil)) DIS-NONE) (DEFCOM com-expand-section "Expand a section." () (LET ((node (expand-reference (line-node (bp-line (point)))))) (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) (defcom com-toggle-section-expansion "Toggle the expansion/contraction of a section." () (IF (node-expandedp (line-node (bp-line (point)))) (FUNCALL #'com-contract-section) (FUNCALL #'com-expand-section))) (DEFCOM com-find-previous "Find and go to the current node's previous reference." () (check-mini-buffer-deexposed) ;1; may 12-21-88* (LET ((node (find-reference (line-node (bp-line (point))) :previous))) ;1;(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) (DEFCOM com-find-next "Find and go to the current node's next reference." () (check-mini-buffer-deexposed) ;1; may 12-21-88* (LET ((node (find-reference (line-node (bp-line (point))) :next))) (update-history node) (SETF (window-redisplay-degree *window*) DIS-TEXT) (SEND *window* :redisplay :START (POINT) nil nil)) DIS-NONE) (DEFCOM com-find-superior "Find and go to the current node's superior reference." () 1 *(check-mini-buffer-deexposed) ;1; may 12-21-88* (LET ((node (find-reference (line-node (bp-line (point))) :superior))) (update-history node) (SETF (window-redisplay-degree *window*) DIS-TEXT) (SEND *window* :redisplay :START (POINT) nil nil)) DIS-NONE) ;;;; (DEFUN show-page (node) "Displays in the Mini-Buffer which page in which document this node is from" (LET ((page (doc-node-page node))) (WHEN page (SEND *query-io* :clear-screen) (FORMAT *query-io* "~%~s is on page ~a in the ~a manual." (SEND node :name) page (manual-name node))))) (DEFCOM com-show-page "Show the page number for node at point" (&aux node) (check-mini-buffer-deexposed) ;1; may 12-21-88* (MULTIPLE-VALUE-bind (IGNORE node) (node-expandedp (bp-node (point))) (show-page node)) dis-none) (DEFCOM com-list-of-manuals "List the available online manuals, and get the table of contents for the selected item." () (check-mini-buffer-deexposed) ;1; may 12-21-88* (LET ((manuals (list-of-manuals)) manual buffer) (SETQ manual (w:menu-choose manuals :label "Select an on-line Reference Manual" :item-alignment :center :columns 1)) (WHEN manual (IF (SETQ buffer (find-doc-viewer-buffer-named manual)) (SEND buffer :select) (get-table-of-contents manual)))) (move-bp (point) (interval-first-bp *interval*)) (SETF (window-redisplay-degree *window*) DIS-TEXT) (SEND *window* :redisplay :START (POINT) nil nil) DIS-NONE) (DEFCOM com-table-of-contents "Get the current buffer's table of contents" () (get-table-of-contents (AND (TYPEP *interval* 'zwei:zwei-doc-viewer-buffer) (SEND *interval* :namespace-name))) (move-bp (point) (interval-first-bp *interval*)) (SETF (window-redisplay-degree *window*) DIS-TEXT) (SEND *window* :redisplay :START (POINT) nil nil) DIS-NONE) (DEFPROP com-doc-viewer-general-mouse-menu "Visidoc Menu" :mouse-short-documentation) (defcom com-doc-viewer-general-mouse-menu "Offer a menu of general Visidoc operations." () (USING-RESOURCE (menu menu-command-menu doc-viewer-general-mouse-menu-alist) (send menu :set-label " Visidoc General Menu ") (let ((command (funcall menu :choose))) (WHEN command (funcall command))) (SEND *window* :select) dis-none)) (defcom com-doc-viewer "Visidoc" () (com-doc-viewer-general-mouse-menu)) (defcom com-document-next-definition "Find next definition of node under (point)" () (LET (ret-val lookup-nth) (BEEP) (MULTIPLE-VALUE-BIND (IGNORE ignore ignore node) (node-expandedp (bp-node (point))) (IF (CONSP (SETQ ret-val (get-stuff-from-doc-server (SEND node :name)))) (COND ((TYPEP (CAR ret-val) 'zwei:reference-node) (SETQ lookup-nth (IF (EQ (SEND node :nth) (SEND node :max-nth)) 0 (SEND node :nth))) (SETQ node (DOLIST (n ret-val) (WHEN (= lookup-nth (SEND n :nth)) (RETURN n)))) (expand-reference node)) ((EQ :multiple-attributes (SECOND ret-val)) (doc-viewer-top-level (SEND node :name) (manual-name node) (OR (AND (= (SEND node :nth) (SEND node :max-nth)) 0) (1+ (SEND node :nth))))) ) ;;cond (tv:notify nil "There are no other references for ~s" (SEND node :name))) )) ;;let dis-none) (defcom com-document-next-definition "Find next definition of node under (point)" () dis-none) (defcom com-doc-viewer-2 "Visidoc" () (kill-new-buffer-on-abort (*interval*) (if (typep *interval* 'zwei-doc-viewer-buffer) (IF *numeric-arg-p* (com-document-next-definition) (doc-viewer-top-level (read-function-name "Document" nil nil t))) (doc-viewer-top-level (read-function-name "Document" (relevant-function-name (point)) nil t))))) (defcom com-doc-viewer-apropos "Pops up a series of menus to collect the Visidoc aprops info" () (doc-viewer-apropos) dis-none) (DEFPROP com-doc-viewer-find-highlighted-string "View Cross Reference" :mouse-short-documentation) (defcom com-doc-viewer-find-highlighted-string "Find Reference from Mouse box" () (MULTIPLE-VALUE-BIND (line start end) ;;; start-loc end-loc start-y height) (highlighted-string-under-mouse *window*) (IF line (IF (node-expandedp (line-node line)) (doc-viewer-top-level (Fonted-STRING-TRIM '(#\space #\( #\[ #\] #\)) (SUBSEQ line start end))) (progn (move-bp (point) line 0) (funcall #'com-expand-section) ;;(expand-reference (line-node line)) dis-text)) (funcall 'com-mouse-mark-region) dis-none))) (DEFUN fonted-string-trim (char-set string &aux i j) "Does exactly what STRING-TRIM does, but disregards fonts. Returns a copy of STRING with all characters in CHAR-SET removed at both ends. CHAR-SET can be a list of characters or a string. As of now, case is ignored in comparisons." (setq i (string-search-not-set char-set string 0 () nil)) (cond ((null i) "") (t (setq j (string-reverse-search-not-set char-set string () 0 nil)) (ZLC:SUBSTRING string i (1+ j))))) (defcom com-list-doc-viewer-buffers "Print a list of the all Visidoc buffers and their files (or sizes)." () (let* ((star-flag nil) (plus-flag nil) (eqv-flag nil) (circle-plus-flag nil) (max-size (min 40. (- (funcall *STANDARD-OUTPUT* :size-in-characters) 40.))) (version-pos (min (max (+ (find-maximum-buffer-name-length max-size) 3) 16.) (+ max-size 2)))) (declare (special *zmacs-doc-viewer-list*)) (format t "~&Buffers in ZWEI:~% Buffer name:~vTFile Version:~vTMajor mode:~2%" version-pos (+ version-pos 20.)) (dolist (buffer *zmacs-doc-viewer-list*) ;;was *ZMACS-BUFFER-LIST* -- same thing, different ordering (let ((file-id (buffer-file-id buffer)) name flag) (write-char (cond ((eq file-id t) (setq plus-flag t) #\+) ;+ means new file, never written out ((buffer-read-only-p buffer) (setq eqv-flag t) #\) ; means read-only ((buffer-modified-p buffer) (setq star-flag t) #\*) ;* means has unsaved changes. (t #\Sp)) ;blank if unmodified. *STANDARD-OUTPUT*) (write-char #\Sp *STANDARD-OUTPUT*) (multiple-value-setq (name flag) (name-for-display buffer max-size)) (if flag (setq circle-plus-flag flag)) (let ((major-mode (buffer-major-mode buffer))) (funcall *STANDARD-OUTPUT* :item 'zmacs-buffer buffer "~A~vT~:[ [~D Line~:P]~*~;~*~@[~A~]~]~vT(~A)" name version-pos (and file-id (not (atom file-id)) (cdr file-id)) (if (or (null file-id) (atom file-id) (null (cdr file-id))) (count-lines-buffer buffer)) (buffer-version-string buffer) (+ version-pos 20.) (symbol-value major-mode))) (terpri *STANDARD-OUTPUT*))) (terpri *STANDARD-OUTPUT*) ;extra TERPRI to show you that it's finished. (and plus-flag (princ "+ means new file. " *STANDARD-OUTPUT*)) (and star-flag (princ "* means buffer modified. " *STANDARD-OUTPUT*)) (and eqv-flag (princ " means read-only. " *STANDARD-OUTPUT*)) (and circle-plus-flag (princ " means name truncated." *STANDARD-OUTPUT*)) (and (or plus-flag star-flag eqv-flag circle-plus-flag) (terpri *STANDARD-OUTPUT*)) dis-none)) (defcom com-select-current-buffer "Select the previously selected buffer. A numeric argument selects the argth previous buffer (the default argument is 2). With an argument of 1, rotates the entire buffer history, and a negative argument rotates the other way. This uses the order of buffers that is displayed by List Buffers." () (cond (*numeric-arg-p* (let ((temp-numeric-arg (1- *numeric-arg*))) (rotate-buffer-history (if (member *numeric-arg-p* '(nil :sign) :test #'eq) (* temp-numeric-arg 2) temp-numeric-arg)))) (t (send (car (history-contents (send *window* :buffer-history))) :select) dis-text))) (defcom com-select-doc-viewer-buffer "Select a Visidoc buffer by popping up a menu of online manuals. If a buffer for that manual exists, select it. If a buffer does NOT exist, create it and retrieve its table of contents." () (FUNCALL #'com-list-of-manuals) dis-none) (defun add-extended-command-to-comtab (extended-command comtab) (let ((command-to-add (if (symbolp extended-command) (cons (make-command-name extended-command) extended-command) extended-command))) (setf (comtab-extended-commands comtab) (adjoin command-to-add (comtab-extended-commands comtab) :test #'equal)))) (add-extended-command-to-comtab '("Visidoc" . com-doc-viewer-2) *zmacs-comtab*) (command-store 'com-doc-viewer-2 #\m-\c-\d *zmacs-comtab*) ;;;(w:add-to-system-menu-column ;;; :user-aids "Visidoc" '(view-on-line-documentation :selectp t) ;;; "Display pages of on-line manuals.") ;;; las - added calls to new sam functions (w:modify-system-access-spec 'visidoc :assign-defaults) (setf (sys:system-made-p 'visidoc) t) (defcom com-doc-viewer-documentation "Handle HELP Key" () (let ((*com-documentation-alist* (cons '(#\M com-doc-viewer-help) *com-documentation-alist*))) (com-documentation)) dis-none) (defcom com-doc-viewer-help "Supply documentation for Visidoc"() (format t "~:|~% Visidoc Online Documentation Viewer~% Visidoc finds documentation from the Explorer manuals which are online on a document server. Documentation can be viewed by: 1. Selecting Visidoc from the System Menu, or 2. Pressing the META-CTRL-SHIFT-D keys any time while in ZMACS. Once the document viewer is selected, you can type in a name or select one by clicking the mouse on a boxed item in the buffer. If that name is identified in the manuals, it will be brought in to a seperate Document Viewer buffer. While viewing documentation in the document viewer, you can point at any boldface string and click on it to read its definition for viewing. FINDING TEXT WITHIN THE DOCUMENT VIEWER Standard scrolling and browsing techniques in Zmacs will work in the document viewer. Other methods for finding text include: mousing items in the REQUEST HISTORY window; mousing items from the manual hierarchy which is viewed by clicking on the \"Show Manual Hierarchy\" command (or by pressing the h key); mousing items in the graphical hierarchy of the current reference's position in the manual viewed by clicking on the \"Show Overview\" command (or by pressing the o key). MANAGEMENT OF TEXT Text can be contracted into a single mousable line that signals the presence of a reference that is no longer visible. The text associated with this marker can be viewed again by expanding the section with a keystroke listed below, or by using any of the selection techniques mentioned above. To leave the document viewer, press the END key, or click on the \"Exit\" command in the Visidoc COMMANDS window. CURRENTLY DEFINED KEYSTROKES a apropos search for a name c Contract a section of text. e Expand a section of text. s Toggle expansion/contraction of text. t Table of Contents l List Available Manuals (and get table of contents) h Show Buffer Hierarchy o Show Overview # Show Page Number v View History in a typeout window p View Previous Topic n View Next Topic u View Surrounding Topic META-CTRL-SHIFT-D Get Documentation END Exit Visidoc For other available commands, select the Visidoc Menu by pressing ~:c." #\mouse-r-1) dis-none) (defcom com-doc-viewer-exit "Exit Visidoc buffer." () (funcall *window* :exit-special-buffer nil *interval*) dis-none) (defcom com-no-toggle-read-only "Disable the C-X R read only toggle" () (tv:notify nil "Don't toggle READ-ONLY in this buffer... you will probably lose!") dis-none) (DEFUN find-dox-section (node) "Find the desired section from a node" (doc-viewer-select-buffer nil (send node :climb-to-buffer)) (send node :link-and-expose) (unless (node-expandedp node) (expand-reference node)) (update-history node) (move-bp (point) (interval-first-bp node)) (SETF (window-redisplay-degree *window*) DIS-TEXT) (SEND *window* :redisplay :START (point) nil t)) (W:ADD-TYPEOUT-ITEM-TYPE *TYPEOUT-COMMAND-ALIST* Dox-Section "Find this section" find-dox-section 'find-dox-section "Find this section to read") (defun pretty-print-hierarchy (node &optional (indentation "")) (COND ((TYPEP node 'zwei-doc-viewer-buffer) (FORMAT *standard-output* "~%~a" indentation) (FORMAT *standard-output* "Buffer for ~a Manual" (SEND node :name))) ((eq :ask-superior (send node :expanded-p)) "") ((eq :unbound (send node :ref-type)) (FORMAT *standard-output* "~%~a" indentation) (format *standard-output* "Chapter ~a" (send node :name))) (t (FORMAT *standard-output* "~%~a" indentation) (SEND *standard-output* :item 'Dox-Section node "<<~s ~a>>" (send node :name) (send node :ref-type)))) (setq indentation (string-append " " indentation)) (dolist (inf (node-inferiors node)) (pretty-print-hierarchy inf indentation)) "") (defcom com-show-buffer-hierarchy "Show the structure of this Document Viewer buffer" () (pretty-print-hierarchy *interval*) (FORMAT *standard-output* "~2%Select any mouseable item, or ~a" w:*remove-typeout-standard-message*) dis-none) (DEFUN find-overview-section (somelist) "Find the desired section from an overview" (LET ((ret (EVAL somelist))) (WHEN (TYPEP ret 'reference-node) (update-history ret))) (SETF (window-redisplay-degree *window*) DIS-TEXT) (SEND *window* :redisplay :START (point) nil t)) (W:ADD-TYPEOUT-ITEM-TYPE *TYPEOUT-COMMAND-ALIST* Overview-Section "Find this section" find-overview-section 'find-overview-section "Find this section to read") (DEFUN pretty-print-overview (node) (LET* ((name (SEND node :name)) (sup (doc-node-superior node)) (prev (doc-node-previous node)) (next (doc-node-next node)) (infs (doc-node-inferiors node)) (indent 5) (string-width 25) (xpos (+ indent string-width)) ypos (widest 0) midline xpixel ypixel endxpix endypix thisendx) (SETQ ypos (MAX 7 (+ 2 (LENGTH infs)))) (DOTIMES (var ypos) (SEND *standard-output* :set-cursorpos 0 var :character) (SEND *standard-output* :clear-eol)) (SETQ midline (/ ypos 2.0)) ;;draw text for SUPERIOR and set pixel locations for lines (SEND *standard-output* :set-cursorpos indent midline :character) (IF sup (SEND *standard-output* :item 'overview-section `(find-reference ,node :superior ,sup) "~a" (IF (<= (LENGTH (THE string sup)) string-width) sup (SUBSEQ (THE string sup) 0 (1- string-width)))) (SEND *standard-output* :item 'overview-section '(move-bp (point) (interval-first-bp *interval*)) "~a" (FORMAT nil "~a manual" (manual-name node)))) (MULTIPLE-VALUE-SETQ (endxpix endypix) (SEND *standard-output* :read-cursorpos)) (INCF endxpix 3) (INCF endypix 3) (SETQ xpos (+ (SEND *standard-output* :read-cursorpos :character) indent)) ;;draw lines and text for the PREVIOUS reference (WHEN prev (SEND *standard-output* :set-cursorpos xpos (1- midline) :character) (MULTIPLE-VALUE-SETQ (xpixel ypixel) (SEND *standard-output* :read-cursorpos)) (SEND *standard-output* :draw-line endxpix endypix (- xpixel 3) (+ ypixel 3)) (SEND *standard-output* :item 'overview-section `(find-reference ,node :previous ,prev) "~a" (IF (<= (LENGTH (THE string prev)) string-width) prev (SUBSEQ (THE string prev) 0 (1- string-width)))) (SETQ widest (LENGTH (THE string prev)))) ;;draw lines and text for the NEXT reference (WHEN next (SEND *standard-output* :set-cursorpos xpos (1+ midline) :character) (MULTIPLE-VALUE-SETQ (xpixel ypixel) (SEND *standard-output* :read-cursorpos)) (SEND *standard-output* :draw-line endxpix endypix (- xpixel 3) (+ ypixel 3)) (SEND *standard-output* :item 'overview-section `(find-reference ,node :next ,next) "~a" (IF (<= (LENGTH (THE string next)) string-width) next (SUBSEQ (THE string next) 0 (1- string-width)))) (IF (< widest (LENGTH (THE string next))) (SETQ widest (LENGTH (THE string next))))) ;;draw lines and text for this reference... do this AFTER the other two because you want ;;to get pixel locations from the end of this reference (SEND *standard-output* :set-cursorpos xpos midline :character) (MULTIPLE-VALUE-SETQ (xpixel ypixel) (SEND *standard-output* :read-cursorpos)) (SEND *standard-output* :draw-line endxpix endypix (- xpixel 3) (+ ypixel 3)) (SEND *standard-output* :item 'overview-section `(IGNORE) "~a" (IF (<= (LENGTH (THE string name)) string-width) name (SUBSEQ (THE string name) 0 (1- string-width)))) (IF (< widest (LENGTH (THE string name))) (SETQ widest (LENGTH (THE string name)))) (SETQ thisendx (+ 3 (SEND *standard-output* :read-cursorpos))) ;;set "beginning" pixel locations for next set(s) of lines (if any) (SETQ xpos (+ xpos (IF (< widest string-width) widest string-width))) (SEND *standard-output* :set-cursorpos xpos midline :character) (MULTIPLE-VALUE-SETQ (endxpix endypix) (SEND *standard-output* :read-cursorpos)) (INCF endxpix 3) (INCF endypix 3) ;;draw lines and text of INFERIOR references (SETQ xpos (+ xpos indent)) (WHEN infs (WHEN (< thisendx endxpix) (SEND *standard-output* :draw-line thisendx endypix endxpix endypix)) (DO ((i (CAR infs) (CAR infs)) (ypos (- midline (- (/ (LENGTH infs) 2.0) 0.5)) (1+ ypos))) ((NULL i) (RETURN)) (SEND *standard-output* :set-cursorpos xpos ypos :character) (MULTIPLE-VALUE-SETQ (xpixel ypixel) (SEND *standard-output* :read-cursorpos)) (SEND *standard-output* :draw-line endxpix endypix (- xpixel 3) (+ ypixel 3)) (SEND *standard-output* :item 'overview-section `(find-reference ,node :inferior ,i) "~a" (IF (<= (LENGTH (THE string i)) string-width) i (SUBSEQ (THE string i) 0 (1- string-width)))) (SETQ infs (CDR infs)))) (SEND *standard-output* :set-cursorpos 0 (1- ypos) :character))) (defcom com-show-overview "Show the immediate surroundings of the current reference." () (MULTIPLE-VALUE-BIND (IGNORE node) (node-expandedp (bp-node (point))) (pretty-print-overview node) (FORMAT *standard-output* "~2%Select any mouseable item, or ~a" w:*remove-typeout-standard-message*) dis-none)) (DEFUN call-doc-top-level (list-arg) (doc-viewer-top-level (FIRST list-arg) (SECOND list-arg) (THIRD list-arg))) (W:ADD-TYPEOUT-ITEM-TYPE *TYPEOUT-COMMAND-ALIST* doc-top-level "Find this section" call-doc-top-level 'call-doc-top-level "Find the text for this section using doc-viewer-top-level") (defun view-reference-history (&aux tlist) (dolist (item *doc-viewer-request-history*) (format *standard-output* "~%") (IF (STRING-EQUAL "APROPOS:" (SUBSEQ (CAR item) 0 8)) (SEND *standard-output* :item 'overview-section `(execute-apropos-menu-item ',(THIRD (THIRD item))) (CAR item)) (SEND *standard-output* :item 'doc-top-level (LIST (THIRD (SETQ tlist (THIRD item))) (FOURTH tlist) (FIFTH tlist)) "<<~a>>" (CAR item))))) (defcom com-view-reference-history "View history of references" () (view-reference-history) (FORMAT *standard-output* "~2%Select any mouseable item, or ~a" w:*remove-typeout-standard-message*) dis-none) (defcom com-save-history "Save the Request History's menu item list" () (OR *user-request-history-file* (SETQ *user-request-history-file* (fs:make-pathname :host "lm" :directory fs:user-id :name "visidoc-request-history" :type :lisp))) (UNLESS (EQ :abort (CATCH 'write-file (w:choose-variable-values '((*user-request-history-file* "File" :pathname)) :label "Enter filename in which to save the Request History:" :margin-choices '("Write File" ("Abort Save" (THROW 'write-file :abort)))))) (WITH-OPEN-FILE (fstream *user-request-history-file* :direction :output :if-exists :new-version :if-does-not-exist :create) (PRIN1 *doc-viewer-request-history* fstream))) dis-none) (defcom com-restore-history "Restore the Request History from a file" () (OR *user-request-history-file* (SETQ *user-request-history-file* (fs:make-pathname :host "lm" :directory fs:user-id :name "visidoc-request-history" :type :lisp))) (UNLESS (EQ :abort (CATCH 'write-file (w:choose-variable-values '((*user-request-history-file* "File" :pathname)) :label "Enter filename from which to restore the Request History:" :margin-choices '("Use File" ("Abort Restore" (THROW 'write-file :abort)))))) (WITH-OPEN-FILE (fstream *user-request-history-file* :direction :input :if-does-not-exist nil) (IF fstream (PROGN (SETQ *doc-viewer-request-history* (READ fstream)) (update-request-history-item-list (window-frame *window*))) (tv:notify nil "cannot find file ~s" (OR (AND (STRINGP *user-request-history-file*) *user-request-history-file*) (SEND *user-request-history-file* :string-for-printing)))))) dis-none) ;================================================================================ ; UTILITY ROUTINES ;;Added for Hypertext support (DEFUN make-fat-string (string font &aux fat-string (len (LENGTH string))) (SETQ fat-string (MAKE-ARRAY len :type 'ART-FAT-STRING)) (DO () ((> 0 (SETQ len (1- len))) fat-string) (setf (aref fat-string len) (CODE-CHAR (AREF string len) 0 font))) ) (defun object-attribute-chapter (list) "accepts an attribute LIST and returns it's chapter." (car list)) (defun object-attribute-start (list) "accepts an attribute LIST and returns it's start pointer." (second list)) (defun object-attribute-end (list) "accepts an attribute LIST and returns it's end pointer." (third list)) (defun object-attribute-page (list) "accepts an attribute LIST and returns it's page info." (fourth list)) (defun object-attribute-next (list) "accepts an attribute LIST and returns it's next reference." (fifth list)) (defun object-attribute-previous (list) "accepts an attribute LIST and returns it's previous reference." (sixth list)) (defun object-attribute-superior (list) "accepts an attribute LIST and returns it's superior." (seventh list)) (DEFUN object-attribute-children (LIST) "accepts an attribute LIST an returns the list of children." (eighth list)) (DEFUN node-expandedp (node) "Returns multiple values. If NODE is not fully displayed, the first value is NIL. If NODE is fully displayed, the first value is T. The second value is the node that actually returned T or NIL (if this node's expansion is :ask-superior)." ;;This first test is for error checking... all lines in a buffer ;;should belong to a reference node (EXCEPT for the last line!) (IF (NOT (TYPEP node 'reference-node)) (LET ((new-node (DO ((line (line-previous (bp-line (interval-last-bp node))) (line-previous line))) ((null line) (RETURN nil)) (WHEN (TYPEP (line-node line) 'reference-node) (RETURN (line-node line)))))) (IF new-node (node-expandedp new-node) (tv:notify nil "I don't understand what section you're pointing to Please move the cursor to a different line and try the command again."))) (LET ((expansion (reference-node-expanded-p node))) (cond ((listp expansion) (values (car expansion) node)) ((eq expansion :ask-superior) (node-expandedp (node-superior node))) (t (values expansion node)))))) (DEFUN node-exposedp (node) "Returns multiple values. The first value is T if the node (or it's superior if the value of instance variable EXPANDED-P is :ASK-SUPERIOR) is exposed, or NIL if it's deexposed. The second value is the node that actually returned this value." (LET ((exposure (ht-node-exposed-p node))) (IF (EQ :ask-superior exposure) (VALUES (node-exposedp (node-superior node))) (VALUES exposure node))))