cgit.sxemacs.org Git - sxemacs/blob - lisp/term/apollo.el

   1 ;;; apollo.el --- Apollo Graphics Primitive Support Functions
   2
   3 ;; Copyright (C) 1998 by Free Software Foundation, Inc.
   4 ;; Copyright (C) 1991 by Lucid, Inc.
   5
   6 ;; Author: Leonard N. Zubkoff <lnz@dandelion.com>
   7 ;; Keywords: hardware
   8
   9 ;; This file is part of SXEmacs.
  10
  11 ;; SXEmacs is free software: you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation, either version 3 of the License, or
  14 ;; (at your option) any later version.
  15
  16 ;; SXEmacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Synched up with: InfoDock 3.6.2.
  25
  26 ;;; Commentary:
  27
  28 ;;                  GNU Emacs Apollo GPR Support Functions
  29
  30 ;;                            Leonard N. Zubkoff
  31
  32 ;;                               lnz@dandelion.com
  33 ;;                            Lucid, Incorporated
  34 ;;                              23 January 1991
  35
  36 ;; This file defines functions that support GNU Emacs using the Apollo
  37 ;; Graphics Primitives (GPR).  See the file "APOLLO.README" for a description
  38 ;; of the key bindings set up by this file.
  39
  40 ;;                             Acknowledgements
  41
  42 ;; The following people have contributed ideas that have helped make this
  43 ;; interface possible: Nathaniel Mishkin, Rob Stanzel, and Mark Weissman of
  44 ;; Apollo Computer, Dave Holcomb of CAECO, Vincent Broman of NOSC, and J. W.
  45 ;; Peterson of the University of Utah.
  46
  47 ;;; Change Log:
  48 ;; Bob Weiner, Motorola, Inc., 2/2/89
  49
  50 ;; Added section to 'apollo-clean-help-file()' to remove underlining
  51 ;;   and overstriking (only by the same letter) from Apollo '.hlp' files.
  52 ;;   Based on the 'nuke-nroff-bs' function in man.el.
  53 ;; Changed apollo-mouse-{cut,copy,paste} commands so that they work
  54 ;;   with the DM paste buffer.  This combined with cut,copy,paste
  55 ;;   bindings of the mouse keys allows quick and easy copying from
  56 ;;   Emacs windows to DM windows.
  57 ;; Added 'unbind-apollo-mouse-button' and 'unbind-apollo-function-key'
  58 ;;   commands.
  59 ;; Added 'apollo-mouse-cut-copy-paste' command which provides a
  60 ;;   second set of mouse key functions that can be set with one key
  61 ;;   press and cleared with another key press.  Put default mouse key
  62 ;;   bindings into a command called 'apollo-mouse-defaults' so that
  63 ;;   they can be used to clear any other mouse bindings.
  64 ;; Both these commands affect the DM mouse key bindings as well.
  65 ;; Added 'apollo-mouse-cancel-cut-copy-paste' command which resets the mouse
  66 ;;   key defaults within Emacs and the DM.  The variable
  67 ;;   '*dm-mouse-key-bindings-file*' should be set within an initialization
  68 ;;   file to the pathname of file that executes a user's default DM mouse
  69 ;;   key bindings.
  70
  71 ;; Bob Weiner, Motorola, Inc., 2/23/89
  72
  73 ;; Added ':' as valid character within a filename (if not at the end)
  74 ;; in the command 'extract-file-name-around-point'.  For remote UNIX
  75 ;; operations such as rcp and rsh commands which use the syntax,
  76 ;; <host>:<path>.
  77
  78 ;; Bob Weiner, Motorola, Inc., 3/09/89
  79 ;;
  80 ;; Modified 'apollo-mouse-find-file' and 'apollo-find-file' so that they
  81 ;; recognize buffer names in addition to directory or file paths.  A buffer
  82 ;; name is recognized before a path name, if the match buffer names flag is
  83 ;; enabled.  Added the command 'extract-buf-or-file-name-around-point' to
  84 ; support this functionality.  Added find file in other window option to
  85 ;; these two find-file commands.
  86
  87 ;; Bob Weiner, Motorola, Inc., 3/20/89
  88
  89 ;; Changed (funcall *apollo-key-bindings-hook*) to (run-hooks
  90 ;; '*apollo-key-bindings-hook*) which is what it should be.
  91
  92 ;; Bob Weiner, Motorola, Inc., 4/20/89
  93
  94 ;; Rebound M2D button to perform different functions by buffer and location in
  95 ;; buffer.  Executes 'smart-key-mouse' command found in smart-key.el.
  96 ;; Meta-M2D executes 'smart-key-mouse-meta'.  M2U is unbound.
  97
  98 ;; Bob Weiner, Motorola, Inc., 8/1/89
  99
 100 ;; Fixed 'apollo-mouse-move-point' and 'apollo-mouse-move-mark' so they do
 101 ;; not set the mark gratuitously.  They are bound to M1D and M1U respectively.
 102
 103 ;; Bob Weiner, Motorola, Inc., 4/11/90
 104
 105 ;; Bound left and right box arrow keys to scroll right and left,
 106 ;; respectively, which most closely emulates their DM functions.
 107
 108 ;;; Code:
 109 (eval-when-compile
 110   (globally-declare-fboundp
 111    '(enable-apollo-function-key disable-apollo-function-key
 112                                 set-apollo-meta-key enable-apollo-mouse-button
 113                                 disable-apollo-mouse-button
 114                                 write-region-to-default-apollo-paste-buffer
 115                                 insert-contents-of-default-apollo-paste-buffer
 116                                 execute-dm-command window-edges)))
 117
 118
 119 (defvar *dm-mouse-key-bindings-file* "/sys/dm/std_keys3"
 120   "Path of the DM key binding file which sets up a user's default mouse key
 121 bindings.  If none exists, this value should be set to one of the
 122 /sys/dm/std_key* files which set up DM key defaults.")
 123
 124 ;;; Set this variable in your ".emacs" to a function to call to set up
 125 ;;; additional key bindings.
 126 ;;;
 127 (defvar *apollo-key-bindings-hook* nil)
 128
 129 ;;; Set this variable non-NIL in your ".emacs" to enable preemption of normal
 130 ;;; Display Manager bindings.
 131 ;;;
 132 (defvar *preempt-display-manager-bindings* nil)
 133
 134
 135
 136 ;;; Determine whether or not we're running diskless and define
 137 ;;; *paste-buffer-directory* to point to the paste buffers directory.
 138
 139 (defvar *paste-buffer-directory*
 140   (let ((test-directory (concat "/sys/node_data."
 141                                 (downcase (getenv "NODEID"))
 142                                 "paste_buffers/")))
 143     (if (file-directory-p test-directory)
 144         test-directory
 145         "/sys/node_data/paste_buffers/")))
 146
 147
 148 ;;; Bind this variable non-NIL to allow apollo-mouse-move-point to leave the
 149 ;;; minibuffer area.
 150
 151 (defvar *apollo-mouse-move-point-allow-minibuffer-exit* nil)
 152
 153
 154 ;;; Define the Apollo Function Keys.
 155
 156 (defvar *apollo-function-keys*
 157   '(("ESC" . 0) ("L1" . 1) ("L2" . 2) ("L3" . 3)
 158     ("L1A" . 4) ("L2A" . 5) ("L3A" . 6) ("L4" . 7)
 159     ("L5" . 8) ("L6" . 9) ("L7" . 10) ("L8" . 11)
 160     ("L9" . 12) ("LA" . 13) ("LB" . 14) ("LC" . 15)
 161     ("LD" . 16) ("LE" . 17) ("LF" . 18) ("F0" . 19)
 162     ("F1" . 20) ("F2" . 21) ("F3" . 22) ("F4" . 23)
 163     ("F5" . 24) ("F6" . 25) ("F7" . 26) ("F8" . 27)
 164     ("F9" . 28) ("R1" . 29) ("R2" . 30) ("R3" . 31)
 165     ("R4" . 32) ("R5" . 33) ("R6" . 34) ("NP0" . 35)
 166     ("NP1" . 36) ("NP2" . 37) ("NP3" . 38) ("NP4" . 39)
 167     ("NP5" . 40) ("NP6" . 41) ("NP7" . 42) ("NP8" . 43)
 168     ("NP9" . 44) ("NPA" . 45) ("NPB" . 46) ("NPC" . 47)
 169     ("NPD" . 48) ("NPE" . 49) ("NPF" . 50) ("NPG" . 51)
 170     ("NPP" . 52) ("AL" . 53) ("AR" . 54) ("SHL" . 55)
 171     ("SHR" . 56) ("LCK" . 57) ("CTL" . 58) ("RPT" . 59)
 172     ("TAB" . 60) ("RET" . 61) ("BS" . 62) ("DEL" . 63)
 173     ("ESCS" . 64) ("L1S" . 65) ("L2S" . 66) ("L3S" . 67)
 174     ("L1AS" . 68) ("L2AS" . 69) ("L3AS" . 70) ("L4S" . 71)
 175     ("L5S" . 72) ("L6S" . 73) ("L7S" . 74) ("L8S" . 75)
 176     ("L9S" . 76) ("LAS" . 77) ("LBS" . 78) ("LCS" . 79)
 177     ("LDS" . 80) ("LES" . 81) ("LFS" . 82) ("F0S" . 83)
 178     ("F1S" . 84) ("F2S" . 85) ("F3S" . 86) ("F4S" . 87)
 179     ("F5S" . 88) ("F6S" . 89) ("F7S" . 90) ("F8S" . 91)
 180     ("F9S" . 92) ("R1S" . 93) ("R2S" . 94) ("R3S" . 95)
 181     ("R4S" . 96) ("R5S" . 97) ("R6S" . 98) ("NP0S" . 99)
 182     ("NP1S" . 100) ("NP2S" . 101) ("NP3S" . 102) ("NP4S" . 103)
 183     ("NP5S" . 104) ("NP6S" . 105) ("NP7S" . 106) ("NP8S" . 107)
 184     ("NP9S" . 108) ("NPAS" . 109) ("NPBS" . 110) ("NPCS" . 111)
 185     ("NPDS" . 112) ("NPES" . 113) ("NPFS" . 114) ("NPGS" . 115)
 186     ("NPPS" . 116) ("ALS" . 117) ("ARS" . 118) ("SHLS" . 119)
 187     ("SHRS" . 120) ("LCKS" . 121) ("CTLS" . 122) ("RPTS" . 123)
 188     ("TABS" . 124) ("RETS" . 125) ("BSS" . 126) ("DELS" . 127)
 189     ("ESCC" . 128) ("L1C" . 129) ("L2C" . 130) ("L3C" . 131)
 190     ("L1AC" . 132) ("L2AC" . 133) ("L3AC" . 134) ("L4C" . 135)
 191     ("L5C" . 136) ("L6C" . 137) ("L7C" . 138) ("L8C" . 139)
 192     ("L9C" . 140) ("LAC" . 141) ("LBC" . 142) ("LCC" . 143)
 193     ("LDC" . 144) ("LEC" . 145) ("LFC" . 146) ("F0C" . 147)
 194     ("F1C" . 148) ("F2C" . 149) ("F3C" . 150) ("F4C" . 151)
 195     ("F5C" . 152) ("F6C" . 153) ("F7C" . 154) ("F8C" . 155)
 196     ("F9C" . 156) ("R1C" . 157) ("R2C" . 158) ("R3C" . 159)
 197     ("R4C" . 160) ("R5C" . 161) ("R6C" . 162) ("NP0C" . 163)
 198     ("NP1C" . 164) ("NP2C" . 165) ("NP3C" . 166) ("NP4C" . 167)
 199     ("NP5C" . 168) ("NP6C" . 169) ("NP7C" . 170) ("NP8C" . 171)
 200     ("NP9C" . 172) ("NPAC" . 173) ("NPBC" . 174) ("NPCC" . 175)
 201     ("NPDC" . 176) ("NPEC" . 177) ("NPFC" . 178) ("NPGC" . 179)
 202     ("NPPC" . 180) ("ALC" . 181) ("ARC" . 182) ("SHLC" . 183)
 203     ("SHRC" . 184) ("LCKC" . 185) ("CTLC" . 186) ("RPTC" . 187)
 204     ("TABC" . 188) ("RETC" . 189) ("BSC" . 190) ("DELC" . 191)
 205     ("ESCU" . 192) ("L1U" . 193) ("L2U" . 194) ("L3U" . 195)
 206     ("L1AU" . 196) ("L2AU" . 197) ("L3AU" . 198) ("L4U" . 199)
 207     ("L5U" . 200) ("L6U" . 201) ("L7U" . 202) ("L8U" . 203)
 208     ("L9U" . 204) ("LAU" . 205) ("LBU" . 206) ("LCU" . 207)
 209     ("LDU" . 208) ("LEU" . 209) ("LFU" . 210) ("F0U" . 211)
 210     ("F1U" . 212) ("F2U" . 213) ("F3U" . 214) ("F4U" . 215)
 211     ("F5U" . 216) ("F6U" . 217) ("F7U" . 218) ("F8U" . 219)
 212     ("F9U" . 220) ("R1U" . 221) ("R2U" . 222) ("R3U" . 223)
 213     ("R4U" . 224) ("R5U" . 225) ("R6U" . 226) ("NP0U" . 227)
 214     ("NP1U" . 228) ("NP2U" . 229) ("NP3U" . 230) ("NP4U" . 231)
 215     ("NP5U" . 232) ("NP6U" . 233) ("NP7U" . 234) ("NP8U" . 235)
 216     ("NP9U" . 236) ("NPAU" . 237) ("NPBU" . 238) ("NPCU" . 239)
 217     ("NPDU" . 240) ("NPEU" . 241) ("NPFU" . 242) ("NPGU" . 243)
 218     ("NPPU" . 244) ("ALU" . 245) ("ARU" . 246) ("SHLU" . 247)
 219     ("SHRU" . 248) ("LCKU" . 249) ("CTLU" . 250) ("RPTU" . 251)
 220     ("TABU" . 252) ("RETU" . 253) ("BSU" . 254) ("DELU" . 255)
 221     ("MARK" . "L1") ("LINE_DEL" . "L2") ("CHAR_DEL" . "L3")
 222     ("L_BAR_ARROW" . "L4") ("CMD" . "L5") ("R_BAR_ARROW" . "L6")
 223     ("L_BOX_ARROW" . "L7") ("UP_ARROW" . "L8") ("R_BOX_ARROW" . "L9")
 224     ("LEFT_ARROW" . "LA") ("NEXT_WIN" . "LB") ("RIGHT_ARROW" . "LC")
 225     ("UP_BOX_ARROW" . "LD") ("DOWN_ARROW" . "LE") ("DOWN_BOX_ARROW" . "LF")
 226     ("COPY" . "L1A") ("PASTE" . "L2A") ("GROW" . "L3A") ("INS_MODE" . "L1S")
 227     ("SHELL" . "L5S") ("CUT" . "L1AS") ("UNDO" . "L2AS") ("MOVE" . "L3AS")
 228     ("POP" . "R1") ("AGAIN" . "R2") ("READ" . "R3") ("EDIT" . "R4")
 229     ("EXIT" . "R5") ("HOLD" . "R6") ("SAVE" . "R4S") ("ABORT" . "R5S")
 230     ("UNIXHELP" . "R6S") ("AEGISHELP" . "R6C")))
 231
 232
 233 ;;; Define the Apollo Mouse Buttons.
 234
 235 (defvar *apollo-mouse-buttons*
 236   '(("M1D" . 97) ("M2D" . 98) ("M3D" . 99) ("M4D" . 100)
 237     ("M1S" . 33) ("M2S" . 34) ("M3S" . 35) ("M4S" . 36)
 238     ("M1C" . 1) ("M2C" . 2) ("M3C" . 3) ("M4C" . 4)
 239     ("M1U" . 65) ("M2U" . 66) ("M3U" . 67) ("M4U" . 68)))
 240
 241
 242 ;;; Define functions to simplify making function key and mouse button bindings.
 243
 244 (defun bind-apollo-function-key (function-key binding &optional meta-binding)
 245   "Enable an Apollo Function Key and assign a binding to it."
 246   (interactive "sFunction Key: \nCCommand: \nCMeta Command: ")
 247   (let ((numeric-code (cdr (assoc function-key *apollo-function-keys*))))
 248     (if (null numeric-code)
 249         (error "%s is not a legal Apollo Function Key name" function-key))
 250     (if (stringp numeric-code)
 251         (setq numeric-code
 252               (cdr (assoc numeric-code *apollo-function-keys*))))
 253     (enable-apollo-function-key numeric-code)
 254     (let ((normal-sequence
 255            (concat (char-to-string (logior 72 (lsh numeric-code -6)))
 256                    (char-to-string (logior 64 (logand numeric-code 63)))))
 257           (meta-sequence
 258            (concat (char-to-string (logior 76 (lsh numeric-code -6)))
 259                    (char-to-string (logior 64 (logand numeric-code 63))))))
 260       (define-key 'apollo-prefix normal-sequence binding)
 261       (define-key 'apollo-prefix meta-sequence (or meta-binding binding)))))
 262
 263 (defun unbind-apollo-function-key (function-key)
 264   "Disable an Apollo Function Key and return control of it to the DM."
 265   (interactive "sFunction key: ")
 266   (let ((numeric-code (cdr (assoc function-key *apollo-function-keys*))))
 267     (if (null numeric-code)
 268         (error "%s is not a legal Apollo Function Key name" function-key))
 269     (if (stringp numeric-code)
 270         (setq numeric-code
 271               (cdr (assoc numeric-code *apollo-function-keys*))))
 272     (disable-apollo-function-key numeric-code)))
 273
 274 (defun select-apollo-meta-key (meta-key)
 275   "Select the Function Key used as the Meta Key."
 276   (interactive "sMeta Key: ")
 277   (let ((numeric-code (cdr (assoc meta-key *apollo-function-keys*))))
 278     (if (null numeric-code)
 279         (error "%s is not a legal Apollo Function Key name" meta-key))
 280     (if (stringp numeric-code)
 281         (setq numeric-code
 282               (cdr (assoc numeric-code *apollo-function-keys*))))
 283     (set-apollo-meta-key numeric-code)))
 284
 285 (defun bind-apollo-mouse-button (mouse-button binding &optional meta-binding)
 286   "Enable an Apollo Mouse Button and assign a binding to it."
 287   (interactive "sMouse Button: \nCCommand: \nCMeta Command: ")
 288   (let ((numeric-code (cdr (assoc mouse-button *apollo-mouse-buttons*))))
 289     (if (null numeric-code)
 290         (error "%s is not a legal Apollo Mouse Button name" mouse-button))
 291     (enable-apollo-mouse-button numeric-code)
 292     (let ((normal-sequence (char-to-string numeric-code))
 293           (meta-sequence (char-to-string (+ numeric-code 16))))
 294       (define-key 'apollo-prefix normal-sequence binding)
 295       (define-key 'apollo-prefix meta-sequence (or meta-binding binding)))))
 296
 297 (defun unbind-apollo-mouse-button (mouse-button)
 298   "Disable an Apollo Mouse Button and return control of it to the DM."
 299   (interactive "sMouse Button: ")
 300   (let ((numeric-code (cdr (assoc mouse-button *apollo-mouse-buttons*))))
 301     (if (null numeric-code)
 302         (error "%s is not a legal Apollo Mouse Button name" mouse-button))
 303     (disable-apollo-mouse-button numeric-code)))
 304
 305
 306 ;;; Initialize the Apollo Keymaps.
 307
 308 (define-prefix-command 'apollo-prefix)
 309 (global-set-key "\C-^" 'apollo-prefix)
 310 (define-prefix-command 'apollo-prefix-1)
 311 (define-prefix-command 'apollo-prefix-2)
 312 (define-prefix-command 'apollo-prefix-3)
 313 (define-prefix-command 'apollo-prefix-4)
 314 (define-prefix-command 'apollo-prefix-5)
 315 (define-prefix-command 'apollo-prefix-6)
 316 (define-prefix-command 'apollo-prefix-7)
 317 (define-prefix-command 'apollo-prefix-8)
 318 (define-key 'apollo-prefix "H" 'apollo-prefix-1)
 319 (define-key 'apollo-prefix "I" 'apollo-prefix-2)
 320 (define-key 'apollo-prefix "J" 'apollo-prefix-3)
 321 (define-key 'apollo-prefix "K" 'apollo-prefix-4)
 322 (define-key 'apollo-prefix "L" 'apollo-prefix-5)
 323 (define-key 'apollo-prefix "M" 'apollo-prefix-6)
 324 (define-key 'apollo-prefix "N" 'apollo-prefix-7)
 325 (define-key 'apollo-prefix "O" 'apollo-prefix-8)
 326
 327
 328 ;;; Commands to COPY, CUT, and PASTE.
 329
 330 (defun apollo-copy-region ()
 331   "Copy region between point and mark to the default DM paste buffer."
 332   (interactive)
 333   (write-region-to-default-apollo-paste-buffer (mark) (point))
 334   (message "Region Copied"))
 335
 336 (defun apollo-cut-region ()
 337   "Copy region between point and mark to the default DM paste buffer."
 338   (interactive)
 339   (write-region-to-default-apollo-paste-buffer (mark) (point))
 340   (kill-region (mark) (point))
 341   (message "Region Cut"))
 342
 343 (defun apollo-paste ()
 344   "Copy region between point and mark to the default DM paste buffer."
 345   (interactive)
 346   (let ((x (insert-contents-of-default-apollo-paste-buffer)))
 347     (push-mark (+ (point) x)))
 348   (message "Pasted and Mark set"))
 349
 350
 351 ;;; Miscellaneous Commands.
 352
 353 (defun minibuffer-prompt-length ()
 354   "Returns the length of the current minibuffer prompt."
 355   (let ((window (selected-window))
 356         length)
 357     (select-window (minibuffer-window))
 358     (let ((point (point)))
 359       (goto-char (point-min))
 360       (insert-char ?a 200)
 361       (goto-char (point-min))
 362       (vertical-motion 1)
 363       (setq length (- (frame-width) (point)))
 364       (goto-char (point-min))
 365       (delete-char 200)
 366       (goto-char point))
 367     (select-window window)
 368     length))
 369
 370 (defun extract-file-or-buffer-name-around-point (&optional buffer-flag)
 371   (let ((skip-characters (if buffer-flag
 372                              "!#-%*-9=?-{}~:<>"
 373                              "!#-%*-9=?-{}~:"))
 374         (skip-at-end (if buffer-flag
 375                          '(?@ ?. ?, ?: ?<)
 376                          '(?* ?@ ?. ?, ?:))))
 377     (save-excursion
 378       (skip-chars-backward skip-characters)
 379       (let ((start (point)))
 380         (skip-chars-forward skip-characters)
 381         (let* ((filename (buffer-substring start (point)))
 382                (last-char (aref filename (- (length filename) 1))))
 383           (if (memq last-char skip-at-end)
 384               (substring filename 0 -1)
 385               filename))))))
 386 (fset 'extract-file-name-around-point
 387       'extract-file-or-buffer-name-around-point)
 388 (fset 'extract-buf-or-file-name-around-point
 389       'extract-file-or-buffer-name-around-point)
 390
 391 (defun apollo-find-file (&optional find-buffer-flag other-window)
 392   "Find the file or buffer whose name the cursor is over.  Buffer names are
 393 matched only if the optional argument FIND-BUFFER-FLAG is non-NIL.  If the
 394 optional argument OTHER-WINDOW is non-NIL, the file is displayed in the other
 395 window.  When matching file names, ignores trailing '*' or '@' as in 'ls -F'
 396 output."
 397   (interactive)
 398   (let* ((file-or-buffer-name
 399           (extract-file-or-buffer-name-around-point find-buffer-flag))
 400          (buffer (and find-buffer-flag (get-buffer file-or-buffer-name))))
 401     (if (or buffer (file-exists-p file-or-buffer-name))
 402         (funcall (if other-window
 403                      'switch-to-buffer-other-window
 404                      'switch-to-buffer)
 405                  (or buffer (find-file-noselect file-or-buffer-name)))
 406         (error "Cannot find %s \"%s\""
 407                (if find-buffer-flag "buffer or file" "file")
 408                file-or-buffer-name))))
 409
 410 (defun apollo-grow-emacs-window ()
 411   "Grow Emacs's Apollo window with rubberbanding."
 412   (interactive)
 413   (execute-dm-command "WGE"))
 414
 415 (defun apollo-move-emacs-window ()
 416   "Move Emacs's Apollo window with rubberbanding."
 417   (interactive)
 418   (execute-dm-command "WME"))
 419
 420 (defun apollo-again ()
 421   "Copy the remainder of the current line to the end of the buffer."
 422   (interactive)
 423   (set-mark-command nil)
 424   (end-of-line)
 425   (copy-region-as-kill (mark) (point))
 426   (end-of-buffer)
 427   (yank))
 428
 429 (defun apollo-exit ()
 430   "Kill current buffer after saving changes."
 431   (interactive)
 432   (save-buffer)
 433   (kill-buffer (current-buffer)))
 434
 435 (defun apollo-abort ()
 436   "Kill current buffer without saving changes."
 437   (interactive)
 438   (kill-buffer (current-buffer)))
 439
 440 (defun apollo-aegis-help (filename)
 441   "Prompt for topic and find the Apollo help file."
 442   (interactive "sHelp on: ")
 443   (let ((help-file (concat "/sys/help/" filename ".hlp")))
 444     (with-output-to-temp-buffer "*Help File*"
 445       (buffer-disable-undo standard-output)
 446       (save-excursion
 447         (set-buffer standard-output)
 448         (insert-man-file help-file)
 449         (if (> (buffer-size) 0)
 450             (progn
 451               (message "Cleaning help file entry...")
 452               (apollo-clean-help-file)
 453               (message ""))
 454             (message "No help found in %s" help-file))
 455         (set-buffer-modified-p nil)))))
 456 (fset 'apollo-help 'apollo-aegis-help)
 457
 458 ;;; Make sure this will be loaded if necessary.
 459
 460 (autoload 'insert-man-file "man")
 461
 462 (defun apollo-clean-help-file ()
 463   (interactive "*")
 464   ;; Remove underlining and overstriking by the same letter.
 465   (goto-char (point-min))
 466   (while (search-forward "\b" nil t)
 467     (let ((preceding (char-after (- (point) 2)))
 468           (following (following-char)))
 469       (cond ((= preceding following)    ; x\bx
 470              (delete-char -2))
 471             ((= preceding ?\_)          ; _\b
 472              (delete-char -2))
 473             ((= following ?\_)          ; \b_
 474              (delete-region (1- (point)) (1+ (point)))))))
 475   ;; Remove overstriking and carriage returns before newline.
 476   (goto-char (point-min))
 477   (while (re-search-forward "\r$" nil t)
 478     (replace-match ""))
 479   (goto-char (point-min))
 480   (while (re-search-forward "^.*\r" nil t)
 481     (replace-match ""))
 482   ;; Fit in 79 cols rather than 80.
 483   (indent-rigidly (point-min) (point-max) -1)
 484   ;; Delete excess multiple blank lines.
 485   (goto-char (point-min))
 486   (while (re-search-forward "\n\n\n\n*" nil t)
 487     (replace-match "\n\n"))
 488   ;; Remove blank lines at the beginning.
 489   (goto-char (point-min))
 490   (skip-chars-forward "\n")
 491   (delete-region (point-min) (point))
 492   ;; Separate the header from the main subject line.
 493   (end-of-line)
 494   (insert "\n")
 495   (goto-char (point-min)))
 496
 497 (defun kill-whole-line ()
 498   "Kill the line containing point.  Try to retain column cursor is on."
 499   (interactive)
 500   (let ((old-column (current-column)))
 501     (beginning-of-line)
 502     (kill-line 1)
 503     (move-to-column old-column)))
 504
 505 (defun apollo-key-undefined ()
 506   "Signal that an Apollo Function Key is undefined."
 507   (interactive)
 508   (error "Apollo Function Key undefined"))
 509
 510
 511 ;;; Define the mouse commands.
 512
 513 (defun apollo-mouse-move-point (&optional no-mark)
 514   "Used so that pressing the left mouse button, moving the cursor, and
 515 releasing the left mouse button leaves the mark set to the initial position
 516 and the point set to the final position.  Useful for easily marking regions
 517 of text.  If the left mouse button is pressed and released at the same place,
 518 the mark is left at the original position of the character cursor.
 519
 520 Returns (x y) frame coordinates of point in columns and lines."
 521   (interactive)
 522   (let* ((opoint (point))
 523          (owindow (selected-window))
 524          (x (- (read-char) 8))
 525          (y (- (read-char) 8))
 526          (edges (window-edges))
 527          (window nil))
 528     (while (and (not (eq window (selected-window)))
 529                 (or (<  y (nth 1 edges))
 530                     (>= y (nth 3 edges))
 531                     (<  x (nth 0 edges))
 532                     (>= x (nth 2 edges))))
 533       (setq window (next-window window))
 534       (setq edges (window-edges window)))
 535     (if (and window (not (eq window (selected-window))))
 536         (progn
 537           (if (and (not *apollo-mouse-move-point-allow-minibuffer-exit*)
 538                    (eq (selected-window) (minibuffer-window)))
 539               (error "Cannot use mouse to leave minibuffer!"))
 540           (if (eq window (minibuffer-window))
 541               (error "Cannot use mouse to enter minibuffer!"))))
 542     (if window (select-window window))
 543     (move-to-window-line (- y (nth 1 edges)))
 544     (let* ((width-1 (1- (window-width window)))
 545            (wraps (/ (current-column) width-1))
 546            (prompt-length (if (eq (selected-window) (minibuffer-window))
 547                               (minibuffer-prompt-length)
 548                             0)))
 549       (move-to-column (+ (- x (nth 0 edges) prompt-length)
 550                          (* wraps width-1))))
 551     (if no-mark
 552         (progn (setq window (selected-window))
 553                (if (eq owindow window)
 554                    (if (equal opoint (point))
 555                        (pop-mark))
 556                  (select-window owindow)
 557                  (pop-mark)
 558                  (select-window window)))
 559       (set-mark-command nil))
 560     ;; Return (x y) coords of point in column and frame line numbers.
 561     (list x y)))
 562
 563 (defun apollo-mouse-move-mark ()
 564   "Used so that pressing the left mouse button, moving the cursor, and
 565 releasing the left mouse button leaves the mark set to the initial position
 566 and the point set to the final position.  Useful for easily marking regions
 567 of text.  If the left mouse button is pressed and released at the same place,
 568 the mark is left at the original position of the character cursor."
 569   (interactive)
 570   (apollo-mouse-move-point)
 571   (if (equal (point) (mark))
 572       (pop-mark)))
 573
 574 (defun apollo-mouse-cut ()
 575   "Move point to the location of the mouse cursor and
 576 cut the region to the default DM paste buffer."
 577   (interactive)
 578   (apollo-mouse-move-mark)
 579   (apollo-cut-region))
 580
 581 (defun apollo-mouse-copy ()
 582   "Move point to the location of the mouse cursor and
 583 copy the region to the default DM paste buffer."
 584   (interactive)
 585   (apollo-mouse-move-mark)
 586   (apollo-copy-region))
 587
 588 (defun apollo-mouse-paste ()
 589   "Move point to the location of the mouse cursor and
 590 paste in the default DM paste buffer."
 591   (interactive)
 592   (apollo-mouse-move-point)
 593   (apollo-paste))
 594
 595 (defun apollo-mouse-pop-buffer ()
 596   "Used in conjunction with the 'list-buffers' command, moves
 597 point to cursor location and displays buffer named on current line.
 598 Similar to a DM pop window by name to top."
 599   (interactive)
 600   (apollo-mouse-move-point)
 601   (Buffer-menu-select))
 602
 603 (defun apollo-mouse-find-file ()
 604   "Find the file or buffer whose name the cursor is over.  Buffers are only
 605 allowed when in the '*Buffer List*' buffer.  When matching file names, ignores
 606 trailing '*' or '@' as in 'ls -F' output."
 607   (interactive)
 608   (apollo-mouse-move-point)
 609   (let ((find-buffer-flag
 610          (equal (buffer-name (current-buffer)) "*Buffer List*")))
 611     (apollo-find-file find-buffer-flag nil)))
 612
 613 (defun apollo-mouse-find-file-other-window ()
 614   "Find the file or buffer whose name the cursor is over.  Buffers are only
 615 allowed when in the '*Buffer List*' buffer.  When matching file names, ignores
 616 trailing '*' or '@' as in 'ls -F' output.  The file or buffer is displayed in
 617 the other window."
 618   (interactive)
 619   (apollo-mouse-move-point)
 620   (let ((find-buffer-flag
 621          (equal (buffer-name (current-buffer)) "*Buffer List*")))
 622     (apollo-find-file find-buffer-flag t))
 623   (other-window 1))
 624
 625
 626 ;;; Define and Enable the Mouse Key Bindings.
 627
 628 (defun apollo-mouse-defaults ()
 629 "Set up default Apollo mouse key bindings for GNU Emacs."
 630   (interactive)
 631   (bind-apollo-mouse-button "M1D" 'apollo-mouse-move-point
 632                             'apollo-mouse-move-point) ;MOUSE LEFT DOWN
 633   (bind-apollo-mouse-button "M1U" 'apollo-mouse-move-mark
 634                             'apollo-mouse-copy) ;MOUSE LEFT UP
 635   (bind-apollo-mouse-button "M2D" 'sm-depress
 636                             'sm-depress-meta) ;MOUSE MIDDLE DOWN
 637   (bind-apollo-mouse-button "M2U" 'smart-key-mouse
 638                             'smart-key-mouse-meta) ;MOUSE MIDDLE UP
 639   (bind-apollo-mouse-button "M3D" 'sm-depress-meta) ;MOUSE RIGHT DOWN
 640   (bind-apollo-mouse-button "M3U" 'smart-key-mouse-meta) ;MOUSE RIGHT UP
 641 )
 642 (apollo-mouse-defaults)
 643
 644 (defun apollo-mouse-cut-copy-paste ()
 645   "Sets Apollo mouse keys to perform DM-style cut, copy, and paste.
 646 LEFT MOUSE DOWN moves point to cursor location.  LEFT MOUSE UP sets
 647 mark, moves point to cursor location and cuts region.  MID MOUSE works
 648 the same way but does a copy.  RIGHT MOUSE sets point and pastes at
 649 cursor location.  These key bindings are also effective in DM windows
 650 until \\[apollo-mouse-cancel-cut-copy-paste] is executed in the GNU Emacs DM
 651 window."
 652   (interactive)
 653   (bind-apollo-mouse-button "M1D" 'apollo-mouse-move-point) ;MOUSE LEFT DOWN
 654   (bind-apollo-mouse-button "M1U" 'apollo-mouse-cut) ;MOUSE LEFT UP
 655   (bind-apollo-mouse-button "M2D" 'apollo-mouse-move-point) ;MOUSE MIDDLE DOWN
 656   (bind-apollo-mouse-button "M2U" 'apollo-mouse-copy) ;MOUSE MIDDLE UP
 657   (bind-apollo-mouse-button "M3D" 'apollo-mouse-paste) ;MOUSE RIGHT DOWN
 658   (unbind-apollo-mouse-button "M3U") ;MOUSE RIGHT UP
 659   (message "Mouse Edit Mode: left=cut, mid=copy, right=paste")
 660   (execute-dm-command "msg 'Mouse Edit Mode: left=cut, mid=copy, right=paste';kd m1 dr;echo ke;kd m1u xd ke;kd m2 dr;echo ke;kd m2u xc ke; kd m3 xp ke;kd m3u ke")
 661 )
 662
 663 (defun apollo-mouse-cancel-cut-copy-paste ()
 664   "Sets Apollo mouse keys back to defaults with GNU Emacs and personal
 665 settings within the DM."
 666   (interactive)
 667   (apollo-mouse-defaults)
 668   (message "Default mouse key bindings set")
 669   (execute-dm-command
 670     (concat "msg 'Mouse Edit Mode canceled; personal mouse keys restored';"
 671             "cmdf " *dm-mouse-key-bindings-file*))
 672 )
 673
 674 ;;; Define and Enable the Function Key Bindings.
 675
 676 (bind-apollo-function-key "TABS" "\C-I") ;Shift TAB
 677 (bind-apollo-function-key "TABC" "\C-I") ;Control TAB
 678 (bind-apollo-function-key "RETS" "\C-M") ;Shift RET
 679 (bind-apollo-function-key "RETC" "\C-M") ;Control RET
 680 (bind-apollo-function-key "LINE_DEL" 'kill-whole-line) ;LINE DEL
 681 (bind-apollo-function-key "CHAR_DEL" "\C-D") ;CHAR DEL
 682 (bind-apollo-function-key "L_BAR_ARROW" "\C-A") ;LEFT BAR ARROW
 683 (bind-apollo-function-key "R_BAR_ARROW" "\C-E") ;RIGHT BAR ARROW
 684 (bind-apollo-function-key "L_BOX_ARROW" "\C-x>") ;LEFT BOX ARROW
 685 (bind-apollo-function-key "UP_ARROW" "\C-P") ;UP ARROW
 686 (bind-apollo-function-key "L8S" "\M-1\M-V") ;Shift UP ARROW
 687
 688 ;;; RIGHT BOX ARROW is the Default Meta Key.  If the Meta Key is changed with
 689 ;;; SELECT-APOLLO-META-KEY, then RIGHT BOX ARROW signals an error.
 690
 691 (select-apollo-meta-key "R1") ; Make POP the META key instead.
 692 (bind-apollo-function-key "R_BOX_ARROW" "\C-x<") ;RIGHT BOX ARROW
 693 (bind-apollo-function-key "LEFT_ARROW" "\C-B") ;LEFT ARROW
 694 (bind-apollo-function-key "RIGHT_ARROW" "\C-F") ;RIGHT ARROW
 695 (bind-apollo-function-key "DOWN_ARROW" "\C-N") ;DOWN ARROW
 696 (bind-apollo-function-key "LES" "\M-1\C-V") ;Shift DOWN ARROW
 697 (bind-apollo-function-key "R3S" 'apollo-find-file) ;Shift READ
 698 (bind-apollo-function-key "MARK" 'set-mark-command) ;MARK
 699 (bind-apollo-function-key "INS_MODE" 'overwrite-mode) ;INS MODE
 700 (bind-apollo-function-key "L2S" "\C-Y") ;Shift LINE DEL
 701 (bind-apollo-function-key "L3S" "\C-D") ;Shift CHAR DEL
 702 (bind-apollo-function-key "COPY" 'apollo-copy-region) ;COPY
 703 (bind-apollo-function-key "CUT" 'apollo-cut-region) ;CUT
 704 (bind-apollo-function-key "PASTE" 'apollo-paste) ;PASTE
 705 (bind-apollo-function-key "UNDO" 'undo) ;UNDO
 706 (bind-apollo-function-key "GROW" 'apollo-grow-emacs-window) ;GROW
 707 (bind-apollo-function-key "MOVE" 'apollo-move-emacs-window) ;MOVE
 708 (bind-apollo-function-key "LAS" "\M-B") ;Shift LEFT ARROW
 709 (bind-apollo-function-key "LCS" "\M-F") ;Shift RIGHT ARROW
 710 (bind-apollo-function-key "UP_BOX_ARROW" "\M-V") ;UP BOX ARROW
 711 (bind-apollo-function-key "LDS" "\M-<") ;Shift UP BOX ARROW
 712 (bind-apollo-function-key "DOWN_BOX_ARROW" "\C-V") ;DOWN BOX ARROW
 713 (bind-apollo-function-key "LFS" "\M->") ;Shift DOWN BOX ARROW
 714 (bind-apollo-function-key "AGAIN" 'apollo-again) ;AGAIN
 715 (bind-apollo-function-key "EXIT" 'apollo-exit) ;EXIT
 716 (bind-apollo-function-key "ABORT" 'apollo-abort) ;ABORT
 717 (bind-apollo-function-key "SAVE" 'save-buffer) ;SAVE
 718 (bind-apollo-function-key "HOLD" 'apollo-key-undefined) ;HOLD
 719
 720 (defun install-apollo-dm-preemptive-key-bindings ()
 721   (bind-apollo-function-key "L4S" "\M-<") ;Shift LEFT BAR ARROW
 722   (bind-apollo-function-key "L5" 'execute-dm-command) ;CMD
 723   (bind-apollo-function-key "L6S" "\M->") ;Shift RIGHT BAR ARROW
 724   (bind-apollo-function-key "LB" 'other-window) ;NEXT WNDW
 725   (bind-apollo-function-key "LBS" 'delete-window) ;Shift NEXT WNDW
 726   (bind-apollo-function-key "READ" 'find-file-read-only) ;READ
 727   (bind-apollo-function-key "EDIT" 'find-file) ;EDIT
 728   (bind-apollo-function-key "SHELL" 'shell) ;SHELL
 729   (bind-apollo-function-key "UNIXHELP" 'manual-entry) ;HELP
 730   (bind-apollo-function-key "AEGISHELP" 'apollo-aegis-help)) ;HELP
 731
 732 (if *preempt-display-manager-bindings*
 733     (install-apollo-dm-preemptive-key-bindings))
 734
 735 (run-hooks '*apollo-key-bindings-hook*)
 736
 737 (provide 'apollo)
 738
 739 ;;; apollo.el ends here