;;; -*- Mode: Common-Lisp; Package: ZWEI; Base: 10.; Patch-File: T -*- ;;; Written 06/12/89 06:47:25 by BERGER, ;;; Reason: Fixed com-expand-section and com-contract-section to grab the mouse. This was causing redisplay errors. Also fixed expand-reference to handle empty topics. ;;; while running on ARIES from band LOD1 ;;; With SYSTEM 6.5, VIRTUAL-MEMORY 6.1, EH 6.1, MAKE-SYSTEM 6.0, MICRONET 6.0, LOCAL-FILE 6.0, ;;; BASIC-PATHNAME 6.0, NETWORK-SUPPORT-COLD 6.0, BASIC-NAMESPACE 6.0, NETWORK-NAMESPACE 6.0, ;;; DISK-IO 6.0, DISK-LABEL 6.0, BASIC-FILE 6.1, MAC-PATHNAME 6.0, NETWORK-PATHNAME 6.0, ;;; COMPILER 6.2, TV 6.6, DATALINK 6.0, CHAOSNET 6.0, GC 6.2, MEMORY-AUX 6.0, NVRAM 6.0, ;;; SYSLOG 6.0, STREAMER-TAPE 6.0, UCL 6.0, INPUT-EDITOR 6.0, METER 6.0, ZWEI 6.0, ;;; DEBUG-TOOLS 6.0, NETWORK-SUPPORT 6.0, NETWORK-SERVICE 6.0, DATALINK-DISPLAYS 6.0, ;;; FONT-EDITOR 6.1, SERIAL 6.0, PRINTER 6.1, MAC-PRINTER-TYPES 6.1, PRINTER-TYPES 6.0, ;;; IMAGEN 6.0, SUGGESTIONS 6.0, MAIL-DAEMON 6.2, MAIL-READER 6.0, TELNET 6.0, VT100 6.0, ;;; NAMESPACE-EDITOR 6.0, PROFILE 6.1, VISIDOC 6.0, TI-CLOS 6.5, CLEH 6.1, IP 3.46, ;;; Experimental BUG 11.7, CLX 6.0, CLUE 6.0, X11M 6.0, microcode 429, Band Name: Release 6.0 + SLE 5/22 #!C ; From file DEFINITIONS.LISP#> VISIDOC; SYS: #10R ZWEI#: (COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "ZWEI")) (SI:*LISP-MODE* :COMMON-LISP) (*READTABLE* SYS:COMMON-LISP-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*)) (COMPILER#:PATCH-SOURCE-FILE "SYS: VISIDOC; DEFINITIONS.#" (DEFCOM com-contract-section "Contract a section." () (tv:with-mouse-grabbed ; DAB 06-08-89 (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." () (tv:with-mouse-grabbed ; DAB 06-08-89 (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)) )) #!C ; From file DOCUMENT-VIEWER.LISP#> VISIDOC; SYS: #10R ZWEI#: (COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "ZWEI")) (SI:*LISP-MODE* :COMMON-LISP) (*READTABLE* SYS:COMMON-LISP-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*)) (COMPILER#:PATCH-SOURCE-FILE "SYS: VISIDOC; DOCUMENT-VIEWER.#" (defun expand-reference (node &aux lnext filepos) "Given a reference NODE, display the text that is associated with it." (DECLARE (inline object-attribute-start object-attribute-end)) (MULTIPLE-VALUE-BIND (expanded? snode) (node-expandedp node) (UNLESS (or expanded? (string-equal (send node :name) "")) ; DAB 06-12-89 Handle empty topics. (FORMAT *query-io* "~&Expanding text for ~s" (ht-node-name snode)) (SETQ lnext (delete-doc-interval snode)) (SEND snode :mark-as-deexposed) (SETF (reference-node-expanded-p snode) t) (IF (PROGN (SETQ filepos (reference-node-start snode)) (DOLIST (inf (node-inferiors snode)) (UNLESS (EQ :header (ht-node-type inf)) (IF (<= (reference-node-start inf) (1+ filepos)) (SETQ filepos (reference-node-end inf)) (RETURN (SETQ filepos nil))))) (UNLESS (AND filepos (<= (reference-node-end snode) (1+ filepos))) (SETQ filepos nil)) filepos) (SEND snode :link-and-expose) ;;All the text is not in the buffer... ;;get and insert it in contracted form. (LET* ((object-list (get-stuff-from-doc-server (ht-node-name snode) :manual (manual-name snode) :nth (reference-node-nth snode) :forced-get t)) (list-of-references (FOURTH object-list)) (bp-next (create-bp lnext 0 :moves)) (potential-grandchildren nil) (inf-list nil)) (insert-inferiors snode list-of-references nil bp-next) ;;Now, find any nodes that should be GRANDCHILDREN that are ;;still in the hierarchy as siblings. (DOLIST (sib (REMOVE-IF #'(lambda (x) (OR (EQ (ht-node-type x) :header) (EQ (ht-node-type x) :contents) (EQ x snode))) ;;don't check against yourself 09-01-88 DAB SB (node-inferiors (node-superior snode)))) (LET ((superior-children (object-attribute-children (SECOND (NTH (reference-node-nth (node-superior snode)) (entries-alist (ht-node-name (node-superior snode)) (manual-name snode))))))) (WHEN (AND ;;(NOT (EQ sib snode)) (NOT (MEMBER (ht-node-name sib) superior-children :test #'string-equal)) (<= (reference-node-start snode) (reference-node-start sib)) (<= (reference-node-end sib) (reference-node-end snode))) (PUSHNEW sib potential-grandchildren)))) ;;Now, find any nodes that should be GREAT-GRANDCHILDREN that are ;;still in the hierarchy as children. (SETQ inf-list (REMOVE-IF #'(lambda (x) (OR (EQ (ht-node-type x) :header) (EQ (ht-node-type x) :contents))) (node-inferiors snode))) (DOLIST (c inf-list) (DOLIST (n inf-list) (WHEN (AND (NOT (eq c n)) (<= (reference-node-start n) (reference-node-start c)) (<= (reference-node-end c) (reference-node-end n)) (not (and (= (reference-node-start n) (reference-node-start c)) ;09-12-88 DAB and not the same. (= (reference-node-end c) (reference-node-end n)))) ) (PUSHNEW c potential-grandchildren)))) (WHEN potential-grandchildren (DOLIST (n potential-grandchildren) (setf (node-inferiors snode) (DELETE n (node-inferiors snode))) ; DAB 06-08-89 (WHEN (node-next n) (SETF (node-previous (node-next n)) (node-previous n))) (WHEN (node-previous n) (SETF (node-next (node-previous n)) (node-next n))) (SETF (node-next n) nil (node-previous n) nil (node-superior n) (node-superior snode))) (make-grandchildren snode potential-grandchildren))))) snode)) ))