;;; -*- Mode:LISP; Package:ZWEI; Fonts:(CPTFONT); Base:10; Readtable:ZL -*- ;;; Copyright (C) Lisp Machine, Inc. 1984, 1985, 1986 ;;; See filename "Copyright" for ;;; licensing and release information. ;;; The basic, relatively static elements out of which Gateway is constructed, ;;; such as global variables, data structures, initialization routines, menus, ;;; tables, and defcoms. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; ;;; ;;; INITIAL DATA FILES ;;; ;;; ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; The initial data node accessed by Gateway. (defconst *INITIAL-GATEWAY-DATA-NODE* `("GATEWAY:DATA;INITIAL-GATEWAY-DATA-NODES.GATE#>" "Welcome to LMI-Gateway" "Welcome to LMI-Gateway")) ;;; The initial script node accessed by Gateway. (defconst *INITIAL-GATEWAY-SCRIPT-NODE* `("GATEWAY:DATA;INITIAL-GATEWAY-SCRIPT-NODES.GATE#>" "Initial LMI-Gateway Script Node" "Initial LMI-Gateway Script Node")) ;;; The initial data node accessed by Guide. (defconst *INITIAL-GUIDE-DATA-NODE* `("GATEWAY:DATA;INTRO-SCRIPT-A.GATE#>" "Welcome to LMI-Guide" "Welcome to LMI-Guide")) ;;; The initial script node accessed by Guide. (defconst *INITIAL-GUIDE-SCRIPT-NODE* `("GATEWAY:DATA;ICAI-FILE-1.GATE#>" "Guide Nodes" "Guide Nodes")) ;;; The initial data node accessed by ODM. (defconst *INITIAL-ODM-DATA-NODE* `("GATEWAY:DATA;INITIAL-ODM-DATA-NODES.GATE#>" "Welcome to LMI-ODM" "Welcome to LMI-ODM")) ;;; The initial script node accessed by ODM. (defconst *INITIAL-ODM-SCRIPT-NODE* `("GATEWAY:DATA;INITIAL-ODM-SCRIPT-NODES.GATE#>" "Initial LMI-ODM Script Node" "Initial LMI-ODM Script Node")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; ;;; ;;; DEFSTRUCTS, FLAVORS, OBJECTS ;;; ;;; ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; A node/script pair derived from a script. There is one for each node in the script. (defstruct (SCRIPT-FRAME :conc-name) (script-name) ;The script from which the frame was derived. (node-name) ;The node to which the frame refers. (next) ;The next node in the linked list of frames for script script-name. (previous)) ;The previous node in the linked list of frames for script script-name. ;;; Stores a node/script pair in a history. This is a script-frame without the links. (defstruct (HISTORY-FRAME :conc-name) (script-name) ;The script to which the frame refers. (node-name)) ;The node to which the frame refers. ;;; Everything known about a node. (defstruct (GNODE :conc-name) (nodename) ;The name of the node. (related-information) ;Whether the node contains related information. (related-information-item-list) ;The related information as a selectable item list. (script) ;Whether the node is a script node. (script-item-list) ;The script entries as a selectable item list. (first-script-frame) ;The first script frame derived from a script node. (index (list nil)) ;Used in index setup. (index-entries) ;The entries in an index. (index-item-list) ;The index entries as a selectable item list. (function) ;An executable form (if any) associated with the node. (sections)) ;A list of the zmacs sections that constitute the node. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; ;;; ;;; GLOBAL VARIABLES ;;; ;;; ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; WARNING: BE SURE ANY NEW GLOBALS ARE REFERENCED AS APPROPRIATE IN ;;; INITIALIZE-GLOBAL-VARIABLES AND MAKE-GATEWAY-CLOSURE. ;;; The list of history frames used by the backtrack command. (defvar *BACKTRACK-LIST* nil) ;;; Memory global used by edit-mode's choose-variable-values menus (defvar *CREATION-SOURCE* nil) ;;; The Gateway application (full Gateway, Guide, or ODM) currently running. (defvar *CURRENT-GATEWAY-APPLICATION* nil) ;;; The buffer holding the node now on display, unless it is a script node in display mode. (defvar *CURRENT-GATEWAY-BUFFER* nil) ;;; The screen configuration (Gateway, Guide, or ODM) currently on display. (defvar *CURRENT-GATEWAY-CONFIGURATION* nil) ;;; The current mode of Gateway action (Display or Edit). (defvar *CURRENT-GATEWAY-MODE* nil) ;;; The title of the node currently on display (second field of its nodename). (defvar *CURRENT-NODE-TITLE* nil) ;;; The script frame for the current node and script. (defvar *CURRENT-SCRIPT-FRAME* nil) ;;; The buffer that holds the default script. (defvar *DEFAULT-SCRIPT-BUFFER* nil) ;;; The nodename of the default script node in the default script buffer. (defvar *DEFAULT-SCRIPT-NODENAME* nil) ;;; The Zmacs closure of the currently running instantiation of Gateway. (defvar *EDITOR-CLOSURE* nil) ;;; Memory global used by edit-mode's choose-variable-values menus (defvar *FILE-TITLE* nil) ;;; The buffer most recently found by gateway-find-file. Used to prevent ;;; time-consuming redundant calls to zwei:find-file-buffer (defvar *GATEWAY-FIND-FILE-BUFFER-BUFFER* nil) ;;; The pathname of the file in *gateway-find-file-buffer-buffer*. Used to prevent ;;; time-consuming redundant calls to zwei:find-file-buffer (defvar *GATEWAY-FIND-FILE-BUFFER-PATHNAME* nil) ;;; T if Gateway mouse-handling (see blink-line) is on; else nil (defvar *GATEWAY-MOUSE-HANDLING-IS-ON* nil) ;;; T if the *current-gateway-buffer* attributes reflect the attribute line of the file. ;;; NIL if they reflect the attribute line of a node within the file. (defvar *GLOBAL-ATTRIBUTE-LINE-PARSED* nil) ;;; The index chosen from the menu of possible indexes. (defvar *INDEX-CHOSEN* nil) ;;; The default index page when no new page is selected. (defvar *INDEX-DEFAULT-PAGE* nil) ;;; The first half of the LISP Machine Manual index. (defvar *INDEX-LMM-1* nil) ;;; The second half of the LISP Machine Manual index. (defvar *INDEX-LMM-2* nil) ;;; The default system index. (defvar *INDEX-SYSTEM* nil) ;;; The default page for the ZMACS reference table. (defvar *INDEX-ZMACS-DEFAULT-PAGE* nil) ;;; The initial script read in at startup. Used by the initial-script command. (defvar *INITIAL-SCRIPT* nil) ;;; Hash table of nodes that have been set up by get-node. ;;; Used to prevent redundant setting-up of nodes being reaccessed. (defvar *NODE-HASH-TABLE* nil) ;;; Memory global used by edit-mode's choose-variable-values menus (defvar *NODE-TITLE* nil) ;;; Memory global used by edit-mode's choose-variable-values menus (defvar *NODE-TYPE* nil) ;;; Used to delete a node being edited from *node-hash-table*, so that it ;;; will be re-set-up by get-node to reflect any changes. (defvar *NODE-NOW-BEING-EDITED* nil) ;;; Hash table of all pathnames that have been created by make-absolute-pathname. Used to ;;; prevent redundant calls to parse-pathname. (defvar *PATHNAME-HASH-TABLE* nil) ;;; Used by section-p/get-section-name to include a per-node attribute line in the node, ;;; even though it appears prior to the nodes :defun-line. (defvar *PEEKED-SECTION-P-NODE-TITLE* nil) ;;; Buffer to hold a node that has been formatted for printing. (defvar *PRINT-NODE-BUFFER* nil) ;;; Hash table used to keep track of whether a buffer must be resectionized ;;; before it can be displayed. Prevents redundant resectionizations during editing. (defvar *RESECTIONIZE-P-HASH-TABLE* nil) ;;; Buffer to hold a formatted script in display mode. (defvar *SCRIPT-DISPLAY-BUFFER* nil) ;;; Pointer to the zmacs section that holds the lines that were reformatted ;;; to produce the lines in *script-display-buffer*. Used to equate a formatted ;;; script line to an unformatted line (containing file information) when a choice ;;; from a script has been made. (defvar *SCRIPT-SOURCE-SECTION* nil) ;;; The title derived by section-p/get-section-name for use in naming the sections of a node. ;;; Suffixes are added to it to produce the particular section names. (defvar *SECTION-TITLE* nil) ;;; The command that is to be executed because a selection ;;; was taken from a popup command menu. (defvar *SELECTED-COMMAND* nil) ;;; A node chosen for display from a full-history, current-script, or tutorial pane. (defvar *SELECTED-NODE* nil) ;;; The type of terminal (landscape or portrait) on which Gateway is running. (defvar *TERMINAL-TYPE* nil) ;;; List of all data nodes that have been displayed. (defvar *TOP-DATA-NODE-HISTORY-LIST* nil) ;;; List of all nodes that have been edited. (defvar *TOP-EDITING-HISTORY-LIST* nil) ;;; List of all script nodes that have been displayed. (defvar *TOP-FULL-HISTORY-LIST* nil) ;;; List of all nodes on which a node mark has been made. (defvar *TOP-NODE-MARK-LIST* nil) ;;; List of all script nodes that have been displayed. (defvar *TOP-SCRIPT-HISTORY-LIST* nil) ;;; Used for holding cross-reference information in script-like form. (defvar *XREF-DISPLAY-BUFFER* nil) ;;; Hash table linking nodes to their default scripts. (defvar *NODE-SCRIPT-HASH-TABLE* nil) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; ;;; ;;; INITIALIZATION ROUTINES ;;; ;;; ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; INITIALIZE-GLOBAL-VARIABLES ;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Initializes most global variables, directly or by calling an initialization routine. (defun INITIALIZE-GLOBAL-VARIABLES () (setq *backtrack-list* nil *creation-source* *top-full-history-list* ; *current-gateway-application* is initialized via the system key evoking the program. *current-gateway-buffer* nil ; *current-gateway-configuration* is initialized via the system key evoking the program. *current-gateway-mode* 'display-mode *current-node-title* "NODE UNSPECIFIED" *current-script-frame* (make-script-frame) ; *default-script-buffer* is initialized in the startup sequence ; by establish-default-script-buffer. ; *default-script-nodename* is initialized in the startup sequence ; by establish-default-script-buffer. *editor-closure* nil *file-title* nil *gateway-find-file-buffer-buffer* nil *gateway-find-file-buffer-pathname* nil *gateway-mouse-handling-is-on* nil *global-attribute-line-parsed* nil *index-chosen* nil *index-default-page* (initialize-index-default-page) *index-lmm-1* (initialize-index-lmm-1) *index-lmm-2* (initialize-index-lmm-2) *index-system* (initialize-index-system) *index-zmacs-default-page* (initialize-index-zmacs-default-page) *initial-script* nil *node-hash-table* (make-equal-hash-table) *node-now-being-edited* nil *node-title* nil *node-type* "=Text:" *pathname-hash-table* (make-equal-hash-table) *peeked-section-p-node-title* nil *print-node-buffer* (initialize-print-node-buffer) *resectionize-p-hash-table* (make-equal-hash-table) *script-display-buffer* (initialize-script-display-buffer) *script-source-section* nil *section-title* nil *selected-command* nil ; *terminal-type* is initialized in the individual META-X-ENTRY-TO-GATEWAY commands *top-data-node-history-list* (list (list "DATA NODE HISTORY" :no-select nil :font fonts:bigfnt)) *top-editing-history-list* (list (list "EDITING HISTORY" :no-select nil :font fonts:bigfnt)) *top-full-history-list* (list (list "FULL HISTORY" :no-select nil :font fonts:bigfnt)) *top-node-mark-list* (list (list "NODE MARKS" :no-select nil :font fonts:bigfnt)) *top-script-history-list* (list (list "SCRIPT NODE HISTORY" :no-select nil :font fonts:bigfnt)) *xref-display-buffer* "gateway:data;xref-display-buffer.gate#>" ; *node-script-hash-table* is initialized when ODM is built at LMI. It can be modified ; temporarily as with any hash table, or permanently via ; Patch Files. )) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; MAKE-GATEWAY-CLOSURE ;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; This inserts the GATEWAY-specific global variables into the closure (*EDITOR*) ;;; of the Zmacs process associated with a GATEWAY instantiation. The values ;;; established for the globals by INITIALIZE-GLOBAL-VARIABLES become the ;;; initial values within the closure. (defun make-gateway-closure () (mapcar #'(lambda (gvar) (sys:insert-binding-in-closure *editor* gvar '*editor*)) '( *backtrack-list* *creation-source* *current-gateway-application* *current-gateway-buffer* *current-gateway-configuration* *current-gateway-mode* *current-node-title* *current-script-frame* *default-script-buffer* *default-script-nodename* ; *editor-closure* *file-title* *gateway-find-file-buffer-buffer* *gateway-find-file-buffer-pathname* ; *gateway-mouse-handling-is-on* *global-attribute-line-parsed* *index-chosen* *index-default-page* ; *index-lmm-1* ; *index-lmm-2* ; *index-system* *index-zmacs-default-page* *initial-script* ; *node-hash-table* *node-title* *node-type* *node-now-being-edited* ; *pathname-hash-table* *peeked-section-p-node-title* *print-node-buffer* ; *resectionize-p-hash-table* *script-display-buffer* *script-source-section* *section-title* *selected-command* *selected-node* *terminal-type* *top-data-node-history-list* *top-editing-history-list* *top-full-history-list* *top-node-mark-list* *top-script-history-list* *xref-display-buffer* *gateway-constraint-frame* *herald-pane* *full-history-pane* *current-script-pane* *current-tutorial-pane* *command-pane* *guide-command-pane* *display-pane-1* *display-pane-2* *lisp-listener-pane* ))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; INITIALIZE-INDEX-SYSTEM ;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Temporary kludge that sets up a menu for indexing. Should be replaced by nodes. (defun INITIALIZE-INDEX-SYSTEM () (list (list "SYSTEM INDEXES CURRENTLY AVAILABLE" :no-select nil :font fonts:CPTFONTb) (list " " :no-select nil) (list "LISP MACHINE MANUAL: 1+$ FUNCTION - TO - HANDLING ERRORS" :value "lmm-1" :font fonts:CPTFONT) (list "LISP MACHINE MANUAL: Hash TABLES - TO - ZUNDERFLOW" :value "lmm-2" :font fonts:CPTFONT))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; INITIALIZE-INDEX-LMM-1 ;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Temporary kludge that sets up a menu for indexing. Should be replaced by nodes. (defun INITIALIZE-INDEX-LMM-1 () (list (list "LISP MACHINE MANUAL INDEX" :no-select nil :font fonts:hl10b) (list "1+$ FUNCTION - TO - HANDLING ERRORS" :no-select nil :font fonts:hl10b) (list "CHOOSE A RANGE TO GET AN INDEX PAGE" :no-select nil :font fonts:hl10b) (list " " :no-select nil) (list "1+$ function TO `&'keywords " :value '("GATEWAY:DATA;INDEX-LMM-01.GATE#>" "1+$ function - TO - `&' keywords" "1+$ function - TO - `&' keywords") :font fonts:hl10) (list "Abs function TO Array, Maclisp " :value '("GATEWAY:DATA;INDEX-LMM-01.GATE#>" "Abs function - TO - Array, Maclisp" "Abs function - TO - Array, Maclisp") :font fonts:hl10) (list "Array, pointer TO Art-special-pdl " :value '("GATEWAY:DATA;INDEX-LMM-01.GATE#>" "Array, pointer - TO - Art-special-pdl" "Array, pointer - TO - Art-special-pdl") :font fonts:hl10) (list "Art-stack-group-head TO Bit-xor function " :value '("GATEWAY:DATA;INDEX-LMM-02.GATE#>" "Art-stack-group-head - TO - Bit-xor function" "Art-stack-group-head - TO - Bit-xor function") :font fonts:hl10) (list "Bitblt function TO Cdr-safe function " :value '("GATEWAY:DATA;INDEX-LMM-02.GATE#>" "Bitblt function - TO - Cdr-safe function" "Bitblt function - TO - Cdr-safe function") :font fonts:hl10) (list "Cdr TO Common Lisp syntax " :value '("GATEWAY:DATA;INDEX-LMM-02.GATE#>" "Cdr - TO - Common Lisp syntax" "Cdr - TO - Common Lisp syntax") :font fonts:hl10) (list "Common Lisp, packages TO Conditions, fs:no-more-room " :value '("GATEWAY:DATA;INDEX-LMM-03.GATE#>" "Common Lisp, packages - TO - Conditions, fs:no-more-room" "Common Lisp, packages - TO - Conditions, fs:no-more-room") :font fonts:hl10) (list "Conditions, fs:not-available TO Conditions, sys:unknown-address " :value '("GATEWAY:DATA;INDEX-LMM-03.GATE#>" "Conditions, fs:not-available - TO - Conditions, sys:unknown-address" "Conditions, fs:not-available - TO - Conditions, sys:unknown-address") :font fonts:hl10) (list "Conditions, sys:unknown-host-name TO Data types " :value '("GATEWAY:DATA;INDEX-LMM-03.GATE#>" "Conditions, sys:unknown-host-name - TO - Data types" "Conditions, sys:unknown-host-name - TO - Data types") :font fonts:hl10) (list "Data types, user defined TO Directory (pathname) " :value '("GATEWAY:DATA;INDEX-LMM-04.GATE#>" "Data types, user defined - TO - Directory (pathname)" "Data types, user defined - TO - Directory (pathname)") :font fonts:hl10) (list "Disassemble TO Encapsulation " :value '("GATEWAY:DATA;INDEX-LMM-04.GATE#>" "Disassemble - TO - Encapsulation" "Disassemble - TO - Encapsulation") :font fonts:hl10) (list "End of list TO File servers " :value '("GATEWAY:DATA;INDEX-LMM-04.GATE#>" "End of list - TO - File servers" "End of list - TO - File servers") :font fonts:hl10) (list "File stream operations TO Flavors, si:input-pointer-remembering-mixin " :value '("GATEWAY:DATA;INDEX-LMM-05.GATE#>" "File stream operations - TO - Flavors, si:input-pointer-remembering-mixin" "File stream operations - TO - Flavors, si:input-pointer-remembering-mixin") :font fonts:hl10) (list "Flavors, si:input-stream TO Function entry frame " :value '("GATEWAY:DATA;INDEX-LMM-05.GATE#>" "Flavors, si:input-stream - TO - Function entry frame" "Flavors, si:input-stream - TO - Function entry frame") :font fonts:hl10) (list "Function execution TO Functions, % pointerp " :value '("GATEWAY:DATA;INDEX-LMM-05.GATE#>" "Function execution - TO - Functions, % pointerp" "Function execution - TO - Functions, % pointerp") :font fonts:hl10) (list "Functions, %pointer TO Functions, array-displaced-p " :value '("GATEWAY:DATA;INDEX-LMM-06.GATE#>" "Functions, %pointer - TO - Functions, array-displaced-p" "Functions, %pointer - TO - Functions, array-displaced-p") :font fonts:hl10) (list "Functions, array-element-size TO Functions, caaadr " :value '("GATEWAY:DATA;INDEX-LMM-06.GATE#>" "Functions, array-element-size - TO - Functions, caaadr" "Functions, array-element-size - TO - Functions, caaadr") :font fonts:hl10) (list "Functions, caaar TO Functions, chaos:host-data " :value '("GATEWAY:DATA;INDEX-LMM-06.GATE#>" "Functions, caaar - TO - Functions, chaos:host-data" "Functions, caaar - TO - Functions, chaos:host-data") :font fonts:hl10) (list "Functions, chaos:host-up-p TO Functions, commonp " :value '("GATEWAY:DATA;INDEX-LMM-07.GATE#>" "Functions, chaos:host-up-p - TO - Functions, commonp" "Functions, chaos:host-up-p - TO - Functions, commonp") :font fonts:hl10) (list "Functions, compile-encapsulations TO Functions, define-loop-macro " :value '("GATEWAY:DATA;INDEX-LMM-07.GATE#>" "Functions, compile-encapsulations - TO - Functions, define-loop-macro" "Functions, compile-encapsulations - TO - Functions, define-loop-macro") :font fonts:hl10) (list "Functions, define-loop-path TO Functions, ed " :value '("GATEWAY:DATA;INDEX-LMM-07.GATE#>" "Functions, define-loop-path - TO - Functions, ed" "Functions, define-loop-path - TO - Functions, ed") :font fonts:hl10) (list "Functions, eh:arg-name TO Functions, file-write-date " :value '("GATEWAY:DATA;INDEX-LMM-08.GATE#>" "Functions, eh:arg-name - TO - Functions, file-write-date" "Functions, eh:arg-name - TO - Functions, file-write-date") :font fonts:hl10) (list "Functions, fill-pointer TO Functions, fs:pathname-plist " :value '("GATEWAY:DATA;INDEX-LMM-08.GATE#>" "Functions, fill-pointer - TO - Functions, fs:pathname-plist" "Functions, fill-pointer - TO - Functions, fs:pathname-plist") :font fonts:hl10) (list "Functions, fs:read-attribute-list TO Functions, import " :value '("GATEWAY:DATA;INDEX-LMM-08.GATE#>" "Functions, fs:read-attribute-list - TO - Functions, import" "Functions, fs:read-attribute-list - TO - Functions, import") :font fonts:hl10) (list "Functions, in-package TO Functions, logeqv " :value '("GATEWAY:DATA;INDEX-LMM-09.GATE#>" "Functions, in-package - TO - Functions, logeqv" "Functions, in-package - TO - Functions, logeqv") :font fonts:hl10) (list "Functions, login-eval TO Functions, math:invert-matrix " :value '("GATEWAY:DATA;INDEX-LMM-09.GATE#>" "Functions, login-eval - TO - Functions, math:invert-matrix" "Functions, login-eval - TO - Functions, math:invert-matrix") :font fonts:hl10) (list "Functions, math:list-2d-array TO Functions, package-shadowing-symbols " :value '("GATEWAY:DATA;INDEX-LMM-09.GATE#>" "Functions, math:list-2d-array - TO - Functions, package-shadowing-symbols" "Functions, math:list-2d-array - TO - Functions, package-shadowing-symbols") :font fonts:hl10) (list "Functions, package-use-list TO Functions, progn " :value '("GATEWAY:DATA;INDEX-LMM-10.GATE#>" "Functions, package-use-list - TO - Functions, progn" "Functions, package-use-list - TO - Functions, progn") :font fonts:hl10) (list "Functions, progv TO Functions, rotatef " :value '("GATEWAY:DATA;INDEX-LMM-10.GATE#>" "Functions, progv - TO - Functions, rotatef" "Functions, progv - TO - Functions, rotatef") :font fonts:hl10) (list "Functions, rot TO Functions, si:lisp-top-level1 " :value '("GATEWAY:DATA;INDEX-LMM-10.GATE#>" "Functions, rot - TO - Functions, si:lisp-top-level1" "Functions, rot - TO - Functions, si:lisp-top-level1") :font fonts:hl10) (list "Functions, si:lisp-top-level TO Functions, store " :value '("GATEWAY:DATA;INDEX-LMM-11.GATE#>" "Functions, si:lisp-top-level - TO - Functions, store" "Functions, si:lisp-top-level - TO - Functions, store") :font fonts:hl10) (list "Functions, stream-copy-until-eof TO Functions, tanh " :value '("GATEWAY:DATA;INDEX-LMM-11.GATE#>" "Functions, stream-copy-until-eof - TO - Functions, tanh" "Functions, stream-copy-until-eof - TO - Functions, tanh") :font fonts:hl10) (list "Functions, tan TO Functions, vector-pop " :value '("GATEWAY:DATA;INDEX-LMM-11.GATE#>" "Functions, tan - TO - Functions, vector-pop" "Functions, tan - TO - Functions, vector-pop") :font fonts:hl10) (list "Functions, vector-push-extend TO Handling errors " :value '("GATEWAY:DATA;INDEX-LMM-11.GATE#>" "Functions, vector-push-extend - TO - Handling errors" "Functions, vector-push-extend - TO - Handling errors") :font fonts:hl10))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; INITIALIZE-INDEX-LMM-2 ;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Temporary kludge that sets up a menu for indexing. Should be replaced by nodes. (defun INITIALIZE-INDEX-LMM-2 () (list (list "LISP MACHINE MANUAL INDEX" :no-select nil :font fonts:hl10b) (list "HASH TABLES - TO - ZUNDERFLOW" :no-select nil :font fonts:hl10b) (list "CHOOSE A RANGE TO GET AN INDEX PAGE" :no-select nil :font fonts:hl10b) (list " " :no-select nil) (list "Hash table operations TO Integer data type " :value '("GATEWAY:DATA;INDEX-LMM-12.GATE#>" "Hash table operations - TO - Integer data type" "Hash table operations - TO - Integer data type") :font fonts:hl10) (list "Integer division TO Keywords, :compare-function " :value '("GATEWAY:DATA;INDEX-LMM-12.GATE#>" "Integer division - TO - Keywords, :compare-function" "Integer division - TO - Keywords, :compare-function") :font fonts:hl10) (list "Keywords, :compile TO Keywords, :french " :value '("GATEWAY:DATA;INDEX-LMM-12.GATE#>" "Keywords, :compile - TO - Keywords, :french" "Keywords, :compile - TO - Keywords, :french") :font fonts:hl10) (list "Keywords, :fresh-line TO Keywords, :no-action " :value '("GATEWAY:DATA;INDEX-LMM-13.GATE#>" "Keywords, :fresh-line - TO - Keywords, :no-action" "Keywords, :fresh-line - TO - Keywords, :no-action") :font fonts:hl10) (list "Keywords, :no-increment-patch TO Keywords, :restart-after-reset " :value '("GATEWAY:DATA;INDEX-LMM-13.GATE#>" "Keywords, :no-increment-patch - TO - Keywords, :restart-after-reset" "Keywords, :no-increment-patch - TO - Keywords, :restart-after-reset") :font fonts:hl10) (list "Keywords, :retry TO Keywords, :wherein " :value '("GATEWAY:DATA;INDEX-LMM-13.GATE#>" "Keywords, :retry - TO - Keywords, :wherein" "Keywords, :retry - TO - Keywords, :wherein") :font fonts:hl10) (list "Keywords, :width TO Lexical scoping " :value '("GATEWAY:DATA;INDEX-LMM-14.GATE#>" "Keywords, :width - TO - Lexical scoping" "Keywords, :width - TO - Lexical scoping") :font fonts:hl10) (list "Lexical variable bindings TO Logbitp function " :value '("GATEWAY:DATA;INDEX-LMM-14.GATE#>" "Lexical variable bindings - TO - Logbitp function" "Lexical variable bindings - TO - Logbitp function") :font fonts:hl10) (list "Logcount function TO Macros, name conflicts " :value '("GATEWAY:DATA;INDEX-LMM-14.GATE#>" "Logcount function - TO - Macros, name conflicts" "Logcount function - TO - Macros, name conflicts") :font fonts:hl10) (list "Macros, nesting TO Messages, :clear-hash " :value '("GATEWAY:DATA;INDEX-LMM-15.GATE#>" "Macros, nesting - TO - Messages, :clear-hash" "Macros, nesting - TO - Messages, :clear-hash") :font fonts:hl10) (list "Messages, :clear-input TO Messages, :modify-hash " :value '("GATEWAY:DATA;INDEX-LMM-15.GATE#>" "Messages, :clear-input - TO - Messages, :modify-hash" "Messages, :clear-input - TO - Messages, :modify-hash") :font fonts:hl10) (list "Messages, :name TO Messages, :rewind " :value '("GATEWAY:DATA;INDEX-LMM-15.GATE#>" "Messages, :name - TO - Messages, :rewind" "Messages, :name - TO - Messages, :rewind") :font fonts:hl10) (list "Messages, :rubout-handler TO Message handling " :value '("GATEWAY:DATA;INDEX-LMM-16.GATE#>" "Messages, :rubout-handler - TO - Message handling" "Messages, :rubout-handler - TO - Message handling") :font fonts:hl10) (list "Meters, sys:%aging-depth TO Name spaces " :value '("GATEWAY:DATA;INDEX-LMM-16.GATE#>" "Meters, sys:%aging-depth - TO - Name spaces" "Meters, sys:%aging-depth - TO - Name spaces") :font fonts:hl10) (list "Name spaces, inheritance between TO Objects, conceptual " :value '("GATEWAY:DATA;INDEX-LMM-16.GATE#>" "Name spaces, inheritance between - TO - Objects, conceptual" "Name spaces, inheritance between - TO - Objects, conceptual") :font fonts:hl10) (list "Objects, Lisp TO Pathnames, defaults and merging " :value '("GATEWAY:DATA;INDEX-LMM-17.GATE#>" "Objects, Lisp - TO - Pathnames, defaults and merging" "Objects, Lisp - TO - Pathnames, defaults and merging") :font fonts:hl10) (list "Pathnames, definition of TO Proclaim function " :value '("GATEWAY:DATA;INDEX-LMM-17.GATE#>" "Pathnames, definition of - TO - Proclaim function" "Pathnames, definition of - TO - Proclaim function") :font fonts:hl10) (list "Prog special form TO Rational data type " :value '("GATEWAY:DATA;INDEX-LMM-17.GATE#>" "Prog special form - TO - Rational data type" "Prog special form - TO - Rational data type") :font fonts:hl10) (list "Rational function TO Rubout handler " :value '("GATEWAY:DATA;INDEX-LMM-18.GATE#>" "Rational function - TO - Rubout handler" "Rational function - TO - Rubout handler") :font fonts:hl10) (list "Run reason TO Si:change-indirect-array " :value '("GATEWAY:DATA;INDEX-LMM-18.GATE#>" "Run reason - TO - Si:change-indirect-array" "Run reason - TO - Si:change-indirect-array") :font fonts:hl10) (list "Si:dump-warnings TO Stack group, regular PDL as component of " :value '("GATEWAY:DATA;INDEX-LMM-18.GATE#>" "Si:dump-warnings - TO - Stack group, regular PDL as component of" "Si:dump-warnings - TO - Stack group, regular PDL as component of") :font fonts:hl10) (list "Stack groups, an example TO Structures, named " :value '("GATEWAY:DATA;INDEX-LMM-18.GATE#>" "Stack groups, an example - TO - Structures, named" "Stack groups, an example - TO - Structures, named") :font fonts:hl10) (list "Structures, usage TO Sys:throw-tag-not-seen " :value '("GATEWAY:DATA;INDEX-LMM-19.GATE#>" "Structures, usage - TO - Sys:throw-tag-not-seen" "Structures, usage - TO - Sys:throw-tag-not-seen") :font fonts:hl10) (list "Sys:too-few-arguments TO Transformations " :value '("GATEWAY:DATA;INDEX-LMM-19.GATE#>" "Sys:too-few-arguments - TO - Transformations" "Sys:too-few-arguments - TO - Transformations") :font fonts:hl10) (list "Transpose-matrix TO Variables, %%q-all-but-typed-pointer " :value '("GATEWAY:DATA;INDEX-LMM-19.GATE#>" "Transpose-matrix - TO - Variables, %%q-all-but-typed-pointer" "Transpose-matrix - TO - Variables, %%q-all-but-typed-pointer") :font fonts:hl10) (list "Variables, %%q-cdr-code TO Variables, art-stack-group-head " :value '("GATEWAY:DATA;INDEX-LMM-20.GATE#>" "Variables, %%q-cdr-code - TO - Variables, art-stack-group-head" "Variables, %%q-cdr-code - TO - Variables, art-stack-group-head") :font fonts:hl10) (list "Variables, art-string TO Variables, dtp-trap " :value '("GATEWAY:DATA;INDEX-LMM-20.GATE#>" "Variables, art-string - TO - Variables, dtp-trap" "Variables, art-string - TO - Variables, dtp-trap") :font fonts:hl10) (list "Variables, dtp-u-entry TO Variables, room " :value '("GATEWAY:DATA;INDEX-LMM-20.GATE#>" "Variables, dtp-u-entry - TO - Variables, room" "Variables, dtp-u-entry - TO - Variables, room") :font fonts:hl10) (list "Variables, rubout-handler TO Variables, sys:amem-evcp-vector " :value '("GATEWAY:DATA;INDEX-LMM-21 .GATE#>" "Variables, rubout-handler - TO - Variables, sys:amem-evcp-vector" "Variables, rubout-handler - TO - Variables, sys:amem-evcp-vector") :font fonts:hl10) (list "Variables, sys:array-index-order TO Zunderflow variable " :value '("GATEWAY:DATA;INDEX-LMM-21.GATE#>" "Variables, sys:array-index-order - TO - Zunderflow variable" "Variables, sys:array-index-order - TO - Zunderflow variable") :font fonts:hl10))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; INITIALIZE-INDEX-DEFAULT-PAGE ;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Hardwired nodename that should be replaced by a routine to dynamically set up the default (defun INITIALIZE-INDEX-DEFAULT-PAGE () '("GATEWAY:DATA;INDEX-LMM-01.GATE#>" "1+$ function - TO - `&' keywords" "1+$ function - TO - `&' keywords")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; INITIALIZE-INDEX-ZMACS-DEFAULT-PAGE ;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Hardwired nodename that should be replaced by a routine to dynamically set up the default (defun INITIALIZE-INDEX-ZMACS-DEFAULT-PAGE () '("GATEWAY:DATA;INDEX-ZMACS-01.GATE#>")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; INITIALIZE-PRINT-NODE-BUFFER ;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Create a zmacs buffer for printing nodes. (defun INITIALIZE-PRINT-NODE-BUFFER () (create-one-buffer-to-go (string-append "PRINT-NODE-" (generate-buffer-name) ".GATE#>"))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; INITIALIZE-SCRIPT-DISPLAY-BUFFER ;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Create a zmacs buffer for displaying scripts. (defun INITIALIZE-SCRIPT-DISPLAY-BUFFER () (create-one-buffer-to-go (string-append "SCRIPT-DISPLAY-" (generate-buffer-name) ".GATE#>"))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; GET-TERMINAL-TYPE ;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Determine (somewhat heuristically) whether we are on a landscape or portrait terminal. (defun GET-TERMINAL-TYPE () (if (> (send tv:main-screen :size) 900) 'landscape 'portrait)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; ;;; ;;; CONSTRAINT-FRAME SHADOW BORDERS ;;; ;;; ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; These routines draw the various shadow borders used by the panes in ;;; the Gateway constraint frame. (defconst *SHADOW-WIDTH* 10) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; DRAW-LEFT-SHADOW-BORDER ;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defprop DRAW-LEFT-SHADOW-BORDER 10 tv:default-border-size) (defun DRAW-LEFT-SHADOW-BORDER (window alu left top right bottom) (let ((width (- right left)) (height (- bottom top)) ) (tv:%draw-rectangle 1 ;width (- height width) ;height (- width 1) ;x 0 ;y alu window) (draw-gray-rectangle (- width 5) ;width (- height width) ;height 5 (- width 5) tv:alu-ior window :gray 50))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; DRAW-LEFT-SHADOW-BORDER-PLUS ;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defprop DRAW-LEFT-SHADOW-BORDER-PLUS 10 tv:default-border-size) (defun DRAW-LEFT-SHADOW-BORDER-PLUS (window alu left top right bottom) (let ((width (- right left)) (height (- bottom top)) ) (tv:%draw-rectangle 1 ;width (- height width 5) ;height (- width 1) ;x 5 ;y alu window) (draw-gray-rectangle (- width 5) ;width (- height width 5) ;height 5 width tv:alu-ior window :gray 50))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; DRAW-RIGHT-SHADOW-BORDER ;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defprop DRAW-RIGHT-SHADOW-BORDER 1 tv:default-border-size) (defun DRAW-RIGHT-SHADOW-BORDER (window alu left top right bottom) (let ((width (- right left)) (height (- bottom top)) ) (tv:%draw-rectangle width ;width (- height *shadow-width*) ;height left ;x top ;y alu window) )) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; DRAW-RIGHT-SHADOW-BORDER-PLUS ;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defprop DRAW-RIGHT-SHADOW-BORDER-PLUS 6 tv:default-border-size) (defun DRAW-RIGHT-SHADOW-BORDER-PLUS (window alu left top ignore bottom) (let ((height (- bottom top)) ) (tv:%draw-rectangle 1 ;width (- height *shadow-width*) ;height left ;x top ;y alu window) )) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; DRAW-TOP-SHADOW-BORDER ;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defprop DRAW-TOP-SHADOW-BORDER 1 tv:default-border-size) (defun DRAW-TOP-SHADOW-BORDER (window alu left top right ignore) (let ((width (- right left))) ; (tv:%draw-rectangle (- width 5) ;width 1 ;height left ;x top ;y alu window) )) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; DRAW-TOP-SHADOW-BORDER-PLUS ;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defprop DRAW-TOP-SHADOW-BORDER-PLUS 6 tv:default-border-size) (defun DRAW-TOP-SHADOW-BORDER-PLUS (window alu left ignore right bottom) (let ((width (- right left))) ; (tv:%draw-rectangle (- width 5) ;width 1 ;height left ;x (- bottom 1) ;y alu window) )) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; DRAW-BOTTOM-SHADOW-BORDER ;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defprop DRAW-BOTTOM-SHADOW-BORDER 10 tv:default-border-size) (defun DRAW-BOTTOM-SHADOW-BORDER (window alu left top right bottom) (let ((width (- right left)) ; (height (- bottom top)) ) (tv:%draw-rectangle width ;width 1 ;height left ;x top ;y alu window) (draw-gray-rectangle (- width height -5) ;width (- height 5) ;height left ;x top ;y tv:alu-ior window :gray 50) )) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; DRAW-50%-GRAY-RECTANGULAR-BORDER ;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defprop DRAW-50%-GRAY-RECTANGULAR-BORDER 10 tv:default-border-size) (defun DRAW-50%-GRAY-RECTANGULAR-BORDER (window ignore left top right bottom) (draw-gray-rectangle (- right left) ;width (- bottom top) ;height left top tv:alu-ior window :gray 50)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; DRAW-GRAY-RECTANGLE ;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun DRAW-GRAY-RECTANGLE (width height x y alu window &optional &key (gray 50)) (let ((gray-array (selectq gray (12 tv:12%-gray) (25 tv:25%-gray) (33 tv:33%-gray) (50 tv:50%-gray) (75 tv:75%-gray) (t tv:50%-gray)))) (bitblt ;operation alu ;alu width ;width height ;height gray-array ;from-array 0 0 ;from-x, from-y (send window :screen-array) ;to-array x y))) ;to-x , to-y ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; ;;; ;;; CONSTRAINT FRAME ;;; ;;; ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; GLOBAL CONSTANTS FOR REFERRING TO CONSTRAINT FRAME PANES ;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defvar *GATEWAY-CONSTRAINT-FRAME* nil "THE LMI INFORMATION MANAGEMENT SYSTEM FRAME") (defvar *HERALD-PANE* nil "USED FOR HERALD DISPLAY") (defvar *FULL-HISTORY-PANE* nil "USED FOR FULL HISTORY DISPLAY") (defvar *CURRENT-SCRIPT-PANE* nil "USED FOR CURRENT SCRIPT DISPLAY") (defvar *CURRENT-TUTORIAL-PANE* nil "USED FOR CURRENT SCRIPT DISPLAY") (defvar *COMMAND-PANE* nil "HOLDS THE COMMAND MENU") (defvar *GUIDE-COMMAND-PANE* nil "HOLDS THE GUIDE COMMAND MENU") (defvar *DISPLAY-PANE-1* nil "USED FOR INFORMATION DISPLAY") (defvar *DISPLAY-PANE-2* nil "USED FOR INFORMATION DISPLAY") (defvar *LISP-LISTENER-PANE* nil "USED FOR LISTENER INTERACTION") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; GATEWAY-COMMAND-MENU-MIXIN ;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; A dummy mixin used to include the (GATEWAY-COMMAND-MENU-MIXIN :AFTER :MOUSE-BUTTONS) ;;; method in GATEWAY-COMMAND-MENU. (defflavor GATEWAY-COMMAND-MENU-MIXIN (io-buffer) () (:required-flavors tv:basic-menu) (:settable-instance-variables io-buffer)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; (GATEWAY-COMMAND-MENU-MIXIN :AFTER :MOUSE-BUTTONS) ;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; This method provides the link between the mouse process that creates blips when ;;; a Gateway Command Menu item is chosen, and the Zmacs process (running as part of Gateway) ;;; that executes them. It takes the blip produced by the mouse process, extracts the ;;; Gateway command it contains (the car of its third), and tells Zmacs what to do by ;;; putting the command into the Zmacs io buffer. Without this method, Zmacs would get ;;; the whole blip, which it could not interpret. A special case occurs when the command ;;; will cause a popup to be displayed from which a second command will be selected. In ;;; this case, the routine that will display the popup is given in the cdr of the blip's ;;; third. It is saved, and the car of the third is a command directing the routine in ;;; the saved location to be funcalled. (defmethod (GATEWAY-COMMAND-MENU-MIXIN :AFTER :MOUSE-BUTTONS) (ignore ignore ignore) (let ((blip tv:chosen-item)) (when (typep (third blip) 'cons) (set-in-closure *editor-closure* '*selected-command* (cdr (third tv:chosen-item))) (tv:io-buffer-put (send *display-pane-1* :io-buffer) (car (third tv:chosen-item)))) (setq tv:chosen-item nil))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; GATEWAY-COMMAND-MENU ;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; TV:MENU with the mixin that provides the ;;; (GATEWAY-COMMAND-MENU-MIXIN :AFTER :MOUSE-BUTTONS) ;;; method in place of the (TV:MENU :AFTER :MOUSE-BUTTONS) method. (defflavor GATEWAY-COMMAND-MENU () (gateway-command-menu-mixin tv:menu)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; GATEWAY-CONSTRAINT-FRAME ;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; The constraint frame for Gateway. It has three configurations: Landscape, ;;; Portrait, and Guide (a special case of Landscape). Except for the :borders ;;; properties, it is an adaptation of code produced by the Window Maker. (defflavor GATEWAY-CONSTRAINT-FRAME () (tv:alias-for-inferiors-mixin tv:inferiors-not-in-select-menu-mixin tv:constraint-frame ) (:default-init-plist :panes '( (herald-pane gateway-command-menu :borders (draw-left-shadow-border-plus draw-top-shadow-border-plus draw-right-shadow-border-plus draw-bottom-shadow-border ) :deexposed-typein-action :normal :deexposed-typeout-action :normal :label nil :item-list (("" :no-select nil)) :save-bits t) (full-history-pane gateway-command-menu :borders (draw-left-shadow-border-plus draw-top-shadow-border-plus draw-right-shadow-border-plus draw-bottom-shadow-border ) :deexposed-typein-action :normal :deexposed-typeout-action :normal :columns 1 :label nil :item-list (("" :no-select nil)) :save-bits t) (current-script-pane gateway-command-menu :borders (draw-left-shadow-border-plus draw-top-shadow-border-plus draw-right-shadow-border-plus draw-bottom-shadow-border ) :deexposed-typein-action :normal :deexposed-typeout-action :normal :columns 1 :rows 5 :label nil :item-list (("" :no-select nil)) :save-bits t) (current-tutorial-pane gateway-command-menu :borders (draw-left-shadow-border-plus draw-top-shadow-border-plus draw-right-shadow-border-plus draw-bottom-shadow-border ) :deexposed-typein-action :normal :deexposed-typeout-action :normal :columns 3 :rows 5 :label nil :item-list (("" :no-select nil)) :save-bits t) (command-pane gateway-command-menu :borders (draw-left-shadow-border draw-top-shadow-border draw-right-shadow-border-plus draw-bottom-shadow-border ) :deexposed-typein-action :normal :deexposed-typeout-action :normal :label nil :save-bits t :item-list (("" :no-select nil))) (guide-command-pane gateway-command-menu :borders (draw-left-shadow-border-plus draw-top-shadow-border-plus draw-right-shadow-border-plus draw-bottom-shadow-border ) :deexposed-typein-action :normal :deexposed-typeout-action :normal :label nil :item-list (("" :no-select nil)) :save-bits t) (display-pane-1 zmacs-frame :borders (draw-left-shadow-border t draw-right-shadow-border draw-bottom-shadow-border ) :blinker-deselected-visibility :blink :blinker-flavor tv:rectangular-blinker :blinker-p nil :deexposed-typein-action :normal :deexposed-typeout-action :normal :save-bits t) (display-pane-2 zmacs-frame :borders (draw-left-shadow-border t draw-right-shadow-border draw-bottom-shadow-border ) :blinker-deselected-visibility :blink :blinker-flavor tv:rectangular-blinker :blinker-p nil :deexposed-typein-action :normal :deexposed-typeout-action :normal :save-bits t) (lisp-listener-pane tv:lisp-listener :borders (draw-left-shadow-border t draw-right-shadow-border draw-bottom-shadow-border ) :blinker-deselected-visibility :on :blinker-flavor tv:rectangular-blinker :blinker-p t :deexposed-typein-action :normal :deexposed-typeout-action :normal :label t :save-bits t)) :constraints '((landscape-configuration (landscape-1 landscape-2) ((landscape-1 :horizontal (0.127s0) (full-history-pane current-script-pane herald-pane) ((full-history-pane 0.335968s0) (current-script-pane 0.340908s0)) ((herald-pane :even)))) ((landscape-2 :horizontal (:even) (display-pane-1 command-pane) ((display-pane-1 0.755936s0)) ((command-pane :even))))) (portrait-configuration (portrait-1 command-pane display-pane-1) ((portrait-1 :horizontal (0.1s0) (herald-pane current-script-pane full-history-pane) ((full-history-pane 0.335968s0) (current-script-pane 0.340908s0)) ((herald-pane :even))) (command-pane 0.045s0)) ((display-pane-1 :even))) (guide-configuration (guide-1 guide-2) ((guide-1 :horizontal (0.127s0) (herald-pane guide-command-pane) ((herald-pane 0.5s0)) ((guide-command-pane :even)))) ((guide-2 :horizontal (:even) (guide-3 display-pane-1) ((guide-3 :vertical (0.5s0) (lisp-listener-pane display-pane-2) ((lisp-listener-pane 0.46046s0)) ((display-pane-2 :even)))) ((display-pane-1 :even))))) )) :gettable-instance-variables :settable-instance-variables :inittable-instance-variables) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; INITIALIZE-GATEWAY-CONSTRAINT-FRAME ;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Called by the (GATEWAY-CONSTRAINT-FRAME :AFTER :INIT) method to initialize the ;;; constraint frame. (defun INITIALIZE-GATEWAY-CONSTRAINT-FRAME () (cond ((guide-p) (send zwei:*gateway-constraint-frame* :set-configuration 'guide-configuration) (setq *current-gateway-configuration* 'guide-configuration)) ((land-p) (send zwei:*gateway-constraint-frame* :set-configuration 'landscape-configuration) (setq *current-gateway-configuration* 'landscape-configuration)) ((port-p) (send zwei:*gateway-constraint-frame* :set-configuration 'portrait-configuration) (setq *current-gateway-configuration* 'portrait-configuration))) (setq *herald-pane* (send *gateway-constraint-frame* :get-pane 'herald-pane) *full-history-pane* (send *gateway-constraint-frame* :get-pane 'full-history-pane) *current-script-pane* (send *gateway-constraint-frame* :get-pane 'current-script-pane) *current-tutorial-pane* (send *gateway-constraint-frame* :get-pane 'current-tutorial-pane) *command-pane* (send *gateway-constraint-frame* :get-pane 'command-pane) *guide-command-pane* (send *gateway-constraint-frame* :get-pane 'guide-command-pane) *display-pane-1* (send *gateway-constraint-frame* :get-pane 'display-pane-1) *display-pane-2* (send *gateway-constraint-frame* :get-pane 'display-pane-2) *lisp-listener-pane* (send *gateway-constraint-frame* :get-pane 'lisp-listener-pane)) (send *full-history-pane* :set-io-buffer (tv:make-default-io-buffer)) (send *current-script-pane* :set-io-buffer (tv:make-default-io-buffer)) (send *current-tutorial-pane* :set-io-buffer (tv:make-default-io-buffer)) (send *herald-pane* :set-io-buffer (tv:make-default-io-buffer)) (send *command-pane* :set-io-buffer (tv:make-default-io-buffer)) (send *guide-command-pane* :set-io-buffer (tv:make-default-io-buffer))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; (GATEWAY-CONSTRAINT-FRAME :BEFORE :KILL) ;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defmethod (gateway-constraint-frame :before :kill) (&rest ignore) (send (car (send self :processes)) :flush)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; ;;; ;;; HERALDS ;;; ;;; ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; These are displayed in the Herald Pane to tell the user what program and ;;; mode are active. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; DISPLAY-HERALD ;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; The herald which says that Gateway is active. (defun DISPLAY-HERALD () (list (list "" :no-select nil) (list (cond ((gateway-p) "LMI-GATEWAY") ((guide-p) "LMI-GUIDE") ((odm-p) "LMI-ODM")) (if (guide-p) :no-select :value) (if (guide-p) nil '(#/h-s-m-c-greek-g . redisplay-current-node)) :font fonts:METSI :documentation (cond ((gateway-p) " RETURN TO LMI-GATEWAY (IF NECESSARY) AND REDISPLAY THE CURRENT NODE.") ((guide-p) " RETURN TO LMI-GUIDE (IF NECESSARY) AND REDISPLAY THE CURRENT NODE.") ((odm-p) " RETURN TO LMI-ODM (IF NECESSARY) AND REDISPLAY THE CURRENT NODE."))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; EDIT-HERALD ;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; The herald which says that Gateway is in Edit Mode. (defun EDIT-HERALD () (list (list "" :no-select nil) (list "EDIT DATA NET" :value '(#/h-s-m-c-greek-g . redisplay-current-node) :font fonts:METS :documentation (cond ((gateway-p) " RETURN TO LMI-GATEWAY (IF NECESSARY) AND REDISPLAY THE CURRENT NODE.") ((guide-p) " RETURN TO LMI-GUIDE (IF NECESSARY) AND REDISPLAY THE CURRENT NODE.") ((odm-p) " RETURN TO LMI-ODM (IF NECESSARY) AND REDISPLAY THE CURRENT NODE."))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; ;;; ;;; COMMAND MENU ITEMS ;;; ;;; ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; These are the labels and items that make up the various Gateway command menus. ;;; They are functions so they can adapt themselves to the environment in which they ;;; are displayed. The few that do not have to adapt are functions anyway, to provide ;;; a consistant method of referencing menu items. ;;; The adaptations performed fall into two categories: landscape/portrait ;;; adaptations, and Gateway/Guide/ODM adaptations. The latter are just variations ;;; on the string displayed. ;;; A LABEL on the landscape is just a non-selectable string. It is blank-padded ;;; to provide meaningful indentations in the command menu. The commands it ;;; describes appear directly below it. On the portrait, it is not blank-padded, ;;; is selectable, and is not followed by its commands. Instead, selecting it ;;; causes its commands to be displayed in a tv:menu-choose popup. This is done ;;; by making its value be a cons of #/h-s-m-c-greek-g (which was chosen for the ;;; improbability of its ever being typed accidently) with the name of the routine ;;; that pops up the menu. See the (GATEWAY-COMMAND-MENU-MIXIN :AFTER :MOUSE-BUTTONS) ;;; method for details. ;;; An ITEM is selectable and blank-padded on both landscape and portrait. On the ;;; landscape, it appears in a Gateway command menu. When it is selected, the ;;; keystroke that is its value is given to the Zmacs process via the ;;; (GATEWAY-COMMAND-MENU-MIXIN :AFTER :MOUSE-BUTTONS) method. Zmacs than maps ;;; that keystroke to a command using *mode-comtab*, and executes the command. ;;; On the Portrait, an item is displayed in a tv:menu-choose popup. When it is ;;; selected, the menu process funcalls the same command that Zmacs would have called ;;; on a Landscape. This is accomplished by reading that command out of *mode-comtab* ;;; when the item is set up, and making the item a :funcall item, rather than a :value ;;; item as on the Landscape. Since *mode-comtab* is used in either case, a Gateway ;;; programmer can ignore the duplicity of mechanism; any menu item that follows ;;; the formula will automatically work and have the same effect on both Landscape ;;; and Portrait terminals. (defun SKIP-A-LINE () (list " " :no-select nil :font 'cptfontb)) (defun GUIDE-COMMANDS-LABEL () (list "Guide Commands " :no-select nil :font 'cptfontb)) (defun DISPLAY-INFORMATION-LABEL () (list (if (land-p) "Display Information " "Display Information") (if (land-p) :no-select :value) (if (land-p) nil '(#/h-s-m-c-greek-g . pop-up-display-information-menu)) :font 'cptfontb (unless (land-p) :documentation) (unless (land-p) " MENU OF NEXT NODE, PREVIOUS NODE, FIRST NODE, CURRENT SCRIPT, INITIAL SCRIPT, TYPE TITLE AND FILE."))) (defun NEXT-NODE-ITEM () (list (if (guide-p) " Next Node " " Next Node [S-n]") (if (land-p) :value :funcall) (if (land-p) (ncons #/super-n) (cdr (assq '#/super-n (comtab-keyboard-array *mode-comtab*)))) :font 'cptfont :documentation " DISPLAY THE NEXT NODE IN THE CURRENT SCRIPT.")) (defun PREVIOUS-NODE-ITEM () (list (if (guide-p) " Previous Node " " Previous Node [S-p]") (if (land-p) :value :funcall) (if (land-p) (ncons #/super-p) (cdr (assq '#/super-p (comtab-keyboard-array *mode-comtab*)))) :font 'cptfont :documentation " DISPLAY THE PREVIOUS NODE IN THE CURRENT SCRIPT.")) (defun FIRST-NODE-ITEM () (list " First Node [S-f]" (if (land-p) :value :funcall) (if (land-p) (ncons #/super-f) (cdr (assq '#/super-f (comtab-keyboard-array *mode-comtab*)))) :font 'cptfont :documentation " DISPLAY THE FIRST NODE IN THE CURRENT SCRIPT.")) (defun CURRENT-SCRIPT-NODE-ITEM () (list (if (guide-p) " Lesson Contents " " Current Script [S-s]") (if (land-p) :value :funcall) (if (land-p) (ncons #/super-s) (cdr (assq '#/super-s (comtab-keyboard-array *mode-comtab*)))) :font 'cptfont :documentation (if (guide-p) " MENU OF NODES IN THE LESSON." " DISPLAY THE CURRENT SCRIPT."))) (defun INITIAL-SCRIPT-NODE-ITEM () (list " Initial Script [S-i]" (if (land-p) :value :funcall) (if (land-p) (ncons #/super-i) (cdr (assq '#/super-i (comtab-keyboard-array *mode-comtab*)))) :font 'cptfont :documentation " DISPLAY THE INITIAL SCRIPT.")) (defun DEFAULT-SCRIPT-NODE-ITEM () (list " Default Script [S-d]" (if (land-p) :value :funcall) (if (land-p) (ncons #/super-d) (cdr (assq '#/super-d (comtab-keyboard-array *mode-comtab*)))) :font 'cptfont :documentation " DISPLAY THE DEFAULT SCRIPT.")) (defun TYPE-TITLE-AND-FILE-ITEM () (list " Type Title & File [S-t]" (if (land-p) :value :funcall) (if (land-p) (ncons #/super-t) (cdr (assq '#/super-t (comtab-keyboard-array *mode-comtab*)))) :font 'cptfont :documentation " TYPE IN THE TITLE AND THE FILE FOR A NODE. ENTER (S) TO TAKE THE DEFAULT(S).")) (defun ACCESS-INDEX-LABEL () (list (if (land-p) "Access Indexes " "Access Indexes") (if (land-p) :no-select :value) (if (land-p) nil '(#/h-s-m-c-greek-g . pop-up-access-index-menu)) :font 'cptfontb (unless (land-p) :documentation) (unless (land-p) " MENU OF SELECT INDEX AND GET INDEX PAGE."))) (defun SELECT-INDEX-ITEM () (list " Select Index [H-s]" (if (land-p) :value :funcall) (if (land-p) (ncons #/hyper-s) (cdr (assq '#/hyper-s (comtab-keyboard-array *mode-comtab*)))) :font 'cptfont :documentation " SELECT AN INDEX. A KEYWORD LIST OF PAGES IN THE INDEX WILL BE DISPLAYED. CHOOSE A PAGE TO SEE ITS ENTRIES.")) (defun GET-INDEX-PAGE-ITEM () (list " Get Index Page [H-i]" (if (land-p) :value :funcall) (if (land-p) (ncons #/hyper-i) (cdr (assq '#/hyper-i (comtab-keyboard-array *mode-comtab*)))) :font 'cptfont :documentation " DISPLAY AN INDEX PAGE. CHOOSE AN ENTRY FROM THE PAGE TO GET THE NODE DESCRIBED IN THE ENTRY.")) (defun SELECT-BY-HISTORY-LABEL () (list (if (land-p) "Select by History " "Select by History") (if (land-p) :no-select :value) (if (land-p) nil '(#/h-s-m-c-greek-g . pop-up-select-by-history-menu)) :font 'cptfontb (unless (land-p) :documentation) (unless (land-p) " MENU OF DATA NODE HISTORY, SCRIPT NODE HISTORY, FULL HISTORY, EDITING HISTORY, NODE MARKS, BACKTRACK."))) (defun FULL-HISTORY-ITEM () (list (if (guide-p) " Full History " " Full History [H-S-f]") (if (land-p) :value :funcall) (if (land-p) (ncons #/hyper-super-f) (cdr (assq '#/hyper-super-f (comtab-keyboard-array *mode-comtab*)))) :font 'cptfont :documentation " DISPLAY A LIST OF ALL PREVIOUSLY SELECTED DATA AND SCRIPT NODES.")) (defun DATA-NODE-HISTORY-ITEM () (list " Data Node History [H-S-d]" (if (land-p) :value :funcall) (if (land-p) (ncons #/hyper-super-d) (cdr (assq '#/hyper-super-d (comtab-keyboard-array *mode-comtab*)))) :font 'cptfont :documentation " DISPLAY A LIST OF ALL PREVIOUSLY SELECTED DATA NODES.")) (defun SCRIPT-NODE-HISTORY-ITEM () (list " Script Node History [H-S-s]" (if (land-p) :value :funcall) (if (land-p) (ncons #/hyper-super-s) (cdr (assq '#/hyper-super-s (comtab-keyboard-array *mode-comtab*)))) :font 'cptfont :documentation " DISPLAY A LIST OF ALL PREVIOUSLY SELECTED SCRIPT NODES.")) (defun EDITING-HISTORY-ITEM () (list " Editing History [H-S-e]" (if (land-p) :value :funcall) (if (land-p) (ncons #/hyper-super-e) (cdr (assq '#/hyper-super-e (comtab-keyboard-array *mode-comtab*)))) :font 'cptfont :documentation " DISPLAY A LIST OF ALL NODES THAT HAVE BEEN EDITED.")) (defun NODE-MARKS-ITEM () (list " Node marks [H-S-n]" (if (land-p) :value :funcall) (if (land-p) (ncons #/hyper-super-n) (cdr (assq '#/hyper-super-n (comtab-keyboard-array *mode-comtab*)))) :font 'cptfont :documentation " DISPLAY A LIST OF ALL NODE MARKS. ")) (defun BACKTRACK-ITEM () (list " Backtrack [H-S-b]" (if (land-p) :value :funcall) (if (land-p) (ncons #/hyper-super-b) (cdr (assq '#/hyper-super-b (comtab-keyboard-array *mode-comtab*)))) :font 'cptfont :documentation " REDISPLAY THE NODE THAT WAS CURRENT BEFORE THE ONE NOW ON DISPLAY.")) (defun EDIT-DATA-NET-LABEL () (list (if (land-p) "Edit Data Net " "Edit Data Net") (if (land-p) :no-select :value) (if (land-p) nil '(#/h-s-m-c-greek-g . pop-up-edit-data-net-menu)) :font 'cptfontb (unless (land-p) :documentation) (unless (land-p) " MENU OF CREATE/MODIFY DATA-NODE/SCRIPT, GENERATE SCRIPT, CREATE/MODIFY FILE, RETURN TO DISPLAYER"))) (defun ENTER-EDITOR-ITEM () (list " Enter Editor [S-M-e]" (if (land-p) :value :funcall) (if (land-p) (ncons #/super-meta-e) (cdr (assq '#/super-meta-e (comtab-keyboard-array *mode-comtab*)))) :font 'cptfont :documentation " ENTER THE GATEWAY EDITOR. THE CURRENT NODE CAN BE MODIFIED IMMEDIATELY.")) (defun CREATE-NODE-ITEM () (list " Create Node [S-c]" (if (land-p) :value :funcall) (if (land-p) (ncons #/super-c) (cdr (assq '#/super-c (comtab-keyboard-array *mode-comtab*)))) :font 'cptfont :documentation " CREATE A DATA NODE OR SCRIPT NODE BY TYPING IN ITS CONTENTS.")) (defun CREATE-FILE-ITEM () (list " Create File [S-M-c]" (if (land-p) :value :funcall) (if (land-p) (ncons #/super-meta-c) (cdr (assq '#/super-meta-c (comtab-keyboard-array *mode-comtab*)))) :font 'cptfont :documentation " CREATE A NEW FILE FOR EDITING AS A WHOLE (I.E. NOT PER-NODE). THE FILE NEED NOT BECOME A GATEWAY FILE.")) (defun EXTRACT-NODE-ITEM () (list " Extract A Node [S-x]" (if (land-p) :value :funcall) (if (land-p) (ncons #/super-x) (cdr (assq '#/super-x (comtab-keyboard-array *mode-comtab*)))) :font 'cptfont :documentation " COPY A REGION TO A DATA NODE OR SCRIPT NODE NOT ON DISPLAY. THE NODE WILL BE CREATED.")) (defun GENERATE-SCRIPT-NODE-ITEM () (list " Generate Script Node [H-g]" (if (land-p) :value :funcall) (if (land-p) (ncons #/hyper-g) (cdr (assq '#/hyper-g (comtab-keyboard-array *mode-comtab*)))) :font 'cptfont :documentation " AUTOMATICALLY GENERATE A SCRIPT NODE REFERENCING THE NODES IN A FILE, BUFFER, OR HISTORY.")) (defun MODIFY-NODE-ITEM () (list " Modify Node [S-m]" (if (land-p) :value :funcall) (if (land-p) (ncons #/super-m) (cdr (assq '#/super-m (comtab-keyboard-array *mode-comtab*)))) :font 'cptfont :documentation " MODIFY THE CURRENT DATA OR SCRIPT NODE.")) (defun MODIFY-FILE-ITEM () (list " Modify File [S-M-m]" (if (land-p) :value :funcall) (if (land-p) (ncons #/super-meta-m) (cdr (assq '#/super-meta-m (comtab-keyboard-array *mode-comtab*)))) :font 'cptfont :documentation " MODIFY AN EXISTING FILE AS A WHOLE (I.E. NOT PER-NODE). THE FILE NEED NOT BE A GATEWAY FILE.")) (defun WRITE-CHANGES-ITEM () (list " Write Changes [S-M-w]" (if (land-p) :value :funcall) (if (land-p) (ncons #/super-meta-w) (cdr (assq '#/super-w (comtab-keyboard-array *mode-comtab*)))) :font 'cptfont :documentation " WRITE NEW AND MODIFIED NODES TO DISK. WRITING IS DONE PER-FILE WITH QUERY BEFORE EACH WRITE.")) (defun RETURN-TO-DISPLAYER-ITEM () (list " Return to Displayer [S-M-r]" (if (land-p) :value :funcall) (if (land-p) (ncons #/super-meta-r) (cdr (assq '#/super-meta-r (comtab-keyboard-array *mode-comtab*)))) :font 'cptfont :documentation " RETURN TO THE GATEWAY DISPLAY (NON-EDITING) ENVIRONMENT.")) (defun MISCELLANEOUS-LABEL () (list (if (land-p) "Miscellaneous " "Miscellaneous") (if (land-p) :no-select :value) (if (land-p) nil '(#/h-s-m-c-greek-g . pop-up-miscellaneous-menu)) :font 'cptfontb (unless (land-p) :documentation) (unless (land-p) " MENU OF CREATE NODE MARK, CROSS REFERENCES, EXECUTE FUNCTION, FORGET HISTORY, PRINT DATA, SELECT CONFIGURATION"))) (defun CREATE-NODE-MARK-ITEM () (list " Create Node Mark [H-S-m]" (if (land-p) :value :funcall) (if (land-p) (ncons #/hyper-super-m) (cdr (assq '#/hyper-super-m (comtab-keyboard-array *mode-comtab*)))) :font 'cptfont :documentation " CREATE A NODE MARK.")) (defun RELATED-INFORMATION-ITEM () (list " Related Information [H-S-r]" (if (land-p) :value :funcall) (if (land-p) (ncons #/hyper-super-r) (cdr (assq '#/hyper-super-r (comtab-keyboard-array *mode-comtab*)))) :font 'cptfont :documentation " SHOW RELATED INFORMATION FOR THIS NODE.")) (defun EXECUTE-FUNCTION-ITEM () (list " Execute Function [H-S-x]" (if (land-p) :value :funcall) (if (land-p) (ncons #/hyper-super-x) (cdr (assq '#/hyper-super-x (comtab-keyboard-array *mode-comtab*)))) :font 'cptfont :documentation " EXECUTE FUNCTION ASSOCIATED WITH THIS NODE.")) (defun FORGET-HISTORY-ITEM () (list " Forget History [S-M-f]" (if (land-p) :value :funcall) (if (land-p) (ncons #/super-meta-f) (cdr (assq '#/super-meta-f (comtab-keyboard-array *mode-comtab*)))) :font 'cptfont :documentation " FORGET (CLEAR AND RE-INITIALIZE) THE NODE, SCRIPT, OR COMBINED HISTORIES. ")) (defun PRINT-DATA-ITEM () (list " Print Data [H-S-p]" (if (land-p) :value :funcall) (if (land-p) (ncons #/hyper-super-p) (cdr (assq '#/hyper-super-p (comtab-keyboard-array *mode-comtab*)))) :font 'cptfont :documentation " PRINT THE CURRENT NODE.")) (defun HELP-WITH-GATEWAY-ITEM () (list (cond ((gateway-p) " Help With Gateway  ") ((guide-p) " Help With Guide  ") ((odm-p) " Help With ODM  ")) (if (land-p) :value :funcall) (if (land-p) (ncons #/help) (cdr (assq '#/help (comtab-keyboard-array *mode-comtab*)))) :font 'cptfont :documentation (cond ((gateway-p) " PROVIDE HELP WITH LMI-GATEWAY; Choose G option.") ((guide-p) " PROVIDE HELP WITH LMI-GUIDE; Choose = option.") ((odm-p) " PROVIDE HELP WITH LMI-ODM; Choose O option.")))) (defun HELP-WITH-GATEWAY-LABEL () (list (cond ((gateway-p) "Help With Gateway") ((guide-p) "Help with Guide") ((odm-p) "Help With ODM")) :value (ncons #/help) :font 'cptfontb :documentation (cond ((gateway-p) " PROVIDE HELP WITH LMI-GATEWAY; Choose G option.") ((guide-p) " PROVIDE HELP WITH LMI-GUIDE; Choose = option.") ((odm-p) " PROVIDE HELP WITH LMI-ODM; Choose O option.")))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; ;;; ;;; STATIC COMMAND MENUS ;;; ;;; ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; With the labels and items above defined, we can make any number of menus by ;;; combining them in various ways. The Gateway menu adapts to the configuration ;;; of the Gateway constraint frame, but does not care about other properties of ;;; the environment, because these are adapted-to by the individual labels and items. ;;; The static menu(s) used by Gateway. See also POPUP-COMMAND-MENUS, below. (defun GATEWAY-MENU () (cond ((guide-p) (list (guide-commands-label) (next-node-item) (previous-node-item) (current-script-node-item) (full-history-item))) ((land-p) (list (skip-a-line) (display-information-label) (next-node-item) (previous-node-item) (first-node-item) (current-script-node-item) (initial-script-node-item) (default-script-node-item) (type-title-and-file-item) (skip-a-line) (access-index-label) (select-index-item) (get-index-page-item) (skip-a-line) (select-by-history-label) (full-history-item) (data-node-history-item) (script-node-history-item) (editing-history-item) (node-marks-item) (backtrack-item) (skip-a-line) (edit-data-net-label) (enter-editor-item) (create-node-item) (create-file-item) (generate-script-node-item) (modify-node-item) (modify-file-item) (write-changes-item) (return-to-displayer-item) (skip-a-line) (miscellaneous-label) (create-node-mark-item) (related-information-item) (when (gateway-p) (execute-function-item)) (forget-history-item) (print-data-item) (help-with-gateway-item))) ((port-p) (list (display-information-label) (select-by-history-label) (miscellaneous-label) (access-index-label) (edit-data-net-label) (help-with-gateway-label))) )) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; ;;; ;;; POPUP COMMAND MENUS ;;; ;;; ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; These are the popups that are used on the Portrait terminal. They have no ;;; adapting to do, because all the items adapt themselves individually. ;;; Portrait terminal popup menu of Display Information commands. (defun POP-UP-DISPLAY-INFORMATION-MENU () (tv:menu-choose (list (skip-a-line) (next-node-item) (previous-node-item) (first-node-item) (current-script-node-item) (initial-script-node-item) (default-script-node-item) (type-title-and-file-item) (skip-a-line)))) ;;; Portrait terminal popup menu of Access Index commands. (defun POP-UP-ACCESS-INDEX-MENU () (tv:menu-choose (list (skip-a-line) (select-index-item) (get-index-page-item) (skip-a-line)))) ;;; Portrait terminal popup menu of Select by History commands. (defun POP-UP-SELECT-BY-HISTORY-MENU () (tv:menu-choose (list (skip-a-line) (full-history-item) (data-node-history-item) (script-node-history-item) (editing-history-item) (node-marks-item) (backtrack-item) (skip-a-line)))) ;;; Portrait terminal popup menu of Edit Data Net commands. (defun POP-UP-EDIT-DATA-NET-MENU () (tv:menu-choose (list (skip-a-line) (enter-editor-item) (create-node-item) (create-file-item) (generate-script-node-item) (modify-node-item) (modify-file-item) (write-changes-item) (return-to-displayer-item) (skip-a-line)))) ;;; Portrait terminal popup menu of Miscellaneous commands. (defun POP-UP-MISCELLANEOUS-MENU () (tv:menu-choose (list (skip-a-line) (create-node-mark-item) (related-information-item) (when (gateway-p) (execute-function-item)) (forget-history-item) (print-data-item) (help-with-gateway-item) (skip-a-line)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; ;;; ;;; COMTAB ;;; ;;; ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Ye Comtab. When a command (keystroke) is put in the Zmacs IO buffer, Zmacs ;;; searches various relevant comtabs looking for it. If Zmacs finds the keystroke, ;;; it executes the command associated with it in the comtab in which it was found. (defconst *GATEWAY-COMTAB* '(#/super-n com-next-node #/super-p com-previous-node #/super-f com-first-node #/super-s com-current-script #/super-i com-initial-script #/super-d com-default-script #/super-t com-type-title-and-file #/hyper-s com-select-index #/hyper-i com-get-index-page #/hyper-super-f com-full-history #/hyper-super-d com-data-node-history #/hyper-super-s com-script-history #/hyper-super-e com-editing-history #/hyper-super-n com-node-marks #/hyper-super-b com-backtrack #/super-meta-e com-enter-editor #/super-c com-create-node #/super-meta-c com-create-file #/hyper-g com-generate-script #/super-m com-modify-node #/super-meta-m com-modify-file #/super-meta-w com-write-changes #/super-meta-r com-return-to-displayer #/hyper-super-m com-create-node-mark #/hyper-super-r com-related-information ; #/hyper-super-x com-execute-function #/super-meta-f com-forget-history #/hyper-super-p com-print-data #/help com-help #/super-= com-redisplay-current-node #/roman-i com-first-full-history-entry #/roman-ii com-second-full-history-entry #/roman-iii com-third-full-history-entry #/roman-iv com-fourth-full-history-entry #/hyper-super-hand-down com-next-twice-current-script #/Mouse-1-1 com-mouse-1-1 #/control-shift-u com-odm-quick-undo #/control-shift-r com-odm-quick-redo #/super-. com-odm-document-symbol)) (defconst *gateway-extended-comtab* '(("undo" . com-odm-undo) ("redo" . com-odm-redo))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; ;;; ;;; DEFCOMS ;;; ;;; ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; All these coms are dummies. Zmacs won't execute a defun directly from the ;;; comtab. It has to execute a defcom, and it insists that the defcom end ;;; with an indication of what (if any) redisplaying is to be done before ;;; control returns to the command loop. To dump these limitations, each ;;; Gateway defcom immediately calls a defun to do the actual work, and ends ;;; with dis-none, meaning don't redisplay anything. Only GATEWAY-DISPLAY-NODE ;;; ever redisplays anything on Gateway's account, and it calls the redisplayer ;;; directly. (defcom COM-NEXT-NODE "Display the next node in the current script." () (next-node) dis-none) (defcom COM-PREVIOUS-NODE "Display the previous node in the current script." () (previous-node) dis-none) (defcom COM-FIRST-NODE "Display the first node in the current script." () (first-node) dis-none) (defcom COM-CURRENT-SCRIPT "Display the current script." () (current-script) dis-none) (defcom COM-INITIAL-SCRIPT "Display the initial script." () (initial-script) dis-none) (defcom COM-DEFAULT-SCRIPT "Display the default script." () (default-script) dis-none) (defcom COM-TYPE-TITLE-AND-FILE "Type in the title and the file for a node. Enter (s) to take the default(s)." () (type-title-and-file) dis-none) (defcom COM-SELECT-INDEX "Select a menu element to get the index page for a range of topics" () (select-index) dis-none) (defcom COM-GET-INDEX-PAGE "Select an index entry to get the node described in the entry." () (get-index-page) dis-none) (defcom COM-FULL-HISTORY "Display a list of all previously selected data and script nodes." () (full-history) dis-none) (defcom COM-DATA-NODE-HISTORY "Display a list of all previously selected data nodes." () (data-node-history) dis-none) (defcom COM-SCRIPT-HISTORY "Display a list of all previously selected script nodes." () (script-history) dis-none) (defcom COM-EDITING-HISTORY "Display a list of all nodes that have been edited." () (editing-history) dis-none) (defcom COM-NODE-MARKS "Display a list of all node marks. " () (node-marks) dis-none) (defcom COM-BACKTRACK "Redisplay the node that was current before the one now on display." () (backtrack) dis-none) (defcom COM-ENTER-EDITOR "Enter the Gateway editor. The current node can be modified immediately." () (enter-editor) dis-none) (defcom COM-CREATE-NODE "Create a data node or script node by typing in its contents." () (create-node) dis-none) (defcom COM-CREATE-FILE "Create a new file for editing as a whole (i.e. not per-node). The file need not become a Gateway file." () (create-file) dis-none) (defcom COM-GENERATE-SCRIPT "Automatically generate a script node referencing the nodes in a file, buffer, or history." () (generate-script) dis-none) (defcom COM-MODIFY-NODE "Modify the current data or script node." () (modify-node) dis-none) (defcom COM-MODIFY-FILE "Modify an existing file as a whole (i.e. not per-node). The file need not be a gateway file." () (modify-file) dis-none) (defcom COM-WRITE-CHANGES "Write new and modified nodes to disk. Writing is done per-file with query before each write." () (write-changes) dis-none) (defcom COM-RETURN-TO-DISPLAYER "Return to the Gateway display (non-editing) environment." () (return-to-displayer) dis-none) (defcom COM-CREATE-NODE-MARK "Create a node mark."() (create-node-mark) dis-none) (defcom COM-RELATED-INFORMATION "Show related information for this node." () (related-information) dis-none) (defcom COM-EXECUTE-FUNCTION "Execute function associated with the current node." () (execute-function) dis-none) (defcom COM-FORGET-HISTORY "Forget (clear and re-initialize) the node, script, or combined histories. " () (forget-history) dis-none) (defcom COM-PRINT-DATA "Print the current node." () (print-data) dis-none) (defcom COM-HELP "Enter the help utility" () (cond ((gateway-p) (let ((*com-documentation-alist* (cons '(#/G com-help-with-gateway) *com-documentation-alist*))) (com-documentation))) ((guide-p) (let ((*com-documentation-alist* (cons '(#/= com-help-with-guide) *com-documentation-alist*))) (com-documentation))) ((odm-p) (let ((*com-documentation-alist* (cons '(#/O com-help-with-odm) *com-documentation-alist*))) (com-documentation))))) (defcom COM-HELP-WITH-GATEWAY "Explain basic LMI-GATEWAY Commands" () (help-with-gateway) dis-none) (defcom COM-HELP-WITH-GUIDE "Explain basic LMI-GUIDE Commands" () (help-with-guide) dis-none) (defcom COM-HELP-WITH-ODM "Explain basic LMI-ODM Commands" () (help-with-odm) dis-none) (defcom COM-REDISPLAY-CURRENT-NODE "Redisplay the node currently on display (internal command)." () (redisplay-current-node) dis-none) (defcom COM-FIRST-FULL-HISTORY-ENTRY "Display the first node named in the full-history pane (internal command)." () (first-full-history-entry) dis-none) (defcom COM-SECOND-FULL-HISTORY-ENTRY "Display the second node named in the full-history pane (internal command)." () (second-full-history-entry) dis-none) (defcom COM-THIRD-FULL-HISTORY-ENTRY "Display the third node named in the full-history pane (internal command)." () (third-full-history-entry) dis-none) (defcom COM-FOURTH-FULL-HISTORY-ENTRY "Display the fourth node named in the full-history pane (internal command)." () (fourth-full-history-entry) dis-none) (defcom COM-NEXT-TWICE-CURRENT-SCRIPT "Display the fourth node named in the current script pane (internal command)." () (next-twice-current-script) dis-none) (defcom COM-DISPLAY-FROM-TUTORIAL-PANE "Display a node whose name was given literally in a menu-item's value (internal command) (unused)." () (display-from-tutorial-pane) dis-none) (defcom COM-EXECUTE-GATEWAY-COMMAND "Execute a Gateway command whose name was given literally in a menu-item's value (internal command)." () (execute-gateway-command) dis-none) (defcom COM-MOUSE-1-1 "Mouse-left handling when Gateway is the active program (internal command)." () (mouse-1-1) dis-none) (defcom COM-SELECT-FROM-SCRIPT "Display a node whose name was selected by mousing from a script (internal command)." () (select-from-script) dis-none) (defcom COM-ODM-UNDO "Do COM-UNDO to the current node or region." () (odm-undo) dis-none) (defcom COM-ODM-QUICK-UNDO "Do COM-QUICK-UNDO to the current node or region." () (odm-quick-undo) dis-none) (defcom COM-ODM-REDO "Do COM-REDO to the current node or region." () (odm-redo) dis-none) (defcom COM-ODM-QUICK-REDO "Do COM-QUICK-REDO to the current node or region." () (odm-quick-redo) dis-none) (defcom COM-ODM-DOCUMENT-SYMBOL "Display the node for a symbol the user types in." () (odm-document-symbol) dis-none)