;;; -*- Mode:Common-Lisp; Package:GLOSS; Fonts:(COURIER HL12B HL12BI); Base:10 -*- ;;; RESTRICTED RIGHTS LEGEND ;;;Use, duplication, or disclosure by the Government is subject to ;;;restrictions as set forth in subdivision (b)(3)(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) 1985, Texas Instruments Incorporated. All rights reserved. ;;; Copyright (c) 1984, Texas Instruments Incorporated. All Rights Reserved. ;;; Copyright (C) 1986, Texas Instruments Incorporated. All rights reserved. ;; Global variables for the various windows (DEFPARAMETER *glossary-frame* nil "Main Glossary Frame") (DEFPARAMETER *text-pane* nil "Text of the selected glossary entries") (DEFPARAMETER *alph-pane* nil "Menu of letters of the alphabet") (DEFPARAMETER *command-pane* nil "Menu of top-level glossary commands") (DEFPARAMETER *entry-pane* nil "Menu of the glossary entries") (DEFPARAMETER *kbd-pane* nil "Pane in which user can do typein.") (DEFPARAMETER *glossary-typein-modes* nil "List of typein modes that are enabled in the Glossary command loop. This includes items such as completion of glossary entries in the keyboard pane.") (DEFPARAMETER *system-key* #\Z "The system key that Glossary is assigned to.") ;; Use w:*landscape-monitor* instead ;(DEFPARAMETER *landscape-monitor-p* (MULTIPLE-VALUE-BIND (width height) ; (SEND w:main-screen :size) ; (> width height)) ; "Boolean which indicates the orientation of the current console display. ;T is landscape and NIL is Portrait.") (DEFPARAMETER *glossary-documentation* '((:expert-help " Expert Mode provides the ability to manipulate and edit glossaries. To enter this mode, type ~:@C. This keystroke will toggle you in and out of the Expert Mode. Expert Mode increases the number of commands that are displayed in the command menu. These commands are all documented in the who-line documentation line when the mouse is placed over a command. For more information on Expert Mode, see the ~1QConcepts and Tools~0Q manual." #\c-m-t set-font set-font) (:general-help " The online Glossary provides the lisp machine user with a powerful tool that helps clarify the important terms and concepts of the Explorer environment. The content of the online Glossary is identical to the hardcopy version also available from Texas Instruments. The power of the online Glossary is based on the ability to access terms quickly and in a number of different ways.")) "The alist of documentation strings for the glossary. The FIRST of each sublist is the topic. The SECOND is the actual help string." ) ;;; Menu Item lists ;;Command Menu: ;; The command menu consists of a base menu of standard commands ;; When additional features are enabled (eg, glossary editting), this basic menu ;; is extended by including glossary manipulation commands. ;; The appropriate command menu is obtained by calling the function (COMMAND-MENU-ITEM-LIST) (DEFPARAMETER *basic-command-menu-item-list* `( ("Help" :eval (SEND *glossary-frame* :help :main) :documentation "Display Help on how to use the glossary system.") ("Clear Text Display" :eval (SEND *text-pane* :clear-display) :documentation "Clear all of the text from pane labeled: Text of Selected Glossary Entries.") ("Exit Glossary" :eval (*THROW :exit :exit-from-menu) :documentation "Exit the glossary system, retaining the state. This is the same as pressing the END key.") ) "This is the starter kit menu item list of commands that should always be present in the command menu.") (DEFUN command-menu-item-list () "Returns the menu-item-list for the command menu. Adds in additional menu entries to the basic menu as needed." (IF (NOT *glossary-tools-on*) (APPEND *basic-command-menu-item-list* (IF (> (LENGTH *list-of-glossaries*) 1) ;Include this if there is a glossary to select `(("Select Glossary" :eval (SEND *glossary-frame* :select-glossary) "Select a glossary to be the currently active glossary.")))) ;Otherwise, build up a menu as needed (APPEND *basic-command-menu-item-list* `(("" :no-select nil) ("" :no-select nil) ("" :no-select nil) ,(command-menu-item "Define Glossary" :define-new-glossary "Add a new glossary to the set of glossaries that the system knows about. This allows you to define a glossary that already exists in a file, or a completely new one.") ,@(IF (NOT (NULL *list-of-glossaries*)) ;Must be a glossary to select (LIST (command-menu-item "Select Glossary" :select-glossary "Select a glossary to be the currently active glossary. The current glossary is the one whose entries are displayed in the Menu of Glossary Entries") (command-menu-item "Delete Glossary" :delete-glossary "Delete a defined glossary from the glossaries currently defined. If the glossary exists in a file, that file is not affected."))) ,@(IF (NOT (NULL *glossary*)) ;If there is a current glossary (LIST (command-menu-item "Merge in Glossary" :merge-glossaries "Merge another glossary into the current one. This destroys the glossary which is merged into the current one.") (command-menu-item "(Re)Generate XRefs" :generate-xrefs "Regenerate Cross References for current glossary. If there are a large number of entries in this glossary, this may take quite a while.") (command-menu-item "Write Current Glossary" :write-current-glossary "Write the current glossary to a file. You specify both the file pathname and the format of the file to be written.") '("" :no-select nil) '("" :no-select nil) (command-menu-item "Add Glossary Entry" :add-glossary-entry "Add a glossary entry to the current glossary from the keyboard. An editor window will appear, allowing you to type in the text for the entry.") (command-menu-item "Delete Glossary Entry" :remove-glossary-entry "Deletes a glossary entry from the current glossary. Note, that although the entry may be deleted, you can Undelete the entry later on.") (command-menu-item "Edit Glossary Entry" :edit-glossary-entry "Edit the text of an existing glossary entry.") (command-menu-item "Undelete Glossary Entry" :undelete-glossary-entry "Undeletes a previously deleted glossary entry, restoring it in the current glossary.") '("" :no-select nil) '("" :no-select nil) )) ,(IF *glossary-hacker-p* (command-menu-item "Turn Off Xref Deletion" :turn-off-xref-deletion "Disable the ability to remove cross references by clicking the right mouse button on them. Individual cross references to other entries can be deleted while this mode is enabled.") (command-menu-item "Turn On Xref Deletion" :turn-on-xref-deletion "Enable the ability to remove cross references by clicking the right mouse button on them. Individual cross references to other entries can be deleted while this mode is enabled.")) ,(command-menu-item "Exit Expert Mode" :toggle-glossary-tools "Exit the glossary mode in which modifications to the glossary can be made.") ))) ) (DEFPARAMETER *alph-menu-item-list* ; (CONS ; (make-menu-item :display-string " Other Characters" ;Non-alphabetic Characters ; :value (STRING 0) ;The first character in the character set ; :documentation (FORMAT nil "Click Left Button of Mouse to display glossary ~ ; entries beginning with non-alphabetic characters.") ; :font fonts:tr10b) ;Non-standard font so that it won't take up too much horizontal space ;; NOTE:: The code in this section depends on character codes. This will be a problem when ;; we start converting to International methods. (LOOP for letter from (CHAR-CODE #\A) to (CHAR-CODE #\Z) ;Include the alphabets for char-string = (STRING (CHARACTER letter)) ;Need a 1-character string (not just the character) collect `(,char-string :value ,char-string :documentation (:mouse-any ,(FORMAT nil "Display glossary entries beginning with the character \"~A\"" char-string)))) ; ) "This is the menu item list for the thumb index. It consists of all of the letters (A-Z) and and entry named OTHER CHARACTERS which includes all non-alphabetic characters which come before A.") ;;; Window flavors and methods (DEFFLAVOR gloss-pane-mixin ((help-message nil) ;A help message specific to this pane (pane-active-p nil)) ;Non-Nil if the pane is not to be grayed (w:borders-mixin w:top-box-label-mixin) ;Don't need w:pane-mixin anymore :settable-instance-variables ;Settable, Gettable, Inittable (:required-flavors w:minimum-window) (:documentation :mixin "Provides methods common to all glossary panes.") ) ;;;(DEFWRAPPER (gloss-pane-mixin :who-line-documentation-string) (IGNORE . body) ;;; "Display documentation for KBD pane if something interesting exists there." ;;; `(OR (LET ((kbd-pane (SEND w:superior :kbd-pane))) ;;; (AND ;;; (NEQ self kbd-pane) ;;; (SEND kbd-pane :who-line-documentation-string))) ;;; ,body)) (DEFMETHOD (gloss-pane-mixin :make-pane-gray) (&optional clear-screen-first-p) "BitBlt a gray pattern on the specified pane." (UNLESS pane-active-p ;Don't do anything if the pane is being used (WHEN clear-screen-first-p ;Clear the screen first if desired (SEND self :clear-screen)) (w:prepare-sheet (self) ;Allow microcode primitives to be used on this sheet (pane) (BITBLT w:char-aluf (w:sheet-inside-width) (w:sheet-inside-height) w:25%-gray 0 0 w:screen-array (w:sheet-inside-left) (w:sheet-inside-top))))) (DEFMETHOD (gloss-pane-mixin :delayed-clear-gray) (&optional (delay-seconds 5.)) "In another process, the pane is cleared and then grayed after a specified interval." (PROCESS-RUN-FUNCTION "Clear Pane" #'(lambda (pane delay) (PROCESS-SLEEP (* 60. delay)) (SEND pane :make-pane-gray t)) self delay-seconds)) ;Arguments to lambda (DEFMETHOD (gloss-pane-mixin :display-help) () "Displays a help message for this window in a Zmacs pop up window." ;;First put the window in reverse video (LET* ((other-panes (REMOVE self (SEND w:superior :exposed-inferiors) :test #'EQ)) (label-name (IF (LISTP tv:label) (SIXTH tv:label) tv:label)) (actual-help-message (FORMAT nil "~%Help on ~:[unlabeled window:~*~;window labeled: ~s~]~2%~a~2%" label-name label-name help-message))) (DOLIST (other-pane other-panes) (SEND other-pane :set-reverse-video-p (NOT (SEND other-pane :reverse-video-p)))) ;; Bring up the documentation string next to this one (pop-up-help-message actual-help-message `(:window ,self)) ;;Change back the reverse video window (DOLIST (other-pane other-panes) (SEND other-pane :set-reverse-video-p (NOT (SEND other-pane :reverse-video-p)))) )) ;;; This is a modified form of W:POP-UP-MESSAGE (DEFUN pop-up-help-message (help-message &optional (pop-up-near '(:mouse))) "Pop up a window with a message in it, require user to type a character to flush." (LET ((message (FORMAT nil "~a~%~a" help-message tv:*remove-typeout-standard-message*)) old-font-map) (USING-RESOURCE (pop-up-message-window w:pop-up-text-window w:mouse-sheet) (SETQ old-font-map (SEND pop-up-message-window :font-map)) (SEND pop-up-message-window :set-font-map '(fonts:tr12)) (SEND pop-up-message-window :set-label nil) (SEND pop-up-message-window :set-size-in-characters message message) (SEND pop-up-message-window :clear-input) (tv:expose-window-near pop-up-message-window pop-up-near nil) (w:window-call (pop-up-message-window :deactivate) (SEND pop-up-message-window :string-out message) ;; Back up the cursor by one. This is easier than trying to ;; make the window come out wider, because of the interface to ;; :set-size-in-characters. (MULTIPLE-VALUE-BIND (x-pos y-pos) (SEND pop-up-message-window :read-cursorpos :character) (SEND pop-up-message-window :set-cursorpos (1- x-pos) y-pos :character)) (SEND pop-up-message-window :tyi)) (SEND pop-up-message-window :set-font-map old-font-map)))) (DEFSTRUCT (alph-menu-blip (:type :list) (:conc-name alph-menu-blip-)) "Blips that are received from the Thumb Index (alph-menu)." (keyword :alph-menu) ;Static string ;Normally a one-character string menu-window ;The window where the blip came from ) (DEFFLAVOR alph-menu-pane ;A modified command menu (w:io-buffer ;Must know where to put the input blips font-list) ;List of the fonts that are legal for the thumb index (gloss-pane-mixin ;inherited by all panes in the glossary ;;w:text-scroll-window ;;w:sheet w:menu) ;Basically just a special type of menu (the blips are handled special) ;;(:included-flavors w:basic-menu) ;Really redundant since W:MENU contains this (but let's be safe) ;;w:basic-menu is replaced by w:menu in Rel3 (:settable-instance-variables w:io-buffer font-list) ;settable, gettable, and inittable (:default-init-plist :command-menu t ;initialization option for Rel3 :item-list *alph-menu-item-list* ;Item list to be displayed by the menu :font-list *alph-font-list* ;Different size fonts that can be used for the thumb index :default-font (FIRST *alph-font-list*) ;Use this font to display the alphabet :rows (LENGTH *alph-menu-item-list*) ;Probably: 27 = 26 characters + "Other Characters" :columns 1 ;Put it all in one column (indexes should be in columns) :help-message "This menu provides an alternative to scrolling through the Menu of Glossary Entries. Clicking on a letter will cause the Menu to scroll to where Glossary terms beginning with that letter will be displayed." ) (:documentation "This is a menu of the letters of the alphabet, used to display glossary entries beginning with the selected letter.") ) (DEFMETHOD (alph-menu-pane :after :mouse-buttons) (&rest ignore) "Blip Format: (:alph-menu )" ;CHOSEN-ITEM is a standard menu item (COND (w:last-item ;This should always be true; a menu blip is the only input that can come from this pane. (w:io-buffer-put w:io-buffer ;Put our ALPH-MENU-BLIP into the input buffer (make-alph-menu-blip :string (w:menu-execute-no-side-effects w:last-item) :menu-window self)) (SETQ w:chosen-item nil)))) (DEFMETHOD (alph-menu-pane :update-font) () "Determines which is the largest font that will fit in the alph-pane and sets the default font to that font if it is different than the current default." (LET ((available-height (- (SEND self :inside-height) 7)) ;7 pixels must be allocated for a "fudge factor" (constrained-height (+ ;The amount of height that is fixed (* (SEND self :vsp) ;Space between the menu items (LENGTH w:item-list)) (LOOP for item in w:item-list ;Combined height of all fixed fonts for font = (GET item :font) ;Explicit font specification WHEN (NOT (NULL font)) sum (w:font-char-height font)))) (num-of-unfixed-items (LOOP for item in w:item-list ;Count the number of menu items w/o explicit fonts WHEN (NOT (GET item :font)) ;Check if there is an explicit font for this item COUNT 1)) (selected-font nil) ;The font that will actually be selected ) (LOOP for font in font-list WHEN (<= ;When the size of the menu using this font is less than the available space (+ constrained-height (* num-of-unfixed-items (w:font-char-height font))) available-height) RETURN (SETQ selected-font font) ;Use this font since it fits finally (SETQ selected-font fonts:5x5)) ;Use this font if no other will fit (UNLESS (EQ selected-font w:default-font) ;Don't set the font if it is already set to what we want (SEND self :set-default-font selected-font)) )) (DEFSTRUCT (entry-menu-blip (:type :list) (:conc-name entry-menu-blip-)) "Blips coming from the entry menu are of this form (menu of glossary entries)." (keyword :entry) ;static entry-object ;Glossary entry object ) ;;;The items in the item list of this menu are simply Glossary-Entry objects (DEFFLAVOR entry-menu-pane (w:io-buffer (last-wl-doc-item nil) ;The last item for which a who line string was generated (last-wl-doc-string nil)) ;The who line string (list) generated from LAST-WL-DOC-ITEM (;;w:text-scroll-window ;;w:scroll-bar-mixin ;replaces flashy-scrolling-mixin and basic-scroll-bar ;;w:basic-scroll-bar ;Here for thermometer effect w:borders-mixin ;Give it borders w:top-label-mixin ;Put the label at the top of the pane ;;w:flashy-margin-scrolling-mixin ;Nifty scrolling features gloss-pane-mixin ;Inherited by all panes w:menu) ;Just a menu (:settable-instance-variables w:io-buffer) (:required-flavors w:essential-window) (:default-init-plist ;; :scroll-bar-always-displayed T :default-font *entry-menu-font* :margin-scroll-regions '((:TOP "Top of Menu") ;What is displayed at the top and bottom of the scrolling list (:BOTTOM "Bottom of Menu")) ;; :flashy-scrolling-region '((20 0.40s0 0.60s0) ;region in which scrolling occurs ;; (20 0.40s0 0.60s0)) ;;this option is obsolete in Rel3 :help-message "This is a menu of all of the terms in the Glossary. Clicking with the mouse on a term will cause its definition to appear in the right half of the screen. This menu is scrollable using the mouse.") (:documentation "The menu of names of glossary entries. This flavor is a version of a command-menu.") ) (DEFMETHOD (entry-menu-pane :select-char) (char-string) "Scroll to the point where entries beginning with the letter CHAR-STRING are displayed in this menu." (LET* ((entry-menu-item-list (SEND *glossary* :entry-menu-item-list)) (selected-entry (LOOP for item in entry-menu-item-list for entry = (w:menu-execute-no-side-effects item) for entry-name = (SEND entry :name) until (OR (STRING-EQUAL char-string entry-name) (g-string-lessp char-string entry-name)) finally (RETURN item)))) (DECLARE (LIST ENTRY-MENU-ITEM-LIST)) ;; Now that we have the right entry, we must do the display stuff with it. (UNLESS (NULL selected-entry) ;should never be the case (SEND self :scroll-to (POSITION selected-entry entry-menu-item-list :test #'EQ) :absolute)) )) (DEFMETHOD (entry-menu-pane :after :mouse-buttons) (&rest ignore) "Blip Format: (:entry ) " (WHEN w:last-item (w:io-buffer-put w:io-buffer (make-entry-menu-blip ;Put an entry-menu-blip into the input buffer :entry-object (w:menu-execute-no-side-effects w:last-item))) (SETQ w:last-item nil) (SETQ w:chosen-item nil))) (DEFMETHOD (entry-menu-pane :who-line-documentation-string) () "Returns the documentation string for items in this window. Rather than construct a complete menu-item-list with documentation strings, we build the documentation on the fly, at a minimal cost, but it helps make our menu-item lists a lot less wasteful." (DECLARE (VALUES documentation-list)) (COND ;;If the item is the same, use the previously constructed documentation ((AND w:current-item (EQ w:current-item last-wl-doc-item)) last-wl-doc-string) ;;Otherwise we have to go through the work of building a new documentation list (w:current-item (SETQ last-wl-doc-item w:current-item last-wl-doc-string `(:mouse-any ,(FORMAT nil "Display the definition of ~a" (IF (TYPEP w:current-item 'glossary-entry) (SEND w:current-item :name) (PRIN1-TO-STRING w:current-item)))))) ;;Return the empty string if we can't do anything else (t ""))) (DEFFLAVOR glossary-text-pane ((display-entry-list nil) ;This is a list of entries (single-right-menu nil) ;The menu that can be used for a single right click (Not Currently used) ) (w:scroll-bar-mixin ;Replaces basic-scroll-bar and flashy-margin-scrolling-mixin ;;w:basic-scroll-bar ;Here for thermometer effect w:borders-mixin w:top-label-mixin w:text-scroll-window-empty-gray-hack ;Gray the pane when there is nothing to display w:function-text-scroll-window ;changeable display function w:mouse-sensitive-text-scroll-window ;Lines contain mouse sensitive items ;;w:flashy-margin-scrolling-mixin ;Defined above ;;w:basic-scroll-bar gloss-pane-mixin tv:dont-select-with-mouse-mixin w:window) :settable-instance-variables ;Settable, Gettable, and Inittable (:default-init-plist :font-map (LIST *entry-name-font* *entry-text-font* *entry-xref-font*) ;Fonts we can use for display :save-bits T :more-p nil :margin-scroll-regions '((:TOP "Top of Text") (:BOTTOM "Bottom of Text")) ;; :flashy-scrolling-region '((20 0.40s0 0.60s0) ;; (20 0.40s0 0.60s0)) ;; :scroll-bar-always-displayed T :print-function-arg nil :print-function 'gloss-print-function :sensitive-item-types '(:xref-item :entry-item) ;Two types of mouse-sensitive items :help-message "This is where the definitions of all selected terms are displayed. Within some definitions, there are cross-references to other Glossary terms; these cross-referenced terms are in bold type and clicking on one with the mouse causes its definition to appear at the top of the display. This display is scrollable; use the mouse or control-V and meta-V." ) (:documentation "This is where the the selected glossary definitions are displayed.") ) (DEFMETHOD (glossary-text-pane :who-line-documentation-string) () "When the mouse is over a mouse sensitive item, let the user know what this means. We know if we are over a mouse sensitive item if W:ITEM-BLINKER is visible." (MULTIPLE-VALUE-BIND (x y) ;Convert the mouse-sheet X and Y to positions within this window (w:sheet-calculate-offsets self w:mouse-sheet) (SETQ x (- w:mouse-x x) y (- w:mouse-y y)) (MULTIPLE-VALUE-BIND (nil item-type) ;1st arg is the item itself (SEND self :mouse-sensitive-item x y) (CASE item-type (:xref-item (IF *glossary-hacker-p* ;T if the user has the right to delete cross-references `(:mouse-l-1 "Display Text for this Cross Reference." :mouse-r-1 "DELETE this Cross Reference from this Glossary Entry." :font fonts:tr12bi :documentation "Mouse is over a Cross Reference.") `(:mouse-any "Display Text for this Cross Reference." :font fonts:tr12bi :documentation "Mouse is over a Cross Reference."))) (:entry-item (IF *glossary-hacker-p* `(:mouse-l-1 "Move this Glossary Entry to top." :mouse-m-1 "(Re)Generate cross references for this glossary entry." :mouse-r-1 "Remove display of this Glossary Entry." :font fonts:tr12bi :documentation "Mouse is over the name of a Glossary Entry.") `(:mouse-l-1 "Move this Glossary Entry to the top of the display." :mouse-r-1 "Remove this Glossary Entry from this display." :font fonts:tr12bi :documentation "Mouse is over the name of a Glossary Entry.") )) (otherwise nil) ;Use the default documentation (Right click for system menu.) )))) (DEFUN gloss-print-name (item window) "Used by GLOSS-PRINT-FUNCTION to print glossary entry names to the scroll window." ;; Temporarily change the font to display the entry name (SEND window :set-current-font *entry-name-font*) (SEND window :item1 (name-item-entry item) ':entry-item #'(lambda (item window) (FORMAT window "~A" (SEND item :name)))) ;; Restore the font to the default font (SEND window :set-current-font *entry-text-font*)) (DEFUN gloss-print-text (item window) "Used by GLOSS-PRINT-FUNCTION to print glossary entry text to the scroll window." (LET* ((text-line (text-item-text item)) (text-string (text-line-string text-line))) (IF (NULL (text-line-xref-list text-line)) (FORMAT window "~A" text-string);No XRefs ;; All this stuff if there are cross-references (LET ((mousable-list (text-line-xref-list text-line))) ;; The mousables list is a list of the cross references ;; Sort Mousables, in left to right order of where the xref starts (SETQ mousable-list (SORT mousable-list #'(LAMBDA (x y) (< (xref-start-index x) (xref-start-index y)))));Print out the text character-by-character ;Xref items are printed as one character (LOOP for pos from 0 to (1- (LENGTH text-string)) with ml = mousable-list ;ML is list of remaining mousables for first-xref = (FIRST ml) ;Either the first xref in the remaining mousables or NIL (if none left) do (COND ((OR (NULL ml) ;There are no xrefs (< pos (xref-start-index first-xref))) ;First remaining xref starts after this position (SEND window :tyo (AREF text-string pos))) ;Just output a character (t ;There are xrefs ;;Temporarily change the font to highlight the cross-reference (SEND window :set-current-font *entry-xref-font*) (SEND window ;Actually send the item to the text display window :item1 ;;Mouse XRefs are of a special defstruct format (make-mouse-xref :entry-object (xref-entry-object first-xref) :xref first-xref :text-line text-line) :xref-item ;The item type #'(LAMBDA (item window) ;This is the real work of the print function for text (FORMAT window "~a" (SEND (mouse-xref-entry-object item) :name)))) (INCF pos (- (xref-end-index first-xref) ;Increment the position marker past the xref (xref-start-index first-xref))) ;;Change the font back to the default font used for non-xref text of the entries (SEND window :set-current-font *entry-text-font*) (SETQ ml (REST ml))))))))) (DEFUN gloss-print-function (item ignore window &optional ignore) "Function used by GLOSSARY-TEXT-PANE to print out lines. Format of items in TV:ITEMS is (:name|:text )" (CASE (FIRST item) ;First element of the blip is always the item type (:name or :text) (:name ;Glossary name printing (gloss-print-name item window)) (:text ;Glossary entry text (gloss-print-text item window)) (T (FORMAT window "~A" item)))) ;Just write the item out if we don't know what it is (DEFMETHOD (glossary-text-pane :mouse-click) (button IGNORE IGNORE) ;Ignored are X and Y positions "This is a special purpose modification which allows a menu to pop-up when there is a menu to pop up and when the right button is clicked once." (COND ((AND (= button #\mouse-3-1) single-right-menu) ;Feature not being used yet (PROCESS-RUN-FUNCTION "Menu Choose" #'(lambda (us button menu &aux choice) (SETQ choice (SEND menu :choose)) (AND choice (SEND us :force-kbd-input (LIST :menu choice button us)))) self button single-right-menu) t) (t nil) ;Return NIL to indicate that the mouse click hasn't been handled )) (DEFMETHOD (glossary-text-pane :remove-entry) (entry) "Find where entry begins and ends, delete those items, update DISPLAY-ENTRY-LIST." (SETQ display-entry-list (DELETE entry display-entry-list :test #'EQ)) ;Delete the entry from the entry list ;;Now the entry must be removed from the actual display (LET ((position (POSITION ;Find out where the entry is in the TV:ITEMS array (make-name-item :name (SEND entry :name) :entry entry) (THE LIST (LISTARRAY tv:items)) :TEST #'EQUAL))) (UNLESS (NULL position) ;Don't bother if we couldn't find the entry in the display (SEND self :delete-item position) ;Delete the Nth item in the display (Which is the entry name) ;;Now delete all of the following lines until we get to the next entry name in the display (LOOP for line = (AREF tv:items position) until (OR (EQ (FIRST line) :name) ;we've found the next entry name OR (>= position (1- (ARRAY-ACTIVE-LENGTH tv:items)))) ;There aren't any more entries below DO (SEND self :delete-item position) ;Delete this line of text from the display finally (IF (= position (1- (ARRAY-ACTIVE-LENGTH tv:items))) ;Kludge if at bottom (SEND self :delete-item position))) ))) (DEFMETHOD (glossary-text-pane :add-entry) (entry) "Add another entry to the displayed entries. If ENTRY is already displayed, remove and put it at the top." (LET ((rev-list (REVERSE (SEND entry :text-list)))) ;Text lines are added to the display backwards (WHEN (MEMBER entry display-entry-list :TEST #'EQ) ;Don't let things be displayed twice (SEND self :remove-entry entry)) ;Remove it if it already is displayed (so it can be displayed at the top) (PUSH entry display-entry-list) ;;The actual display of the glossary entry is done here. ;;The entry is added to the top of the display ;;The entry name is displayed first, the the entry text is added line-by-line below that. ;;Last entry is added first, second-last pushes that one down, and so on until the top line of the text is displayed. (SEND self :scroll-to 0 :absolute) ;Scroll to top of display (SEND self :insert-item 0 ;Entry name at the top of the display (make-name-item :name (SEND entry :name) :entry entry)) ;;Now, insert the text lines (last-first) at the second line of the display ;;When new lines are added, the ones below it are pushed down. (LOOP for line in rev-list for line-number from 0 DO (SEND self :insert-item 1 (make-text-item :text line :entry entry :line-number line-number))) ;; Take care of the special case of an entry w/o any text (WHEN (OR (AND (= 1 (LENGTH rev-list)) (STRING-EQUAL (CAAR rev-list) "")) (NULL rev-list)) (IF (NULL rev-list) ;Not even a blank line (SEND self :insert-item 1 '(:text ("")))) ;a blank line (SEND self :insert-item 1 '(:text (" (No text for this entry)")))) )) (DEFMETHOD (glossary-text-pane :clear-display) () "Clear all of the entry text from this pane.. The text is cleared line by line, from the bottom up. The effect is that of using an eraser starting from the bottom." (LET ((current-length (ARRAY-ACTIVE-LENGTH tv:items))) (DOTIMES (i (ARRAY-ACTIVE-LENGTH tv:items)) (SEND self :delete-item (1- current-length)) ;Counting backwards (DECF current-length)))) (DEFFLAVOR kbd-pane () (tv:lisp-help-mixin gloss-pane-mixin tv:dont-select-with-mouse-mixin ;;tv:pane-no-mouse-select-mixin w:window) (:default-init-plist :font-map (LIST *kbd-font*) :help-message "If you type any characters while using the Glossary, they will appear in this small window. Typing a sequence of characters followed by the RETURN key will cause the Menu of Glossary Entries to display terms beginning with the entered string. If the entered string is a term in the Glossary, its definition will be displayed in the large display pane on the right titled \"Text of Selected Glossary Entries\".") (:documentation :combination "Keyboard input and message typeout window.")) (DEFMETHOD (kbd-pane :enable-io) () "Enables this pane to be used for input/output." (SETF pane-active-p t) (SEND self :clear-screen)) (DEFMETHOD (kbd-pane :disable-io) (&optional delayed-clear-pane-p) "Let this pane know that it will no longer be used for I/O until it is re-enabled" (SETF pane-active-p nil) (WHEN delayed-clear-pane-p (SEND self :delayed-clear-gray))) (DEFFLAVOR gloss-command-menu-pane () (gloss-pane-mixin ;;w:command-menu-pane ;;replaced by w:menu in Rel3 w:menu) (:documentation :combination "Command menu for the glossary display.") (:default-init-plist :command-menu t ;;initialization option to make the flavor a command menu in Rel3 :help-message "A menu of commands that can be selected by clicking with the mouse: EXIT GLOSSARY - leaves the Glossary. To return: SYSTEM Z CLEAR TEXT DISPLAY - Removes all displayed terms. (For Expert mode commands, see help on Expert Mode.)") ) (DEFFLAVOR xref-indicator-pane () (gloss-pane-mixin ;;w:command-menu-pane ;;replaced-by w:menu in Rel3) w:menu) (:documentation "A one-item menu that indicates whether cross reference deletion is enabled.") (:default-init-plist :command-menu t ;;initialization option to make the flavor a command menu in Rel3 :help-message "The exposure of this small pane indicates that cross reference deletion is enabled. Cross reference deletion allows you to delete individual cross references from within the text of a glossary entry. Deletion of individual cross references is accomplished by clicking right on the highlighted (boldface) entries within the text of a glossary entry. Remember that modifications to glossaries affect only the current working versions of glossaries. The modified glossaries must be written to a file to preserve the changes you make." :item-list '(("Cross Reference Deletion is Enabled" :eval (SEND *glossary-frame* :turn-off-xref-deletion) :documentation (:mouse-any "Click here to disable cross reference deletion."))) )) (DEFFLAVOR glossary-frame (;; All of the panes: text-pane command-pane alph-pane entry-pane kbd-pane) ( w:inferiors-not-in-select-menu-mixin ;;w:full-screen-hack-mixin ;;w:select-mixin w:process-mixin ;Process-Mixin should come before Select-Mixin (See doc for P-M) ;;w:borders-mixin ;;w:centered-label-mixin ;;w:top-label-mixin w:box-label-mixin ;;w:label-mixin w:window-with-typeout-mixin ;;w:stream-mixin w:window w:essential-mouse w:bordered-constraint-frame-with-shared-io-buffer) :settable-instance-variables ;All instance variables settable,gettable, and inittable (:method-combination (:case :base-flavor-last :execute-blip) (:case :base-flavor-last :help)) (:default-init-plist :process '(top-level ;Function to be run by the process :regular-pdl-size 3000.) ;Ensure the PDL stack isn't too small :save-bits :delayed ;Don't create a bit-save array until we need it :label (glossary-system-label) ;Generate a label for the system :borders 2 ) (:documentation "The main frame in which all glossary display occurs.") ) (DEFUN glossary-system-label () "This generates the label for the top of the glossary frame. It returns a list which is understood by the label displaying methods of the window system." `(:string ,(STRING-APPEND "Glossary System" (IF *glossary* ;Include the name of the current glossary in the label (FORMAT nil " - ~A" (SEND *glossary* :name)) "")) :font ,*title-font*)) (DEFMETHOD (glossary-frame :before :init) (ignore) "Set panes and constraints." (SETQ tv:panes `((text-pane glossary-text-pane :blinker-p nil :scroll-bar-draw-edge-p t :label (:font ,*label-font* :string "Text of Selected Glossary Entries")) (command-pane gloss-command-menu-pane :label (:font ,*label-font* :string "Glossary Command Menu") :default-font ,*command-menu-font* :borders (1 2 1 2) :command-menu t :scrolling-p nil :permanent t :item-list ,(command-menu-item-list)) (alph-pane alph-menu-pane :command-menu t :permanent t :item-alignment :center :label (:font ,*label-font* :string "Thumb Index")) (entry-pane entry-menu-pane :scroll-bar-draw-edge-p t :item-alignment :center :command-menu t :permanent t :dynamic t ;1Since item list will change, this allows window to modify itself* :label (:font ,*label-font* :string "Menu of Glossary Entries") :item-list ,(SEND *glossary* :entry-menu-item-list)) ;Probably NIL to begin with. (kbd-pane kbd-pane :label (:font ,*label-font* :string "Keyboard Typein Window") :borders (1 1 1 2) :more-p nil) (xref-indicator-pane xref-indicator-pane :label nil :command-menu t :permanent t :borders 2 :reverse-video-p t :default-font fonts:tr12b) ) tv:constraints '((landscape-1 (whole-thing) ((whole-thing :horizontal (:even) (left right) ((right :vertical (85. :characters text-pane) (text-pane) ((text-pane :even)))) ((left :vertical (:even) (bottom command-pane kbd-pane) ((kbd-pane 2 :lines)) ((command-pane :ask :pane-size)) ((bottom :horizontal (:even) (entry-pane alph-pane) ((alph-pane :ask :pane-size)) ((entry-pane :even))))))))) (landscape-with-xref-deletion (whole-thing) ((whole-thing :horizontal (:even) (left right) ((right :vertical (85. :characters text-pane) (text-pane xref-indicator-pane) ((xref-indicator-pane :ask :pane-size)) ((text-pane :even)))) ((left :vertical (:even) (bottom command-pane kbd-pane) ((kbd-pane 2 :lines)) ((command-pane :ask :pane-size)) ((bottom :horizontal (:even) (entry-pane alph-pane) ((alph-pane :ask :pane-size)) ((entry-pane :even))))))))) (portrait-1 (top command-pane kbd-pane) ((command-pane :ask :pane-size)) ((kbd-pane 2 :lines)) ((top :horizontal (:even) (left alph-pane) ((alph-pane :ask :pane-size)) ((left :vertical (:even) (entry-pane text-pane) ((entry-pane .35)) ((text-pane :even))))))) (portrait-with-xref-deletion (top command-pane kbd-pane) ((command-pane :ask :pane-size)) ((kbd-pane 2 :lines)) ((top :horizontal (:even) (left alph-pane) ((alph-pane :ask :pane-size)) ((left :vertical (:even) (entry-pane xref-indicator-pane text-pane) ((entry-pane .35)) ((xref-indicator-pane :ask :pane-size)) ((text-pane :even))))))) ) tv:configuration (proper-frame-configuration) )) (DEFUN proper-frame-configuration () "Returns the symbol representing the current Glossary configuration, based upon whether the monitor is landscape and whether x-ref deletion is enabled." (IF tv:*landscape-monitor* ;;T if we have a landscape monitor (IF *glossary-hacker-p* 'landscape-with-xref-deletion 'landscape-1) (IF *glossary-hacker-p* 'portrait-with-xref-deletion 'portrait-1))) (DEFMETHOD (glossary-frame :after :init) (&rest IGNORE) "Sets up the typeout window." (WHEN (NULL w:typeout-window) (SETQ w:typeout-window (tv:make-window 'w:typeout-window :deexposed-typeout-action '(:expose-for-typeout) :font-map '(fonts:tr12 fonts:tr12i fonts:tr12b fonts:tr12bi) :io-buffer w:io-buffer :superior self) text-pane (SEND self :get-pane 'text-pane) command-pane (SEND self :get-pane 'command-pane) alph-pane (SEND self :get-pane 'alph-pane) entry-pane (SEND self :get-pane 'entry-pane) kbd-pane (SEND self :get-pane 'kbd-pane)) ;;Color support added for 3.2 by SLM. Code read PMH and KJF. (send text-pane :set-label-background w:33%-gray-color) (send command-pane :set-background-color w:25%-gray-color) (send command-pane :set-label-background w:33%-gray-color) (send alph-pane :set-background-color w:25%-gray-color) (send alph-pane :set-label-background w:33%-gray-color) (send entry-pane :set-label-background w:33%-gray-color) (send kbd-pane :set-background-color w:25%-gray-color) (send kbd-pane :set-label-background w:33%-gray-color) )) (DEFMETHOD (glossary-frame :before :select) (&rest ignore) "Sets the global variables when this window is selected." (SETQ *glossary-frame* self *kbd-pane* (SEND self :get-pane 'kbd-pane) *text-pane* (SEND self :get-pane 'text-pane) *alph-pane* (SEND self :get-pane 'alph-pane) *command-pane* (SEND self :get-pane 'command-pane) *entry-pane* (SEND self :get-pane 'entry-pane))) ;(DEFMETHOD (glossary-frame :after :expose) (&rest IGNORE) ; "Causes fonts in the thumb index to be updated if necessary." ; ;(SEND (SEND self :get-pane 'alph-pane) :update-font) ; ) (DEFMETHOD (glossary-frame :after :refresh) (&rest IGNORE) "Causes fonts in the thumb index to be updated if necessary." (SEND alph-pane :update-font) ) (DEFMETHOD (glossary-frame :who-line-documentation-string) () (SEND kbd-pane :who-line-documentation-string)) (DEFMETHOD (glossary-frame :case :help :main) () "Pop up a menu of the possibilities for help." (LET* ;; Build a list of help possibilities to select from ((menu-item-list (APPEND `(("General Help" :value :general-help :font ,fonts:hl12b :documentation "Click here for general documentation about the Glossary.") ("" :no-select nil) ("Expert Mode Help" :value :expert-help :font ,fonts:hl12b :documentation "Information about the glossary maintainance features of the Glossary.") ("" :no-select nil) ("Descriptions of Individual Glossary Windows" :no-select nil :font ,fonts:hl12i)) (LOOP for (nil . pane-object) in tv:internal-panes ;Pane is a cons: ( . ) when (SEND pane-object :exposed-p) collect (LIST (OR (SIXTH (SEND pane-object :label)) ;6th element of :label is string "Cross Reference Deletion Indicator.") :value pane-object ;The window object :documentation "Information on the window with this label" :font fonts:hl12bi)))) ;; Get a response from the user (what kind of help) (selected-help-option (w:menu-choose menu-item-list :label `(:string "Select Topic for Help: " :font ,fonts:tr12i)))) ;; Execute the specified type of help (SEND self :help selected-help-option))) (DEFMETHOD (glossary-frame :help) (&optional (context :main)) "Provides help to the user. Invoked by the HELP key or clicking HELP in the command menu." ;; Possibility for providing multiple kinds of help ;; For, now, only one kind of help (COND ((NULL context)) ;Don't do anything if CONTEXT is NIL ((TYPEP context 'gloss-pane-mixin) ;CONTEXT is a window (SEND context :display-help)) ((LET ((doc-string (SECOND (ASSOC context *glossary-documentation* :TEST #'EQ))) (format-args (CDDR (ASSOC context *glossary-documentation* :TEST #'EQ)))) (IF doc-string (UNWIND-PROTECT (PROGN (SEND *TERMINAL-IO* :EXPOSE-FOR-TYPEOUT) (SEND *TERMINAL-IO* :select) (APPLY #'FORMAT *TERMINAL-IO* doc-string format-args) (FORMAT *TERMINAL-IO* "~&~%~%~a" tv:*remove-typeout-standard-message*) (SEND *TERMINAL-IO* :any-tyi)) (SEND self :set-configuration ;refresh the screen to get rid of typeout. (proper-frame-configuration)) (SEND kbd-pane :make-pane-gray) (SEND *TERMINAL-IO* :make-complete))) doc-string)) ;Return a value for whether we did anything here. (t (SEND self :report-error (FORMAT nil "Unknown HELP was requested:~%~A" context))) )) (DEFMETHOD (glossary-frame :report-error) (error-string) "Notifies the user of an error condition." (w:notify nil error-string)) (DEFMETHOD (glossary-frame :lookup-entry) (entry-name) "ENTRY-NAME is either the name of a prospective glossary entry or the actual entry object. The entry menu is scrolled so that ENTRY-NAME is visible (if it were present). If the entry is in the glossary, it's text is displayed, otherwise the user is informed that the glossary entry is not present." (SEND entry-pane :select-char ;Scroll the menu so that entry-name is displayed (IF (TYPEP entry-name 'glossary-entry) (SEND entry-name :name) entry-name)) ;; Now see if it is in the glossary (LET ((entry (IF (TYPEP entry-name 'glossary-entry) entry-name ;Just return the entry if it is already an entry (LOOP for entry in (SEND *glossary* :entry-list) ;Look for the entry WHEN (STRING-EQUAL (SEND entry :name) entry-name) RETURN entry finally (RETURN nil))))) (COND ((NOT (NULL entry)) ;Entry was found (SEND text-pane :add-entry entry) (SEND kbd-pane :clear-screen) (SEND kbd-pane :make-pane-gray)) (T (SEND kbd-pane :clear-screen) ;Entry was not found (BEEP) (FORMAT kbd-pane "The entry (~A) was not found." entry-name)) ) )) (DEFMETHOD (glossary-frame :toggle-glossary-tools) () "Turns the display of the glossary tools on or off (toggles)." (SETQ *glossary-tools-on* (NOT *glossary-tools-on*)) ;Toggle whether the commands are in the menu. (w:delaying-screen-management (SEND command-pane :set-item-list (command-menu-item-list)) (SEND self :set-configuration (proper-frame-configuration)) ;This is the slowest step (SEND alph-pane :update-font) (SEND kbd-pane :make-pane-gray) (send entry-pane :set-scroll-bar-mode :minimum))) (DEFMETHOD (glossary-frame :choose-configuration) () "Asks the user for a new configuration and the sets the display to that configuration." (LET* ((item-list (LOOP for constraint in tv:constraints collect (FIRST constraint))) (new-config (w:menu-choose item-list :label "Choose a new configuration:"))) (SEND self :set-configuration new-config))) (DEFMETHOD (glossary-frame :load-glossary-if-needed) (glossary) "Checks to see if GLOSSARY is loaded yet. If it isn't and it can be loaded, it is loaded." (LET ((*glossary* glossary)) (UNLESS (SEND glossary :entries-p) (SEND kbd-pane :enable-io) (FORMAT kbd-pane "Now loading the glossary ...") (CONDITION-CASE (condition) (LET* ((lookup-pathname (fs:parse-pathname (SEND glossary :file-to-load))) (file-type (SEND lookup-pathname :canonical-type)) (file-format (LOOP for format in (glossary-formats-in-decreasing-priority) WHEN (EQUALP file-type (SEND format :file-type)) RETURN format finally (RETURN nil)))) (COND ((NOT (NULL file-format)) (SEND glossary (SEND file-format :glossary-read-method) lookup-pathname)) ((NULL file-type) (LOOP for format in (glossary-formats-in-decreasing-priority) WHEN (SEND format :load-if-exists lookup-pathname) RETURN t ;Stop searching since we just found (and loaded a file) finally (PROGN (tv:notify nil "The file ~A does not exist.~%The current glossary is empty." lookup-pathname) (SEND kbd-pane :delayed-clear-gray)))) (t (BEEP) ;(FORMAT kbd-pane "~:|The load file for ~A is the wrong type." (tv:notify nil "The load file for ~A is the wrong type." (SEND glossary :name)) (SEND kbd-pane :delayed-clear-gray))) ) (ERROR (BEEP) (IF (W:MOUSE-Y-OR-N-P (FORMAT nil "~A:~%Retry load of glossary file ~A?" (SEND condition :report-string) (SEND glossary :name))) (SEND self :load-glossary-if-needed *glossary*) (SEND kbd-pane :delayed-clear-gray 1))) (t nil)) (SEND kbd-pane :disable-io)))) (DEFMETHOD (glossary-frame :prompt-for-another-glossary) (prompt-string string-if-no-others) "Prompts the user for a glossary other than the current glossary. If there aren't any other glossaries to select, then the user is informed by a message stating STRING-IF-NO-OTHERS. If another glossary is not selected, then NIL is returned." (COND ((<= (LENGTH *list-of-glossaries*) 1) ;Can't select a glossary if there aren't any to select (BEEP) (FORMAT kbd-pane "~:|~A" string-if-no-others) (SEND kbd-pane :delayed-clear-gray) nil ;Returned value ) (t (LET ((selected-glossary (SEND self :menu-choose-glossary prompt-string))) (IF (OR (NOT (TYPEP selected-glossary 'glossary)) ;Invalid glossary selected (or no glossary) (EQ selected-glossary *glossary*)) ;Selected the glossary that is already current nil selected-glossary))))) (DEFMETHOD (glossary-frame :menu-choose-glossary) (&optional (prompt "Select A Glossary:")) "Presents a menu of the possible glossaries and returns the selected one (or NIL)." (LET ((menu-item-list (APPEND '(("" :no-select nil)) (LOOP for glossary in *list-of-glossaries* collect (make-menu-item :display-string (FORMAT nil "~:[ ~;*~] ~20A~:[ ~;- Current~]" (SEND glossary :entries-p) (SEND glossary :name) (EQ *glossary* glossary)) :value glossary :documentation "Select this as the current glossary.")) `(("" :no-select nil) ("* means that the glossary is already loaded" :no-select nil :font ,fonts:hl12b)) ))) (w:menu-choose menu-item-list :label `(:string ,prompt :font ,*pop-up-menu-title-font*) :near-mode `(:window ,*command-pane*) :superior self))) (DEFMETHOD (glossary-frame :define-new-glossary) () "Defines a new glossary for the system, querying the user for name and filename." (LET ((name "") (filename "")) (SEND kbd-pane :enable-io) ;Give us full access to the kbd-pane (FORMAT kbd-pane "~:|Name of new glossary: ") (SETQ name (READ-LINE kbd-pane)) (FORMAT kbd-pane "~:|Filename of glossary entries: ") (SETQ filename (fs:merge-pathname-defaults (READ-LINE kbd-pane) *default-pathname* nil nil)) (SEND kbd-pane :disable-io) ;Done with the pane (SEND kbd-pane :make-pane-gray t) (PUSH (MAKE-INSTANCE 'glossary :name name :file-to-load filename) *list-of-glossaries*))) (DEFMETHOD (glossary-frame :select-glossary) () "Selects a glossary to be the current glossaray." (LET ((selected-glossary (SEND self :prompt-for-another-glossary "Select a glossary to become the current glossary." "There aren't any other glossaries to select."))) (WHEN (NOT (NULL selected-glossary)) ;;Check to see if the glossary has been loaded. (SEND self :load-glossary-if-needed selected-glossary) (SEND kbd-pane :delayed-clear-gray 1) (SEND self :set-current-glossary selected-glossary) ))) (DEFMETHOD (glossary-frame :delete-glossary) () "Delete a defined glossary from the system." (SEND kbd-pane :enable-io) (LET ((glossary-to-delete (SEND self :menu-choose-glossary "Select a glossary to delete:"))) ;; If the current glossary (*glossary*) is being deleted, select another glossary to be current (WHEN (AND (NOT (NULL glossary-to-delete)) (EQ *glossary* glossary-to-delete)) (LET ((new-current-glossary (SEND self :prompt-for-another-glossary "Select a glossary to become the current glossary." "You cannot delete the only remaining glossary."))) (IF (NULL new-current-glossary) (SETQ glossary-to-delete nil) ;Means that a glossary won't be deleted (SEND self :set-current-glossary new-current-glossary)))) ;; Actually perform the deletion of the glossary. (COND ((NULL glossary-to-delete) (BEEP) (FORMAT kbd-pane "~%No glossary deleted.")) (t (SETQ *list-of-glossaries* (DELETE glossary-to-delete *list-of-glossaries* :TEST #'EQ)) (PUSH glossary-to-delete *deleted-glossaries*) ;Don't lose it entirely (FORMAT kbd-pane "~:|Glossary ~S has been deleted." (SEND glossary-to-delete :name)))) (SEND kbd-pane :disable-io t) )) (DEFMETHOD (glossary-frame :set-current-glossary) (new-glossary) "Sets the current glossary to be NEW-GLOSSARY." (SETQ *glossary* new-glossary) (SEND *entry-pane* :set-item-list (SEND *glossary* :entry-menu-item-list)) (SEND *command-pane* :set-item-list (command-menu-item-list)) (SEND self :set-label (glossary-system-label))) (DEFMETHOD (glossary-frame :merge-glossaries) () "Merges another (defined) glossary into the current glossary. The other glossary is then deleted because its entries are now in the current glossary. (a copy is not done)" (LET ((selected-glossary (SEND self :prompt-for-another-glossary "Select a glossary to merge into the current glossary." "There aren't any other glossaries to merge."))) (WHEN (NOT (NULL selected-glossary)) ;;Check to see if the glossary has been loaded. (SEND self :load-glossary-if-needed selected-glossary) (SEND *glossary* :merge-in-glossary selected-glossary) (SETQ *list-of-glossaries* (DELETE selected-glossary *list-of-glossaries* :TEST #'EQ)) (SEND entry-pane :set-item-list (SEND *glossary* :entry-menu-item-list))))) (DEFMETHOD (glossary-frame :generate-xrefs) () "(Re)Generates the cross references for the current glossary" (LET ((do-xrefs nil) (glossary-length (LENGTH (SEND *glossary* :entry-list))) (*query-io* kbd-pane)) (SEND kbd-pane :enable-io) ;; Determine whether xrefs should really be generated. (SETQ do-xrefs (COND ((AND (INTEGERP *xref-generation-notification*) (< glossary-length *xref-generation-notification*)) t) ;The glossary isn't long enough to ask for confirmation ((AND (INTEGERP *xref-generation-notification*) (Y-OR-N-P "~:|Because of it's size (~D), cross reference generation ~ ~%will take a while. Do you still want to do it? " glossary-length)) t) ;User understands that it will take a while ((EQ *xref-generation-notification* :allow-xref) t) ;User allows xref generation regardless of length of glossary (t nil))) (COND (do-xrefs (FORMAT kbd-pane "~:|Generating all cross references ...") (LOOP for entry in (SEND *glossary* :entry-list) DO (SEND entry-pane :select-char (SEND entry :name)) (SEND entry :generate-x-references)) (FORMAT kbd-pane "~:|Cross references have been generated.")) ;;; (SEND *glossary* :generate-x-references)) (t (FORMAT kbd-pane "~:|Cross references have not been generated."))) (SEND kbd-pane :disable-io) (SEND kbd-pane :delayed-clear-gray 1))) (DEFMETHOD (glossary-frame :add-glossary-entry) () "Adds a glossary entry to the current glossary." (LET (entry-name (entry-text-list nil)) (SEND kbd-pane :enable-io) (FORMAT kbd-pane "~:|Entry Name: ") (SETQ entry-name (READ-LINE kbd-pane)) (FORMAT kbd-pane "~:|Now type in the text for ~S" entry-name) (SETQ entry-text-list (SEND self :edit-glossary-entry-text nil)) ;;Add this entry to the current glossary (SEND *glossary* :add-entry entry-name entry-text-list) (FORMAT kbd-pane "~:|~S added to glossary." entry-name) (SEND kbd-pane :disable-io) (SEND kbd-pane :delayed-clear-gray) (SEND entry-pane :set-item-list (SEND *glossary* :entry-menu-item-list)) (SEND self :lookup-entry entry-name) )) (DEFMETHOD (glossary-frame :edit-glossary-entry-text) (entry-text-list) "Pops up a temporary Zmacs Editor pane over the Entry Text Pane, allowing the user to edit the text for the glossary entry. Input is a list of strings, one for each line of text. Output is the modified list of strings." (DECLARE (VALUES modified-entry-text-list)) (LET (width height (zwei:*fill-column* 480.) ;60 characters (zwei:auto-fill-mode ;;This is a kludge to keep the END key description always on the screen (STRING-APPEND zwei:auto-fill-mode " (Press END key to exit editing)")) entry-text) (DECLARE (SPECIAL zwei:auto-fill-mode)) ;This isn't declared special anywhere else (MULTIPLE-VALUE-SETQ (width height) (SEND text-pane :size)) ;; Get rid of that left margin (SETQ entry-text-list (LOOP for line in entry-text-list WHEN (AND (STRINGP line) (> (LENGTH line) *entry-text-left-margin*)) collect (SUBSEQ line *entry-text-left-margin*) else collect line)) ;; The real editing goes on here. (SETQ entry-text (zwei:pop-up-edstring (FORMAT nil "~{~a~%~}" entry-text-list) `(:point ,(+ (SEND self :x-offset) (SEND text-pane :x-offset) (TRUNCATE width 2)) ,(+ (SEND self :y-offset) (SEND text-pane :y-offset) (TRUNCATE height 2))) '(zwei:text-mode zwei:auto-fill-mode) ;Yes, we have auto fill mode width height "Type in text above.")) ;;Take the long string from the editor and break it up into a list of strings (SETQ entry-text-list nil) (WITH-INPUT-FROM-STRING (in-stream entry-text) (LOOP for line = (MULTIPLE-VALUE-BIND (string eof) (READ-LINE in-stream nil :eof) (IF (EQ eof :eof) eof string)) until (EQ line :eof) DO ;;Also give each line a left margin (PUSH-END (FORMAT nil "~V@T~A" *entry-text-left-margin* line) entry-text-list) finally (PUSH-END "" entry-text-list) ;Blank line at end of text )) entry-text-list)) (DEFMETHOD (glossary-frame :edit-glossary-entry) () "Pops up the text of a glossary entry to edit." (LET ((entry (SEND self :select-entry "Click on the name of the entry to edit:")) entry-text-list) (SETQ entry-text-list (LOOP for line in (SEND entry :text-list) collect (text-line-string line))) (SETQ entry-text-list (SEND self :edit-glossary-entry-text entry-text-list)) (SEND entry :set-text-list (LOOP for line in entry-text-list collect (make-text-line :string line))) (SEND entry :set-x-references nil) (SEND text-pane :add-entry entry))) (DEFMETHOD (glossary-frame :select-entry) (&optional (prompt "Click on the name of an entry:")) "Prompts the user to select an entry from any of those displayed." (DECLARE (VALUES entry)) (LET ((entry nil)) (SEND kbd-pane :enable-io) (FORMAT kbd-pane "~:|~A " prompt) (LOOP for input-blip = (SEND self :any-tyi) ;;Wait for input until the user ABORTs from the operation ;;or clicks on a glossary entry until (AND (LISTP input-blip) (NEQ :no-entry-selected ;;Returned value if the user didn't select a glossary entry (CASE (FIRST input-blip) ;First element is the blip type (:entry (SETQ entry (entry-menu-blip-entry-object input-blip))) (:entry-item (SETQ entry (SECOND input-blip))) (:xref-item (SETQ entry (mouse-xref-entry-object (SECOND input-blip)))) ;;The alph menu works here. Makes the selection easier. (:alph-menu ;;Move the entry menu to the proper spot and wait again for input (SEND self :execute-blip :alph-menu input-blip) :no-entry-selected ) ;;Otherwise loop again, waiting for the correct input (otherwise :no-entry-selected) ) )) do (BEEP) (FORMAT kbd-pane "~:|~A~%[Press the ABORT key to abort operation]" prompt)) (SEND kbd-pane :disable-io) (SEND kbd-pane :delayed-clear-gray) entry )) (DEFMETHOD (glossary-frame :remove-glossary-entry) () "Removes a glossary entry to the current glossary." (LET ((entry (SEND self :select-entry "Click on name of the entry to be deleted.")) (*terminal-io* kbd-pane)) (SEND kbd-pane :enable-io) ;; Verify that the user really wanted to delete this entry. (UNLESS (AND (NOT (NULL entry)) (Y-OR-N-P "Delete the entry ~s? " (SEND entry :name))) (SETQ entry nil)) (SEND kbd-pane :disable-io) ;;Delete this entry from the current glossary (if (NULL entry) (SEND kbd-pane :make-pane-gray t) (PROGN (SEND *text-pane* :remove-entry entry) (SEND (SEND entry :glossary) :remove-entry entry) (SEND kbd-pane :enable-io) (FORMAT kbd-pane "~:|~S removed from ~A." (SEND entry :name) (SEND (SEND entry :glossary) :name)) (SEND kbd-pane :disable-io) (SEND kbd-pane :delayed-clear-gray) (SEND entry-pane :set-item-list (SEND *glossary* :entry-menu-item-list)) )))) (DEFMETHOD (glossary-frame :Undelete-glossary-entry) () "Allows the user to undelete a previously deleted glossary entry." (LET ((entry nil) (*terminal-io* kbd-pane)) (COND ((NULL *deleted-glossary-entries*) (SEND kbd-pane :enable-io) (FORMAT kbd-pane "There aren't any glossary entries to undelete.")) (t (SETQ entry (w:menu-choose (LOOP for entry in *deleted-glossary-entries* collect (LIST (SEND entry :name) :value entry)) :label "Click on Glossary Entry to Undelete:")) (SEND kbd-pane :enable-io) (COND ((NULL entry) ;If the user didn't select an entry from the menu. (FORMAT kbd-pane "~:|No glossary entry was undeleted.")) ((MEMBER entry (SEND *glossary* :entry-list) :TEST #'EQ) (FORMAT kbd-pane "~:|This entry is already part of this glossary.")) (t ;;; Ensure that the object is pointing to this glossary (WHEN (NEQ (SEND entry :glossary) *glossary*) (SEND entry :set-glossary *glossary*) (IF *auto-generate-x-references-p* (SEND entry :generate-x-references) (SEND entry :delete-x-references))) (SEND *glossary* :add-entry entry) (FORMAT kbd-pane "~:|~s added to current glossary." (SEND entry :name)) (SEND entry-pane :set-item-list (SEND *glossary* :entry-menu-item-list)) (SEND self :lookup-entry entry) (SETF *deleted-glossary-entries* (DELETE entry *deleted-glossary-entries* :TEST #'EQ)) )))) (SEND kbd-pane :disable-io) (SEND kbd-pane :delayed-clear-gray) )) (DEFMETHOD (glossary-frame :remove-xref) (mouse-xref) "Removes the selected cross reference from it's glossary. Of course, this change is only made in memory; the glossary must be re-written to make the change permanent." (LET ((object (mouse-xref-entry-object mouse-xref))) (FORMAT kbd-pane "~:|Deleting all cross references for ~A." (SEND object :name)) (LOOP for entry in (SEND *glossary* :entry-list ) do (LOOP for text-line in (SEND entry :text-list) do (LOOP for xref-object in (text-line-xref-list text-line) do (IF (EQ object (xref-entry-object xref-object)) (SETF (text-line-xref-list text-line) (DELETE xref-object (text-line-xref-list text-line) :TEST #'EQ)))))) (SEND kbd-pane :delayed-clear-gray) (SEND text-pane :clear-screen) (MULTIPLE-VALUE-BIND (ignore ignore ignore lines) (SEND text-pane :scroll-position) (SEND text-pane :redisplay 0 lines)) )) (DEFMETHOD (glossary-frame :write-current-glossary) () "Writes the current glossary in a form specified by the user to a user specified file." (LET (filename ;; The default pathname should not have a type (user will be queried for format) (pathname-default (SEND (SEND *glossary* :file-to-load) :new-type nil)) gloss-file-format) (SEND kbd-pane :enable-io) (IF (NOT (SEND *glossary* :entries-p)) (FORMAT kbd-pane "~:|Current glossary (~A) is empty.~%Cannot write an empty glossary to a file." (SEND *glossary* :name)) (FORMAT kbd-pane "~:|Name of file to write: ~%(default is ~A) " pathname-default) (SETQ filename ;Again, the filename should not have a type (SEND (fs:merge-pathnames (READ-LINE kbd-pane) pathname-default) :new-type nil)) (SETQ gloss-file-format (w:menu-choose (LOOP for format in *glossary-file-formats* collect (LIST (SEND format :name) :value format :documentation (SEND format :documentation-string))) :label `(:string "Choose file format:" :font ,*pop-up-menu-title-font*) :near-mode `(:window ,*command-pane*) :superior self)) (UNLESS (NULL gloss-file-format) (FORMAT kbd-pane "~:|Writing ~A ..." filename) (SEND *glossary* :write-file (SEND gloss-file-format :name) filename))) (SEND kbd-pane :disable-io) (SEND kbd-pane :delayed-clear-gray))) (DEFMETHOD (glossary-frame :turn-on-xref-deletion) () "Turns on the ability to delete cross references in the text display." (SETF *glossary-hacker-p* t) ;Simple (SEND self :set-configuration (proper-frame-configuration)) (SEND command-pane :set-item-list (command-menu-item-list))) ;Update the user display (DEFMETHOD (glossary-frame :turn-off-xref-deletion) () "Turns off the ability to delete cross references in the text display." (SETF *glossary-hacker-p* nil) ;Simple (SEND self :set-configuration (proper-frame-configuration)) (SEND command-pane :set-item-list (command-menu-item-list))) ;Update the user display (DEFMETHOD (glossary-frame :case :execute-blip :menu) (blip) (SEND (FOURTH blip) :execute (SECOND blip))) (DEFMETHOD (glossary-frame :case :execute-blip :mouse-item) (blip) (SEND (SECOND blip) (THIRD blip))) (DEFMETHOD (glossary-frame :case :execute-blip :mouse-button) (blip) (IF (= 2 (LDB sys:%%kbd-mouse-button (SECOND blip))) (w:mouse-call-system-menu) (BEEP))) (DEFMETHOD (glossary-frame :case :execute-blip :entry) (blip) (SEND text-pane :add-entry (entry-menu-blip-entry-object blip))) (DEFMETHOD (glossary-frame :case :execute-blip :alph-menu) (blip) (SEND entry-pane :select-char (alph-menu-blip-string blip))) (DEFMETHOD (glossary-frame :case :execute-blip :xref-item) (blip) ;Blip format: (:XREF-ITEM ); := (IF *glossary-hacker-p* (CASE (LDB sys:%%kbd-mouse-button (FOURTH blip)) ;Find out which button ((0 1) ;Left or Middle (SEND (THIRD blip) :add-entry (mouse-xref-entry-object (SECOND blip)))) (2 ;Right Button (SEND self :remove-xref (SECOND blip)))) ;;If not a hacker, do a xref lookup regardless of the mouse button used. (SEND (THIRD blip) :add-entry (mouse-xref-entry-object (SECOND blip))))) (DEFMETHOD (glossary-frame :case :execute-blip :entry-item) (blip) ;Blip format: (:ENTRY-ITEM ); := (LET ((mouse-button (LDB sys:%%kbd-mouse-button (FOURTH blip)))) (COND ((OR (EQ mouse-button 0.) ;Left or Middle Buttons (AND (NOT *glossary-hacker-p*) (EQ mouse-button 1.))) (SEND (THIRD blip) :add-entry (SECOND blip))) ((EQ mouse-button 1.) ;Middle button and must be a glossary hacker (SEND (SECOND blip) :generate-x-references) (SEND (THIRD blip) :add-entry (SECOND blip))) ((EQ mouse-button 2.) ;Right button (always) (SEND (THIRD blip) :remove-entry (SECOND blip)))))) (DEFMETHOD (glossary-frame :execute-blip) (blip) "This primary method is called if none of the blip types have been recognized by any of the :CASE methods." (DECLARE (IGNORE blip)) (BEEP)) (DEFMETHOD (glossary-frame :command-loop-break) () "Handles the BREAK key by entering a breakpoint loop." (SEND *TERMINAL-IO* :expose-for-typeout) (SEND *TERMINAL-IO* :select) (CATCH-ERROR-RESTART ((ERROR sys:abort) "Return to Glossary top level") (LET ((ucl:*default-typein-modes* 'ucl:(functions symbols pathname-completion))) (BREAK "Glossary" nil))) (SEND self :set-configuration (proper-frame-configuration)) (SEND *TERMINAL-IO* :make-complete) (SEND kbd-pane :make-pane-gray) ) (DEFMETHOD (glossary-frame :handle-normal-keyboard-input) (input-character) "Handles all non-special case keyboard input." (IF (LDB-TEST sys:%%kbd-control-meta input-character) (BEEP) (PROGN (SEND kbd-pane :untyi input-character) ;Put the character back into the input buffer (SEND kbd-pane :enable-io) ;Clear the display in the keyboard pane (MULTIPLE-VALUE-BIND (thing flag) ;Preemptable read handling (SEND kbd-pane :preemptable-read '((:full-rubout :full-rubout-flag) ;Full rubout handling (:prompt "Type a glossary name to lookup: ")) 'tv:read-string kbd-pane) (SEND kbd-pane :disable-io) (CASE flag (:full-rubout-flag ;Clear everything (incl. prompt) if all input is rubbed out (SEND kbd-pane :set-cursorpos 0 0) (SEND kbd-pane :clear-screen) (SEND kbd-pane :make-pane-gray)) (:mouse-char (SEND kbd-pane :set-old-typeahead nil) ;Forget the characters the user has typed (SEND kbd-pane :clear-screen) (SEND kbd-pane :make-pane-gray) (SEND kbd-pane :untyi thing)) ;Put the mouse blip back into the input buffer (otherwise ;Do a lookup of the string that has just been typed in (SEND self :lookup-entry (STRING-TRIM '(#\space) thing)))) ;Be sure there are no extra spaces )) )) (DEFMETHOD (ENTRY-MENU-PANE :DECIDE-IF-SCROLLING-NECESSARY) () 1"Turn the scroll-bar on for the Glossary Entry Menu Pane."* ;;;This is a real kludge to the window system. At present, the scroll-bar ;;;has real problems. If you use the Window's :DECIDE-IF-SCROLLING-NECESSARY, ;;;the entry pane gets resized over the Thumb Index when the scroll bar is turned ;;;on. The real problem is in windows, but this gets around the problem for ;;;Glossary. The window's doc string follows: ;;; 1"Turn the scroll-bar regions on or off for scroll-bar-on-off windows.* ;;;1 This method should be called after changing the number of displayable* ;;;1 items, but before doing the redisplay. This can change the inside size* ;;;1 of the window unless :ADJUSTABLE-SIZE-P has been defined and returns * ;;;1 t. In that case the outside size should be set before entering this method."* ;;; ;;;An editorial comment about this kludge: ;;; PTHTHTHTHTHTHTHHTHTHTHTHHTHTHTHTHTHTHTPPPPTT! ;;; (multiple-value-bind (left-edge top-edge right-edge bottom-edge) (send self :edges) (unwind-protect (when w:scroll-bar-on-off (BIND (LOCATE-IN-INSTANCE SELF 'w:SCROLL-BAR-MAKING-DECISION) T) (LET ((IW (w:SHEET-INSIDE-WIDTH)) (IH (w:SHEET-INSIDE-HEIGHT)) (CHANGEP NIL) SCROLL-NOW) ;; When we ask whether everything fits, pretend there are no scroll regions. (let () (BIND (LOCATE-IN-INSTANCE SELF 'w:SCROLL-BAR-ON-OFF) :off) (BIND (LOCATE-IN-INSTANCE SELF 'w:SCROLL-BAR-REGION) (list (car w:scroll-bar-region))) (MULTIPLE-VALUE-BIND (left NIL right NIL) (SEND SELF :COMPUTE-MARGINS 0 0 0 0) (BIND (LOCF w:left-MARGIN-SIZE) left) (BIND (LOCF w:right-MARGIN-SIZE) right) (SETQ SCROLL-NOW (SEND SELF :ENABLE-SCROLLING-P)))) ;; Now SCROLL-NOW says whether we must now have scrolling. ; (multiple-value-bind (ignore n-lines1 * ignore n-screen-lines) ; 1 *(send self :scroll-position) (when scroll-now ;(if (and scroll-now (> n-lines n-screen-lines)) (setq scroll-now :on) ;(setq scroll-now :off) ) (when (neq scroll-now w:scroll-bar-on-off) (setq w: scroll-bar-on-off scroll-now changep t)) (SEND SELF :REDEFINE-MARGINS) (AND CHANGEP (SEND SELF :SEND-IF-HANDLES :ADJUSTABLE-SIZE-P) (SEND SELF :SET-INSIDE-SIZE IW IH)))) (send self :set-edges left-edge top-edge right-edge bottom-edge)))) ;) ;;; This function gets called because of the process-mixin :process init option. (DEFUN top-level (frame) (DECLARE (SPECIAL *initial-glossary-loaded-p*)) (LET ((entry-pane (SEND frame :get-pane 'entry-pane)) (kbd-pane (SEND frame :get-pane 'kbd-pane)) (default-cons-area *glossary-area*)) (LOOP (ERROR-RESTART ((sys:abort ERROR) "Glossary Top Level.") (WHEN (NOT (SEND *glossary* :entries-p)) (SEND entry-pane :make-pane-gray) (SETQ *initial-glossary-loaded-p* nil) ;Until glossary is completely loaded, don't allow actions. (SEND frame :load-glossary-if-needed *glossary*) (SETQ *initial-glossary-loaded-p* t) ) (SEND kbd-pane :set-pane-active-p nil) (SEND kbd-pane :make-pane-gray t) (SEND entry-pane :clear-screen) (SEND entry-pane :set-item-list (SEND *glossary* :entry-menu-item-list)) ;;The next form is a kludge to get the scroll bar displayed in the entry-pane. ;;Without this call to :decide-if-scrolling-necessary, the scroll bar would not ;;be displayed until the configuration is toggled to expert mode. This is ;;actually a window system bug, and a report has been filed. 2/87 SLM (SEND entry-pane :decide-if-scrolling-necessary) (command-loop frame)) (w:deselect-and-maybe-bury-window frame)))) (DEFSUBST blip-type (blip) "Returns the blip type of this blip, which is the CAR of the blip by convention." (FIRST blip)) ;;; Main command loop (DEFUN command-loop (frame) (LET* ((typeout-window (SEND frame :typeout-window)) (*terminal-io* typeout-window) (*standard-output* si:syn-terminal-io) (*standard-input* si:syn-terminal-io) (text-pane (SEND frame :get-pane 'text-pane)) (kbd-pane (SEND frame :get-pane 'kbd-pane)) (*debug-io* kbd-pane) (ucl:*default-typein-modes* *glossary-typein-modes*) (w:kbd-intercepted-characters (REMOVE (OR (ASSOC #\BREAK w:kbd-intercepted-characters :TEST #'EQ) (ASSOC (CHAR-CODE #\BREAK) w:kbd-intercepted-characters :TEST #'EQ)) W:KBD-INTERCEPTED-CHARACTERS :TEST #'EQUAL))) (CATCH :exit (SEND kbd-pane :refresh-help 'w:erase) ;Just in case there are some residual completion info (LOOP with command do ;;cleanup typeout window if necessary (WHEN (SEND typeout-window :incomplete-p) (SEND typeout-window :make-complete)) ;;Get the next user input (mouse blip or character) (SETQ command (SEND frame :any-tyi)) ;;now, handle the input (IF (CONSP command) ;;List = a mouse blip (SEND frame :execute-blip (blip-type command) command) (CASE (CHARACTER command) ;The (character ...) form can be removed when the (read-any ...) is ready. ;;Handle special characters (#\BREAK (SEND frame :command-loop-break)) (#\HELP (SEND frame :help :main)) (#\Meta-Control-T (SEND frame :toggle-glossary-tools)) ;Brings up some glossary manipulation tools (#\Meta-Control-D (SEND frame (IF *glossary-hacker-p* :turn-off-xref-deletion :turn-on-xref-deletion))) ((#\c-V #\ #\) (SEND text-pane :scroll-relative :bottom :top)) ((#\m-V #\ #\ ) (SEND text-pane :scroll-relative :top :bottom)) (#\END (THROW :exit :exit-from-keyboard)) (#\PAGE (WHEN (SEND typeout-window :active-p) (SEND typeout-window :clear-screen))) (#\RUBOUT) ;don't go through rubout handler for nothing ;Standard keyboard input (OTHERWISE (SEND frame :handle-normal-keyboard-input command))))))) t) (DEFUN set-font (font-id) "Sets the current font of *TERMINAL-IO* to be FONT-ID. Note that undos must be explicitly done." (SEND *TERMINAL-IO* :set-current-font font-id)) (W:ADD-TO-SYSTEM-MENU-COLUMN :user-aids "Glossary" '(w:select-or-create-window-of-flavor 'glossary-frame) "Glossary - display definitions of terms") (W:ADD-SYSTEM-KEY *system-key* 'glossary-frame "Glossary - display definitions of terms." t) (DEFUN glossary (&optional entry-name) "This is the user-callable function that selects the glossary. The optional argument is a glossary entry to lookup and display. ENTRY-NAME can be either a string (the name of the glossary entry) or an actual glossary entry." (DECLARE (SPECIAL *initial-glossary-loaded-p*)) (w:select-or-create-window-of-flavor 'glossary-frame) (WHEN entry-name ;Delay trying to display entry until flavor knows about them. (PROCESS-WAIT "Loading Glossary" #'(lambda () *initial-glossary-loaded-p*)) (SEND *glossary-frame* :lookup-entry entry-name)) (tv:await-window-exposure)) ;;; ;;; GLOSSARY TYPEIN MODE SUPPORT (Completion, etc.) ;;; (DEFUN complete-glossary-entry (name) "Attempts to complete NAME to an entry name in the current glossary." (DECLARE (VALUES list-of-possible-completions)) (LOOP for entry in (SEND *glossary* :entry-list) for entry-name = (SEND entry :name) when (AND (>= (LENGTH entry-name) (LENGTH name)) (STRING-EQUAL name (SUBSEQ entry-name 0 (LENGTH name)))) collect entry-name)) (DEFUN apropos-glossary-entry (name) "Attempts to find the glossary entries which contain NAME in their names." (DECLARE (VALUES list-of-possible-entry-names)) (LOOP for entry in (SEND *glossary* :entry-list) for entry-name = (SEND entry :name) when (AND (>= (LENGTH entry-name) (LENGTH name)) (SEARCH name entry-name :TEST #'CHAR-EQUAL)) collect entry-name)) (DEFFLAVOR glossary-entry-completion () (ucl:typein-mode) (:default-init-plist :description "Handles recognition and apropos completion on glossary entry names." :documentation "This symbol handles completion of glossary entry names when in the Glossary.") (:documentation "This symbol handles completion of glossary entry names when in the Glossary.")) (DEFMETHOD (glossary-entry-completion :complete-p) (syntax) (WHEN (EQ syntax :first-atom) "Glossary entries")) (DEFMETHOD (glossary-entry-completion :complete) (STRING type) (CASE type (:recognition (complete-glossary-entry string)) (:apropos (apropos-glossary-entry string)) (otherwise nil))) (DEFMETHOD (glossary-entry-completion :handle-typein-p) (&rest ignore) nil) (DEFMETHOD (glossary-entry-completion :execute) (IGNORE) (FERROR NIL "This mode doesn't execute.")) (DEFPARAMETER glossary-completion (MAKE-INSTANCE 'glossary-entry-completion) "An instance of glossary-entry-completion.") (PUSHNEW 'glossary-completion *glossary-typein-modes*) ;;; ;;; POP UP MESSAGE ;;; (DEFWINDOW-RESOURCE gloss-pop-up-keystrokes-window () :make-window (sugg:pop-up-keystrokes-window :superior *glossary-frame* :reverse-video-p t :font-map (LIST 'fonts:tr12b) :activate-p t) :reusable-when :deactivated :initial-copies 0) (DEFUN gloss-pop-up-and-down-message (message &optional (double-long-p nil)) (USING-RESOURCE (pop-up-message-window gloss-pop-up-keystrokes-window *glossary-frame*) (SEND pop-up-message-window :set-size-in-characters message "a") (tv:expose-window-near pop-up-message-window '(:mouse) nil) (SEND pop-up-message-window :expose) (SEND pop-up-message-window :string-out message) (sugg:leave-window-up-for (if double-long-p 60. 30.) pop-up-message-window)))