diff lisp/term/apollo.el @ 239:41f2f0e326e9 r20-5b18

Import from CVS: tag r20-5b18
author cvs
date Mon, 13 Aug 2007 10:15:48 +0200
parents 376386a54a3c
children
line wrap: on
line diff
--- a/lisp/term/apollo.el	Mon Aug 13 10:15:04 2007 +0200
+++ b/lisp/term/apollo.el	Mon Aug 13 10:15:48 2007 +0200
@@ -1,1 +1,732 @@
-(load "term/vt100" nil t)
+;;; apollo.el --- Apollo Graphics Primitive Support Functions
+
+;; Copyright (C) 1998 by Free Software Foundation, Inc.
+;; Copyright (C) 1991 by Lucid, Inc.
+
+;; Author: Leonard N. Zubkoff <lnz@dandelion.com>
+;; Keywords: hardware
+
+;; This file is part of XEmacs.
+
+;; XEmacs is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; XEmacs is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with XEmacs; see the file COPYING.  If not, write to the Free
+;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+;; 02111-1307, USA.
+
+;;; Synched up with: InfoDock 3.6.2.
+
+;;; Commentary:
+
+;;		    GNU Emacs Apollo GPR Support Functions
+
+;;			      Leonard N. Zubkoff
+
+;;				 lnz@dandelion.com
+;;			      Lucid, Incorporated
+;;				23 January 1991
+
+;; This file defines functions that support GNU Emacs using the Apollo
+;; Graphics Primitives (GPR).  See the file "APOLLO.README" for a description
+;; of the key bindings set up by this file.
+
+;;			       Acknowledgements
+
+;; The following people have contributed ideas that have helped make this
+;; interface possible: Nathaniel Mishkin, Rob Stanzel, and Mark Weissman of
+;; Apollo Computer, Dave Holcomb of CAECO, Vincent Broman of NOSC, and J. W.
+;; Peterson of the University of Utah.
+
+;;; Change Log:
+;; Bob Weiner, Motorola, Inc., 2/2/89
+
+;; Added section to 'apollo-clean-help-file()' to remove underlining
+;;   and overstriking (only by the same letter) from Apollo '.hlp' files.
+;;   Based on the 'nuke-nroff-bs' function in man.el.
+;; Changed apollo-mouse-{cut,copy,paste} commands so that they work
+;;   with the DM paste buffer.  This combined with cut,copy,paste
+;;   bindings of the mouse keys allows quick and easy copying from
+;;   Emacs windows to DM windows.
+;; Added 'unbind-apollo-mouse-button' and 'unbind-apollo-function-key'
+;;   commands.
+;; Added 'apollo-mouse-cut-copy-paste' command which provides a
+;;   second set of mouse key functions that can be set with one key
+;;   press and cleared with another key press.  Put default mouse key
+;;   bindings into a command called 'apollo-mouse-defaults' so that
+;;   they can be used to clear any other mouse bindings.
+;; Both these commands affect the DM mouse key bindings as well.
+;; Added 'apollo-mouse-cancel-cut-copy-paste' command which resets the mouse
+;;   key defaults within Emacs and the DM.  The variable
+;;   '*dm-mouse-key-bindings-file*' should be set within an initialization
+;;   file to the pathname of file that executes a user's default DM mouse
+;;   key bindings.
+
+;; Bob Weiner, Motorola, Inc., 2/23/89
+
+;; Added ':' as valid character within a filename (if not at the end)
+;; in the command 'extract-file-name-around-point'.  For remote UNIX
+;; operations such as rcp and rsh commands which use the syntax,
+;; <host>:<path>.
+
+;; Bob Weiner, Motorola, Inc., 3/09/89
+;;
+;; Modified 'apollo-mouse-find-file' and 'apollo-find-file' so that they
+;; recognize buffer names in addition to directory or file paths.  A buffer
+;; name is recognized before a path name, if the match buffer names flag is
+;; enabled.  Added the command 'extract-buf-or-file-name-around-point' to
+; support this functionality.  Added find file in other window option to
+;; these two find-file commands.
+
+;; Bob Weiner, Motorola, Inc., 3/20/89
+
+;; Changed (funcall *apollo-key-bindings-hook*) to (run-hooks
+;; '*apollo-key-bindings-hook*) which is what it should be.
+
+;; Bob Weiner, Motorola, Inc., 4/20/89
+
+;; Rebound M2D button to perform different functions by buffer and location in
+;; buffer.  Executes 'smart-key-mouse' command found in smart-key.el.
+;; Meta-M2D executes 'smart-key-mouse-meta'.  M2U is unbound.
+
+;; Bob Weiner, Motorola, Inc., 8/1/89
+
+;; Fixed 'apollo-mouse-move-point' and 'apollo-mouse-move-mark' so they do
+;; not set the mark gratuitously.  They are bound to M1D and M1U respectively.
+
+;; Bob Weiner, Motorola, Inc., 4/11/90
+
+;; Bound left and right box arrow keys to scroll right and left,
+;; respectively, which most closely emulates their DM functions.
+
+;;; Code:
+
+(defvar *dm-mouse-key-bindings-file* "/sys/dm/std_keys3"
+  "Path of the DM key binding file which sets up a user's default mouse key
+bindings.  If none exists, this value should be set to one of the
+/sys/dm/std_key* files which set up DM key defaults.")
+
+;;; Set this variable in your ".emacs" to a function to call to set up
+;;; additional key bindings.
+;;;
+(defvar *apollo-key-bindings-hook* nil)
+
+;;; Set this variable non-NIL in your ".emacs" to enable preemption of normal
+;;; Display Manager bindings.
+;;;
+(defvar *preempt-display-manager-bindings* nil)
+
+
+
+;;; Determine whether or not we're running diskless and define
+;;; *paste-buffer-directory* to point to the paste buffers directory.
+
+(defvar *paste-buffer-directory*
+  (let ((test-directory (concat "/sys/node_data."
+				(downcase (getenv "NODEID"))
+				"paste_buffers/")))
+    (if (file-directory-p test-directory)
+	test-directory
+	"/sys/node_data/paste_buffers/")))
+
+
+;;; Bind this variable non-NIL to allow apollo-mouse-move-point to leave the
+;;; minibuffer area.
+
+(defvar *apollo-mouse-move-point-allow-minibuffer-exit* nil)
+
+
+;;; Define the Apollo Function Keys.
+
+(defvar *apollo-function-keys*
+  '(("ESC" . 0) ("L1" . 1) ("L2" . 2) ("L3" . 3)
+    ("L1A" . 4) ("L2A" . 5) ("L3A" . 6) ("L4" . 7)
+    ("L5" . 8) ("L6" . 9) ("L7" . 10) ("L8" . 11)
+    ("L9" . 12) ("LA" . 13) ("LB" . 14) ("LC" . 15)
+    ("LD" . 16) ("LE" . 17) ("LF" . 18) ("F0" . 19)
+    ("F1" . 20) ("F2" . 21) ("F3" . 22) ("F4" . 23)
+    ("F5" . 24) ("F6" . 25) ("F7" . 26) ("F8" . 27)
+    ("F9" . 28) ("R1" . 29) ("R2" . 30) ("R3" . 31)
+    ("R4" . 32) ("R5" . 33) ("R6" . 34) ("NP0" . 35)
+    ("NP1" . 36) ("NP2" . 37) ("NP3" . 38) ("NP4" . 39)
+    ("NP5" . 40) ("NP6" . 41) ("NP7" . 42) ("NP8" . 43)
+    ("NP9" . 44) ("NPA" . 45) ("NPB" . 46) ("NPC" . 47)
+    ("NPD" . 48) ("NPE" . 49) ("NPF" . 50) ("NPG" . 51)
+    ("NPP" . 52) ("AL" . 53) ("AR" . 54) ("SHL" . 55)
+    ("SHR" . 56) ("LCK" . 57) ("CTL" . 58) ("RPT" . 59)
+    ("TAB" . 60) ("RET" . 61) ("BS" . 62) ("DEL" . 63)
+    ("ESCS" . 64) ("L1S" . 65) ("L2S" . 66) ("L3S" . 67)
+    ("L1AS" . 68) ("L2AS" . 69) ("L3AS" . 70) ("L4S" . 71)
+    ("L5S" . 72) ("L6S" . 73) ("L7S" . 74) ("L8S" . 75)
+    ("L9S" . 76) ("LAS" . 77) ("LBS" . 78) ("LCS" . 79)
+    ("LDS" . 80) ("LES" . 81) ("LFS" . 82) ("F0S" . 83)
+    ("F1S" . 84) ("F2S" . 85) ("F3S" . 86) ("F4S" . 87)
+    ("F5S" . 88) ("F6S" . 89) ("F7S" . 90) ("F8S" . 91)
+    ("F9S" . 92) ("R1S" . 93) ("R2S" . 94) ("R3S" . 95)
+    ("R4S" . 96) ("R5S" . 97) ("R6S" . 98) ("NP0S" . 99)
+    ("NP1S" . 100) ("NP2S" . 101) ("NP3S" . 102) ("NP4S" . 103)
+    ("NP5S" . 104) ("NP6S" . 105) ("NP7S" . 106) ("NP8S" . 107)
+    ("NP9S" . 108) ("NPAS" . 109) ("NPBS" . 110) ("NPCS" . 111)
+    ("NPDS" . 112) ("NPES" . 113) ("NPFS" . 114) ("NPGS" . 115)
+    ("NPPS" . 116) ("ALS" . 117) ("ARS" . 118) ("SHLS" . 119)
+    ("SHRS" . 120) ("LCKS" . 121) ("CTLS" . 122) ("RPTS" . 123)
+    ("TABS" . 124) ("RETS" . 125) ("BSS" . 126) ("DELS" . 127)
+    ("ESCC" . 128) ("L1C" . 129) ("L2C" . 130) ("L3C" . 131)
+    ("L1AC" . 132) ("L2AC" . 133) ("L3AC" . 134) ("L4C" . 135)
+    ("L5C" . 136) ("L6C" . 137) ("L7C" . 138) ("L8C" . 139)
+    ("L9C" . 140) ("LAC" . 141) ("LBC" . 142) ("LCC" . 143)
+    ("LDC" . 144) ("LEC" . 145) ("LFC" . 146) ("F0C" . 147)
+    ("F1C" . 148) ("F2C" . 149) ("F3C" . 150) ("F4C" . 151)
+    ("F5C" . 152) ("F6C" . 153) ("F7C" . 154) ("F8C" . 155)
+    ("F9C" . 156) ("R1C" . 157) ("R2C" . 158) ("R3C" . 159)
+    ("R4C" . 160) ("R5C" . 161) ("R6C" . 162) ("NP0C" . 163)
+    ("NP1C" . 164) ("NP2C" . 165) ("NP3C" . 166) ("NP4C" . 167)
+    ("NP5C" . 168) ("NP6C" . 169) ("NP7C" . 170) ("NP8C" . 171)
+    ("NP9C" . 172) ("NPAC" . 173) ("NPBC" . 174) ("NPCC" . 175)
+    ("NPDC" . 176) ("NPEC" . 177) ("NPFC" . 178) ("NPGC" . 179)
+    ("NPPC" . 180) ("ALC" . 181) ("ARC" . 182) ("SHLC" . 183)
+    ("SHRC" . 184) ("LCKC" . 185) ("CTLC" . 186) ("RPTC" . 187)
+    ("TABC" . 188) ("RETC" . 189) ("BSC" . 190) ("DELC" . 191)
+    ("ESCU" . 192) ("L1U" . 193) ("L2U" . 194) ("L3U" . 195)
+    ("L1AU" . 196) ("L2AU" . 197) ("L3AU" . 198) ("L4U" . 199)
+    ("L5U" . 200) ("L6U" . 201) ("L7U" . 202) ("L8U" . 203)
+    ("L9U" . 204) ("LAU" . 205) ("LBU" . 206) ("LCU" . 207)
+    ("LDU" . 208) ("LEU" . 209) ("LFU" . 210) ("F0U" . 211)
+    ("F1U" . 212) ("F2U" . 213) ("F3U" . 214) ("F4U" . 215)
+    ("F5U" . 216) ("F6U" . 217) ("F7U" . 218) ("F8U" . 219)
+    ("F9U" . 220) ("R1U" . 221) ("R2U" . 222) ("R3U" . 223)
+    ("R4U" . 224) ("R5U" . 225) ("R6U" . 226) ("NP0U" . 227)
+    ("NP1U" . 228) ("NP2U" . 229) ("NP3U" . 230) ("NP4U" . 231)
+    ("NP5U" . 232) ("NP6U" . 233) ("NP7U" . 234) ("NP8U" . 235)
+    ("NP9U" . 236) ("NPAU" . 237) ("NPBU" . 238) ("NPCU" . 239)
+    ("NPDU" . 240) ("NPEU" . 241) ("NPFU" . 242) ("NPGU" . 243)
+    ("NPPU" . 244) ("ALU" . 245) ("ARU" . 246) ("SHLU" . 247)
+    ("SHRU" . 248) ("LCKU" . 249) ("CTLU" . 250) ("RPTU" . 251)
+    ("TABU" . 252) ("RETU" . 253) ("BSU" . 254) ("DELU" . 255)
+    ("MARK" . "L1") ("LINE_DEL" . "L2") ("CHAR_DEL" . "L3")
+    ("L_BAR_ARROW" . "L4") ("CMD" . "L5") ("R_BAR_ARROW" . "L6")
+    ("L_BOX_ARROW" . "L7") ("UP_ARROW" . "L8") ("R_BOX_ARROW" . "L9")
+    ("LEFT_ARROW" . "LA") ("NEXT_WIN" . "LB") ("RIGHT_ARROW" . "LC")
+    ("UP_BOX_ARROW" . "LD") ("DOWN_ARROW" . "LE") ("DOWN_BOX_ARROW" . "LF")
+    ("COPY" . "L1A") ("PASTE" . "L2A") ("GROW" . "L3A") ("INS_MODE" . "L1S")
+    ("SHELL" . "L5S") ("CUT" . "L1AS") ("UNDO" . "L2AS") ("MOVE" . "L3AS")
+    ("POP" . "R1") ("AGAIN" . "R2") ("READ" . "R3") ("EDIT" . "R4")
+    ("EXIT" . "R5") ("HOLD" . "R6") ("SAVE" . "R4S") ("ABORT" . "R5S")
+    ("UNIXHELP" . "R6S") ("AEGISHELP" . "R6C")))
+
+
+;;; Define the Apollo Mouse Buttons.
+
+(defvar *apollo-mouse-buttons*
+  '(("M1D" . 97) ("M2D" . 98) ("M3D" . 99) ("M4D" . 100)
+    ("M1S" . 33) ("M2S" . 34) ("M3S" . 35) ("M4S" . 36)
+    ("M1C" . 1) ("M2C" . 2) ("M3C" . 3) ("M4C" . 4)
+    ("M1U" . 65) ("M2U" . 66) ("M3U" . 67) ("M4U" . 68)))
+
+
+;;; Define functions to simplify making function key and mouse button bindings.
+
+(defun bind-apollo-function-key (function-key binding &optional meta-binding)
+  "Enable an Apollo Function Key and assign a binding to it."
+  (interactive "sFunction Key: \nCCommand: \nCMeta Command: ")
+  (let ((numeric-code (cdr (assoc function-key *apollo-function-keys*))))
+    (if (null numeric-code)
+	(error "%s is not a legal Apollo Function Key name" function-key))
+    (if (stringp numeric-code)
+	(setq numeric-code
+	      (cdr (assoc numeric-code *apollo-function-keys*))))
+    (enable-apollo-function-key numeric-code)
+    (let ((normal-sequence
+	   (concat (char-to-string (logior 72 (lsh numeric-code -6)))
+		   (char-to-string (logior 64 (logand numeric-code 63)))))
+	  (meta-sequence
+	   (concat (char-to-string (logior 76 (lsh numeric-code -6)))
+		   (char-to-string (logior 64 (logand numeric-code 63))))))
+      (define-key 'apollo-prefix normal-sequence binding)
+      (define-key 'apollo-prefix meta-sequence (or meta-binding binding)))))
+
+(defun unbind-apollo-function-key (function-key)
+  "Disable an Apollo Function Key and return control of it to the DM."
+  (interactive "sFunction key: ")
+  (let ((numeric-code (cdr (assoc function-key *apollo-function-keys*))))
+    (if (null numeric-code)
+	(error "%s is not a legal Apollo Function Key name" function-key))
+    (if (stringp numeric-code)
+	(setq numeric-code
+	      (cdr (assoc numeric-code *apollo-function-keys*))))
+    (disable-apollo-function-key numeric-code)))
+
+(defun select-apollo-meta-key (meta-key)
+  "Select the Function Key used as the Meta Key."
+  (interactive "sMeta Key: ")
+  (let ((numeric-code (cdr (assoc meta-key *apollo-function-keys*))))
+    (if (null numeric-code)
+	(error "%s is not a legal Apollo Function Key name" meta-key))
+    (if (stringp numeric-code)
+	(setq numeric-code
+	      (cdr (assoc numeric-code *apollo-function-keys*))))
+    (set-apollo-meta-key numeric-code)))
+
+(defun bind-apollo-mouse-button (mouse-button binding &optional meta-binding)
+  "Enable an Apollo Mouse Button and assign a binding to it."
+  (interactive "sMouse Button: \nCCommand: \nCMeta Command: ")
+  (let ((numeric-code (cdr (assoc mouse-button *apollo-mouse-buttons*))))
+    (if (null numeric-code)
+	(error "%s is not a legal Apollo Mouse Button name" mouse-button))
+    (enable-apollo-mouse-button numeric-code)
+    (let ((normal-sequence (char-to-string numeric-code))
+	  (meta-sequence (char-to-string (+ numeric-code 16))))
+      (define-key 'apollo-prefix normal-sequence binding)
+      (define-key 'apollo-prefix meta-sequence (or meta-binding binding)))))
+
+(defun unbind-apollo-mouse-button (mouse-button)
+  "Disable an Apollo Mouse Button and return control of it to the DM."
+  (interactive "sMouse Button: ")
+  (let ((numeric-code (cdr (assoc mouse-button *apollo-mouse-buttons*))))
+    (if (null numeric-code)
+	(error "%s is not a legal Apollo Mouse Button name" mouse-button))
+    (disable-apollo-mouse-button numeric-code)))
+
+
+;;; Initialize the Apollo Keymaps.
+
+(define-prefix-command 'apollo-prefix)
+(global-set-key "\C-^" 'apollo-prefix)
+(define-prefix-command 'apollo-prefix-1)
+(define-prefix-command 'apollo-prefix-2)
+(define-prefix-command 'apollo-prefix-3)
+(define-prefix-command 'apollo-prefix-4)
+(define-prefix-command 'apollo-prefix-5)
+(define-prefix-command 'apollo-prefix-6)
+(define-prefix-command 'apollo-prefix-7)
+(define-prefix-command 'apollo-prefix-8)
+(define-key 'apollo-prefix "H" 'apollo-prefix-1)
+(define-key 'apollo-prefix "I" 'apollo-prefix-2)
+(define-key 'apollo-prefix "J" 'apollo-prefix-3)
+(define-key 'apollo-prefix "K" 'apollo-prefix-4)
+(define-key 'apollo-prefix "L" 'apollo-prefix-5)
+(define-key 'apollo-prefix "M" 'apollo-prefix-6)
+(define-key 'apollo-prefix "N" 'apollo-prefix-7)
+(define-key 'apollo-prefix "O" 'apollo-prefix-8)
+
+
+;;; Commands to COPY, CUT, and PASTE.
+
+(defun apollo-copy-region ()
+  "Copy region between point and mark to the default DM paste buffer."
+  (interactive)
+  (write-region-to-default-apollo-paste-buffer (mark) (point))
+  (message "Region Copied"))
+
+(defun apollo-cut-region ()
+  "Copy region between point and mark to the default DM paste buffer."
+  (interactive)
+  (write-region-to-default-apollo-paste-buffer (mark) (point))
+  (kill-region (mark) (point))
+  (message "Region Cut"))
+
+(defun apollo-paste ()
+  "Copy region between point and mark to the default DM paste buffer."
+  (interactive)
+  (let ((x (insert-contents-of-default-apollo-paste-buffer)))
+    (push-mark (+ (point) x)))
+  (message "Pasted and Mark set"))
+
+
+;;; Miscellaneous Commands.
+
+(defun minibuffer-prompt-length ()
+  "Returns the length of the current minibuffer prompt."
+  (let ((window (selected-window))
+	length)
+    (select-window (minibuffer-window))
+    (let ((point (point)))
+      (goto-char (point-min))
+      (insert-char ?a 200)
+      (goto-char (point-min))
+      (vertical-motion 1)
+      (setq length (- (frame-width) (point)))
+      (goto-char (point-min))
+      (delete-char 200)
+      (goto-char point))
+    (select-window window)
+    length))
+
+(defun extract-file-or-buffer-name-around-point (&optional buffer-flag)
+  (let ((skip-characters (if buffer-flag
+			     "!#-%*-9=?-{}~:<>"
+			     "!#-%*-9=?-{}~:"))
+	(skip-at-end (if buffer-flag
+			 '(?@ ?. ?, ?: ?<)
+			 '(?* ?@ ?. ?, ?:))))
+    (save-excursion
+      (skip-chars-backward skip-characters)
+      (let ((start (point)))
+	(skip-chars-forward skip-characters)
+	(let* ((filename (buffer-substring start (point)))
+	       (last-char (aref filename (- (length filename) 1))))
+	  (if (memq last-char skip-at-end)
+	      (substring filename 0 -1)
+	      filename))))))
+(fset 'extract-file-name-around-point
+      'extract-file-or-buffer-name-around-point)
+(fset 'extract-buf-or-file-name-around-point
+      'extract-file-or-buffer-name-around-point)
+
+(defun apollo-find-file (&optional find-buffer-flag other-window)
+  "Find the file or buffer whose name the cursor is over.  Buffer names are
+matched only if the optional argument FIND-BUFFER-FLAG is non-NIL.  If the
+optional argument OTHER-WINDOW is non-NIL, the file is displayed in the other
+window.  When matching file names, ignores trailing '*' or '@' as in 'ls -F'
+output."
+  (interactive)
+  (let* ((file-or-buffer-name
+	  (extract-file-or-buffer-name-around-point find-buffer-flag))
+	 (buffer (and find-buffer-flag (get-buffer file-or-buffer-name))))
+    (if (or buffer (file-exists-p file-or-buffer-name))
+	(funcall (if other-window
+		     'switch-to-buffer-other-window
+		     'switch-to-buffer)
+		 (or buffer (find-file-noselect file-or-buffer-name)))
+	(error "Cannot find %s \"%s\""
+	       (if find-buffer-flag "buffer or file" "file")
+	       file-or-buffer-name))))
+
+(defun apollo-grow-emacs-window ()
+  "Grow Emacs's Apollo window with rubberbanding."
+  (interactive)
+  (execute-dm-command "WGE"))
+
+(defun apollo-move-emacs-window ()
+  "Move Emacs's Apollo window with rubberbanding."
+  (interactive)
+  (execute-dm-command "WME"))
+
+(defun apollo-again ()
+  "Copy the remainder of the current line to the end of the buffer."
+  (interactive)
+  (set-mark-command nil)
+  (end-of-line)
+  (copy-region-as-kill (mark) (point))
+  (end-of-buffer)
+  (yank))
+
+(defun apollo-exit ()
+  "Kill current buffer after saving changes."
+  (interactive)
+  (save-buffer)
+  (kill-buffer (current-buffer)))
+
+(defun apollo-abort ()
+  "Kill current buffer without saving changes."
+  (interactive)
+  (kill-buffer (current-buffer)))
+
+(defun apollo-aegis-help (filename)
+  "Prompt for topic and find the Apollo help file."
+  (interactive "sHelp on: ")
+  (let ((help-file (concat "/sys/help/" filename ".hlp")))
+    (with-output-to-temp-buffer "*Help File*"
+      (buffer-disable-undo standard-output)
+      (save-excursion
+	(set-buffer standard-output)
+	(insert-man-file help-file)
+	(if (> (buffer-size) 0)
+	    (progn
+	      (message "Cleaning help file entry...")
+	      (apollo-clean-help-file)
+	      (message ""))
+	    (message "No help found in %s" help-file))
+	(set-buffer-modified-p nil)))))
+(fset 'apollo-help 'apollo-aegis-help)
+
+;;; Make sure this will be loaded if necessary.
+
+(autoload 'insert-man-file "man")
+
+(defun apollo-clean-help-file ()
+  (interactive "*")
+  ;; Remove underlining and overstriking by the same letter.
+  (goto-char (point-min))
+  (while (search-forward "\b" nil t)
+    (let ((preceding (char-after (- (point) 2)))
+	  (following (following-char)))
+      (cond ((= preceding following)	; x\bx
+	     (delete-char -2))
+	    ((= preceding ?\_)		; _\b
+	     (delete-char -2))
+	    ((= following ?\_)		; \b_
+	     (delete-region (1- (point)) (1+ (point)))))))
+  ;; Remove overstriking and carriage returns before newline.
+  (goto-char (point-min))
+  (while (re-search-forward "\r$" nil t)
+    (replace-match ""))
+  (goto-char (point-min))
+  (while (re-search-forward "^.*\r" nil t)
+    (replace-match ""))
+  ;; Fit in 79 cols rather than 80.
+  (indent-rigidly (point-min) (point-max) -1)
+  ;; Delete excess multiple blank lines.
+  (goto-char (point-min))
+  (while (re-search-forward "\n\n\n\n*" nil t)
+    (replace-match "\n\n"))
+  ;; Remove blank lines at the beginning.
+  (goto-char (point-min))
+  (skip-chars-forward "\n")
+  (delete-region (point-min) (point))
+  ;; Separate the header from the main subject line.
+  (end-of-line)
+  (insert "\n")
+  (goto-char (point-min)))
+
+(defun kill-whole-line ()
+  "Kill the line containing point.  Try to retain column cursor is on."
+  (interactive)
+  (let ((old-column (current-column)))
+    (beginning-of-line)
+    (kill-line 1)
+    (move-to-column old-column)))
+
+(defun apollo-key-undefined ()
+  "Signal that an Apollo Function Key is undefined."
+  (interactive)
+  (error "Apollo Function Key undefined"))
+
+
+;;; Define the mouse commands.
+
+(defun apollo-mouse-move-point (&optional no-mark)
+  "Used so that pressing the left mouse button, moving the cursor, and
+releasing the left mouse button leaves the mark set to the initial position
+and the point set to the final position.  Useful for easily marking regions
+of text.  If the left mouse button is pressed and released at the same place,
+the mark is left at the original position of the character cursor.
+
+Returns (x y) frame coordinates of point in columns and lines."
+  (interactive)
+  (let* ((opoint (point))
+	 (owindow (selected-window))
+	 (x (- (read-char) 8))
+	 (y (- (read-char) 8))
+	 (edges (window-edges))
+	 (window nil))
+    (while (and (not (eq window (selected-window)))
+		(or (<  y (nth 1 edges))
+		    (>= y (nth 3 edges))
+		    (<  x (nth 0 edges))
+		    (>= x (nth 2 edges))))
+      (setq window (next-window window))
+      (setq edges (window-edges window)))
+    (if (and window (not (eq window (selected-window))))
+	(progn
+	  (if (and (not *apollo-mouse-move-point-allow-minibuffer-exit*)
+		   (eq (selected-window) (minibuffer-window)))
+	      (error "Cannot use mouse to leave minibuffer!"))
+	  (if (eq window (minibuffer-window))
+	      (error "Cannot use mouse to enter minibuffer!"))))
+    (if window (select-window window))
+    (move-to-window-line (- y (nth 1 edges)))
+    (let* ((width-1 (1- (window-width window)))
+	   (wraps (/ (current-column) width-1))
+	   (prompt-length (if (eq (selected-window) (minibuffer-window))
+			      (minibuffer-prompt-length)
+			    0)))
+      (move-to-column (+ (- x (nth 0 edges) prompt-length)
+			 (* wraps width-1))))
+    (if no-mark
+	(progn (setq window (selected-window))
+	       (if (eq owindow window)
+		   (if (equal opoint (point))
+		       (pop-mark))
+		 (select-window owindow)
+		 (pop-mark)
+		 (select-window window)))
+      (set-mark-command nil))
+    ;; Return (x y) coords of point in column and frame line numbers.
+    (list x y)))
+
+(defun apollo-mouse-move-mark ()
+  "Used so that pressing the left mouse button, moving the cursor, and
+releasing the left mouse button leaves the mark set to the initial position
+and the point set to the final position.  Useful for easily marking regions
+of text.  If the left mouse button is pressed and released at the same place,
+the mark is left at the original position of the character cursor."
+  (interactive)
+  (apollo-mouse-move-point)
+  (if (equal (point) (mark))
+      (pop-mark)))
+
+(defun apollo-mouse-cut ()
+  "Move point to the location of the mouse cursor and
+cut the region to the default DM paste buffer."
+  (interactive)
+  (apollo-mouse-move-mark)
+  (apollo-cut-region))
+
+(defun apollo-mouse-copy ()
+  "Move point to the location of the mouse cursor and
+copy the region to the default DM paste buffer."
+  (interactive)
+  (apollo-mouse-move-mark)
+  (apollo-copy-region))
+
+(defun apollo-mouse-paste ()
+  "Move point to the location of the mouse cursor and
+paste in the default DM paste buffer."
+  (interactive)
+  (apollo-mouse-move-point)
+  (apollo-paste))
+
+(defun apollo-mouse-pop-buffer ()
+  "Used in conjunction with the 'list-buffers' command, moves
+point to cursor location and displays buffer named on current line.
+Similar to a DM pop window by name to top."
+  (interactive)
+  (apollo-mouse-move-point)
+  (Buffer-menu-select))
+
+(defun apollo-mouse-find-file ()
+  "Find the file or buffer whose name the cursor is over.  Buffers are only
+allowed when in the '*Buffer List*' buffer.  When matching file names, ignores
+trailing '*' or '@' as in 'ls -F' output."
+  (interactive)
+  (apollo-mouse-move-point)
+  (let ((find-buffer-flag
+	 (equal (buffer-name (current-buffer)) "*Buffer List*")))
+    (apollo-find-file find-buffer-flag nil)))
+
+(defun apollo-mouse-find-file-other-window ()
+  "Find the file or buffer whose name the cursor is over.  Buffers are only
+allowed when in the '*Buffer List*' buffer.  When matching file names, ignores
+trailing '*' or '@' as in 'ls -F' output.  The file or buffer is displayed in
+the other window."
+  (interactive)
+  (apollo-mouse-move-point)
+  (let ((find-buffer-flag
+	 (equal (buffer-name (current-buffer)) "*Buffer List*")))
+    (apollo-find-file find-buffer-flag t))
+  (other-window 1))
+
+
+;;; Define and Enable the Mouse Key Bindings.
+
+(defun apollo-mouse-defaults ()
+"Set up default Apollo mouse key bindings for GNU Emacs."
+  (interactive)
+  (bind-apollo-mouse-button "M1D" 'apollo-mouse-move-point
+			    'apollo-mouse-move-point) ;MOUSE LEFT DOWN
+  (bind-apollo-mouse-button "M1U" 'apollo-mouse-move-mark
+			    'apollo-mouse-copy) ;MOUSE LEFT UP 
+  (bind-apollo-mouse-button "M2D" 'sm-depress
+			    'sm-depress-meta) ;MOUSE MIDDLE DOWN
+  (bind-apollo-mouse-button "M2U" 'smart-key-mouse
+			    'smart-key-mouse-meta) ;MOUSE MIDDLE UP
+  (bind-apollo-mouse-button "M3D" 'sm-depress-meta) ;MOUSE RIGHT DOWN
+  (bind-apollo-mouse-button "M3U" 'smart-key-mouse-meta) ;MOUSE RIGHT UP
+)
+(apollo-mouse-defaults)
+
+(defun apollo-mouse-cut-copy-paste ()
+  "Sets Apollo mouse keys to perform DM-style cut, copy, and paste.
+LEFT MOUSE DOWN moves point to cursor location.  LEFT MOUSE UP sets
+mark, moves point to cursor location and cuts region.  MID MOUSE works
+the same way but does a copy.  RIGHT MOUSE sets point and pastes at
+cursor location.  These key bindings are also effective in DM windows
+until \\[apollo-mouse-cancel-cut-copy-paste] is executed in the GNU Emacs DM
+window."
+  (interactive)
+  (bind-apollo-mouse-button "M1D" 'apollo-mouse-move-point) ;MOUSE LEFT DOWN
+  (bind-apollo-mouse-button "M1U" 'apollo-mouse-cut) ;MOUSE LEFT UP
+  (bind-apollo-mouse-button "M2D" 'apollo-mouse-move-point) ;MOUSE MIDDLE DOWN
+  (bind-apollo-mouse-button "M2U" 'apollo-mouse-copy) ;MOUSE MIDDLE UP
+  (bind-apollo-mouse-button "M3D" 'apollo-mouse-paste) ;MOUSE RIGHT DOWN
+  (unbind-apollo-mouse-button "M3U") ;MOUSE RIGHT UP
+  (message "Mouse Edit Mode: left=cut, mid=copy, right=paste")
+  (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")
+)
+
+(defun apollo-mouse-cancel-cut-copy-paste ()
+  "Sets Apollo mouse keys back to defaults with GNU Emacs and personal
+settings within the DM."
+  (interactive)
+  (apollo-mouse-defaults)
+  (message "Default mouse key bindings set")
+  (execute-dm-command
+    (concat "msg 'Mouse Edit Mode canceled; personal mouse keys restored';"
+	    "cmdf " *dm-mouse-key-bindings-file*))
+)
+
+;;; Define and Enable the Function Key Bindings.
+
+(bind-apollo-function-key "TABS" "\C-I") ;Shift TAB
+(bind-apollo-function-key "TABC" "\C-I") ;Control TAB
+(bind-apollo-function-key "RETS" "\C-M") ;Shift RET
+(bind-apollo-function-key "RETC" "\C-M") ;Control RET
+(bind-apollo-function-key "LINE_DEL" 'kill-whole-line) ;LINE DEL
+(bind-apollo-function-key "CHAR_DEL" "\C-D") ;CHAR DEL
+(bind-apollo-function-key "L_BAR_ARROW" "\C-A") ;LEFT BAR ARROW
+(bind-apollo-function-key "R_BAR_ARROW" "\C-E") ;RIGHT BAR ARROW
+(bind-apollo-function-key "L_BOX_ARROW" "\C-x>") ;LEFT BOX ARROW
+(bind-apollo-function-key "UP_ARROW" "\C-P") ;UP ARROW
+(bind-apollo-function-key "L8S" "\M-1\M-V") ;Shift UP ARROW
+
+;;; RIGHT BOX ARROW is the Default Meta Key.  If the Meta Key is changed with
+;;; SELECT-APOLLO-META-KEY, then RIGHT BOX ARROW signals an error.
+
+(select-apollo-meta-key "R1") ; Make POP the META key instead.
+(bind-apollo-function-key "R_BOX_ARROW" "\C-x<") ;RIGHT BOX ARROW
+(bind-apollo-function-key "LEFT_ARROW" "\C-B") ;LEFT ARROW
+(bind-apollo-function-key "RIGHT_ARROW" "\C-F") ;RIGHT ARROW
+(bind-apollo-function-key "DOWN_ARROW" "\C-N") ;DOWN ARROW
+(bind-apollo-function-key "LES" "\M-1\C-V") ;Shift DOWN ARROW
+(bind-apollo-function-key "R3S" 'apollo-find-file) ;Shift READ
+(bind-apollo-function-key "MARK" 'set-mark-command) ;MARK
+(bind-apollo-function-key "INS_MODE" 'overwrite-mode) ;INS MODE
+(bind-apollo-function-key "L2S" "\C-Y")	;Shift LINE DEL
+(bind-apollo-function-key "L3S" "\C-D")	;Shift CHAR DEL
+(bind-apollo-function-key "COPY" 'apollo-copy-region) ;COPY
+(bind-apollo-function-key "CUT" 'apollo-cut-region) ;CUT
+(bind-apollo-function-key "PASTE" 'apollo-paste) ;PASTE
+(bind-apollo-function-key "UNDO" 'undo) ;UNDO
+(bind-apollo-function-key "GROW" 'apollo-grow-emacs-window) ;GROW
+(bind-apollo-function-key "MOVE" 'apollo-move-emacs-window) ;MOVE
+(bind-apollo-function-key "LAS" "\M-B") ;Shift LEFT ARROW
+(bind-apollo-function-key "LCS" "\M-F") ;Shift RIGHT ARROW
+(bind-apollo-function-key "UP_BOX_ARROW" "\M-V") ;UP BOX ARROW
+(bind-apollo-function-key "LDS" "\M-<") ;Shift UP BOX ARROW
+(bind-apollo-function-key "DOWN_BOX_ARROW" "\C-V") ;DOWN BOX ARROW
+(bind-apollo-function-key "LFS" "\M->") ;Shift DOWN BOX ARROW
+(bind-apollo-function-key "AGAIN" 'apollo-again) ;AGAIN
+(bind-apollo-function-key "EXIT" 'apollo-exit) ;EXIT
+(bind-apollo-function-key "ABORT" 'apollo-abort) ;ABORT
+(bind-apollo-function-key "SAVE" 'save-buffer) ;SAVE
+(bind-apollo-function-key "HOLD" 'apollo-key-undefined) ;HOLD
+
+(defun install-apollo-dm-preemptive-key-bindings ()
+  (bind-apollo-function-key "L4S" "\M-<") ;Shift LEFT BAR ARROW
+  (bind-apollo-function-key "L5" 'execute-dm-command) ;CMD
+  (bind-apollo-function-key "L6S" "\M->") ;Shift RIGHT BAR ARROW
+  (bind-apollo-function-key "LB" 'other-window) ;NEXT WNDW
+  (bind-apollo-function-key "LBS" 'delete-window) ;Shift NEXT WNDW
+  (bind-apollo-function-key "READ" 'find-file-read-only) ;READ
+  (bind-apollo-function-key "EDIT" 'find-file) ;EDIT
+  (bind-apollo-function-key "SHELL" 'shell) ;SHELL
+  (bind-apollo-function-key "UNIXHELP" 'manual-entry) ;HELP
+  (bind-apollo-function-key "AEGISHELP" 'apollo-aegis-help)) ;HELP
+
+(if *preempt-display-manager-bindings*
+    (install-apollo-dm-preemptive-key-bindings))
+
+(run-hooks '*apollo-key-bindings-hook*)
+
+(provide 'apollo)
+
+;;; apollo.el ends here