home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / gnu / lucid / lemacs-19.6 / lisp / emulators / tpu-edt.el < prev    next >
Encoding:
Text File  |  1992-10-28  |  67.7 KB  |  1,962 lines

  1. ;;;  TPU-edt by Rob Riepel - Emacs emulating TPU emulating EDT
  2. ;;;
  3. ;;;      Based on tpu.el by Jeff Kowalski (November, 1988)
  4. ;;;
  5.  
  6. ;; Copyright (C) 1992 Rob Riepel.
  7.  
  8. ;; GNU Emacs is distributed in the hope that it will be useful,
  9. ;; but WITHOUT ANY WARRANTY.  No author or distributor
  10. ;; accepts responsibility to anyone for the consequences of using it
  11. ;; or for whether it serves any particular purpose or works at all,
  12. ;; unless he says so in writing.  Refer to the GNU Emacs General Public
  13. ;; License for full details.
  14.  
  15. ;; Everyone is granted permission to copy, modify and redistribute
  16. ;; GNU Emacs, but only under the conditions described in the
  17. ;; GNU Emacs General Public License.   A copy of this license is
  18. ;; supposed to have been given to you along with GNU Emacs so you
  19. ;; can know your rights and responsibilities.  It should be in a
  20. ;; file named COPYING.  Among other things, the copyright notice
  21. ;; and this notice must be preserved on all copies.
  22. ;;
  23.  
  24.  
  25. ;;;
  26. ;;;
  27. ;;;  Revision Information
  28. ;;;
  29. ;;;
  30. (defconst tpu-revision "-Revision: 4.8 -"
  31.   "Revision number of TPU-edt.")
  32. (defconst tpu-revision-date "-Date: 1992/06/24 21:16:18 -"
  33.   "Date current revision of TPU-edt was created.")
  34.  
  35.  
  36. ;;;
  37. ;;;
  38. ;;;  User Configurable Variables
  39. ;;;
  40. ;;;
  41. (defconst tpu-have-ispell t
  42.   "*If non-nil (default), TPU-edt uses ispell for spell checking.")
  43.  
  44. (defconst tpu-kill-buffers-silently nil
  45.   "*If non-nil, TPU-edt kills modified buffers without asking.")
  46.  
  47. (defvar tpu-percent-scroll 75
  48.   "*Percentage of the screen to scroll for next/previous screen commands.")
  49.  
  50.  
  51. ;;;
  52. ;;;
  53. ;;;  G L O B A L
  54. ;;;  K E Y M A P S
  55. ;;;
  56. ;;;
  57. ;;;;; (defvar CSI-map nil
  58. ;;;;;   "Maps the CSI function keys on the VT100 keyboard.
  59. ;;;;; CSI is DEC's name for the sequence <ESC>[.")
  60. ;;;;; (setq CSI-map (make-sparse-keymap))
  61.  
  62. ;;;;; (defvar SS3-map nil
  63. ;;;;;   "Maps the SS3 function keys on the VT100 keyboard.
  64. ;;;;; SS3 is DEC's name for the sequence <ESC>O.")
  65. ;;;;; (setq SS3-map (make-sparse-keymap))
  66.  
  67. ;;;;; (defvar GOLD-map nil
  68. ;;;;;    "Maps the function keys on the VT100 keyboard preceeded by PF1.
  69. ;;;;; GOLD is the ASCII 7-bit escape sequence <ESC>OP.")
  70. ;;;;; (setq GOLD-map (make-sparse-keymap))
  71.  
  72. ;;;;; (defvar GOLD-CSI-map nil
  73. ;;;;;    "Maps the function keys on the VT100 keyboard preceeded by GOLD-CSI.")
  74. ;;;;; (setq GOLD-CSI-map (make-sparse-keymap))
  75.  
  76. ;;;;; (defvar GOLD-SS3-map nil
  77. ;;;;;    "Maps the function keys on the VT100 keyboard preceeded by GOLD-SS3.")
  78. ;;;;; (setq GOLD-SS3-map (make-sparse-keymap))
  79.  
  80.  
  81. ;;;
  82. ;;;
  83. ;;;  G L O B A L
  84. ;;;  V A R I A B L E S
  85. ;;;
  86. ;;;
  87. (defvar tpu-global-key-plist nil
  88.   "Original emacs definitions of global keys, so they may be restored.")
  89. (defvar tpu-breadcrumb-plist nil
  90.   "The set of user-defined markers (breadcrumbs), as a plist.")
  91. (defvar tpu-counter 0
  92.   "A general-purpose counter available for the user.")
  93. (defvar tpu-counter-format "%d"
  94.   "The format to use to when displaying the tpu-counter.")
  95. (defvar tpu-last-replaced-text ""
  96.   "Last text deleted by a TPU-edt replace command.")
  97. (defvar tpu-last-deleted-region ""
  98.   "Last text deleted by a TPU-edt remove command.")
  99. (defvar tpu-last-deleted-lines ""
  100.   "Last text deleted by a TPU-edt line-delete command.")
  101. (defvar tpu-last-deleted-words ""
  102.   "Last text deleted by a TPU-edt word-delete command.")
  103. (defvar tpu-last-deleted-char ""
  104.   "Last character deleted by a TPU-edt character-delete command.")
  105. (defvar tpu-search-last-string ""
  106.   "Last text searched for by the TPU-edt search commands.")
  107. (defvar tpu-regexp-p nil
  108.   "If non-nil, TPU-edt uses regexp search and replace routines.")
  109. (defvar tpu-rectangular-p nil
  110.   "If non-nil, TPU-edt removes and inserts rectangles.")
  111. (defvar tpu-advance t
  112.   "True when TPU-edt is operating in the forward direction.")
  113. (defvar tpu-reverse nil
  114.   "True when TPU-edt is operating in the backward direction.")
  115. (defvar tpu-rectangle-string nil
  116.   "Mode line string to identify rectangular mode.")
  117.  
  118.  
  119. ;;;
  120. ;;;
  121. ;;;  L O C A L
  122. ;;;  V A R I A B L E S
  123. ;;;
  124. ;;;
  125. (defvar newline-and-indent-p nil
  126.   "If non-nil, Return produces a newline and indents.")
  127. (make-variable-buffer-local 'newline-and-indent-p)
  128.  
  129. (defvar tpu-saved-delete-func nil
  130.   "Saved value of the delete key.")
  131. (make-variable-buffer-local 'tpu-saved-delete-func)
  132.  
  133. (defvar tpu-buffer-local-map nil
  134.   "TPU-edt buffer local key map.")
  135. (make-variable-buffer-local 'tpu-buffer-local-map)
  136.  
  137.  
  138. ;;;
  139. ;;;
  140. ;;;  Modify the the mode line to show if the mark is set.
  141. ;;;
  142. ;;;
  143. (defvar tpu-mark-flag " ")
  144.  
  145. (make-variable-buffer-local 'tpu-mark-flag)
  146.  
  147. (setq-default mode-line-format
  148.   (list (purecopy "")
  149.    'mode-line-modified
  150.    'mode-line-buffer-identification
  151.    (purecopy "  ")
  152.    'global-mode-string
  153.    (purecopy "  ")
  154.    'tpu-mark-flag
  155.    (purecopy " %[(")
  156.    'mode-name 'minor-mode-alist "%n" 'mode-line-process
  157.    (purecopy ")%]----")
  158.    (purecopy '(-3 . "%p"))
  159.    (purecopy "-%-")))
  160.  
  161.  
  162. ;;;
  163. ;;;
  164. ;;;  Match markers -
  165. ;;;
  166. ;;;     Set in:  Search
  167. ;;;
  168. ;;;     Used in: Replace, Substitute, Store-Text, Cut/Remove,
  169. ;;;              Append, and Change-Case
  170. ;;;
  171. ;;;
  172. (setq tpu-match-beginning-mark (make-marker))
  173. (setq tpu-match-end-mark (make-marker))
  174.  
  175. (defun tpu-set-match nil
  176.   "Set markers at match beginning and end."
  177.   ;; Add one to beginning mark so it stays with the first character of
  178.   ;;   the string even if characters are added just before the string.
  179.   (setq tpu-match-beginning-mark (copy-marker (1+ (match-beginning 0))))
  180.   (setq tpu-match-end-mark (copy-marker (match-end 0))))
  181.  
  182. (defun tpu-unset-match nil
  183.   "Unset match beginning and end markers."
  184.   (set-marker tpu-match-beginning-mark nil)
  185.   (set-marker tpu-match-end-mark nil))
  186.  
  187. (defun tpu-match-beginning nil
  188.   "Returns the location of the last match beginning."
  189.   (1- (marker-position tpu-match-beginning-mark)))
  190.  
  191. (defun tpu-match-end nil
  192.   "Returns the location of the last match end."
  193.   (marker-position tpu-match-end-mark))
  194.  
  195. (defun tpu-check-match nil
  196.   "Returns t if point is between tpu-match markers.
  197. Otherwise sets the tpu-match markers to nil and returns nil."
  198.   ;; make sure 1- marker is in this buffer
  199.   ;;           2- point is at or after beginning marker
  200.   ;;           3- point is before ending marker, or in the case of
  201.   ;;              zero length regions (like bol, or eol) that the
  202.   ;;              beginning, end, and point are equal.
  203.   (cond ((and
  204.           (equal (marker-buffer tpu-match-beginning-mark) (current-buffer))
  205.           (>= (point) (1- (marker-position tpu-match-beginning-mark)))
  206.           (or
  207.            (< (point) (marker-position tpu-match-end-mark))
  208.            (and (= (1- (marker-position tpu-match-beginning-mark))
  209.                    (marker-position tpu-match-end-mark))
  210.                 (= (marker-position tpu-match-end-mark) (point))))) t)
  211.         (t
  212.          (tpu-unset-match) nil)))
  213.  
  214. (defun tpu-show-match-markers nil
  215.   "Show the values of the match markers."
  216.   (interactive)
  217.   (if (markerp tpu-match-beginning-mark)
  218.       (let ((beg (marker-position tpu-match-beginning-mark)))
  219.         (message "(%s, %s) in %s -- current %s in %s"
  220.                  (if beg (1- beg) nil)
  221.                  (marker-position tpu-match-end-mark)
  222.                  (marker-buffer tpu-match-end-mark)
  223.                  (point) (current-buffer)))))
  224.  
  225.  
  226. ;;;
  227. ;;;
  228. ;;;  U T I L I T I E S
  229. ;;;
  230. ;;;
  231. (defun caar (thingy) (car (car thingy)))
  232. (defun cadr (thingy) (car (cdr thingy)))
  233. (defun cadar (thingy) (car (cdr (car thingy))))
  234. (defun caddar (thingy) (car (cdr (cdr (car thingy)))))
  235.  
  236. (defun tpu-y-or-n-p (prompt &optional not-yes)
  237.   "Prompt for a y or n answer with positive default.
  238. Optional second argument NOT-YES changes default to negative.
  239. Like emacs y-or-n-p, also accepts space as y and DEL as n."
  240.   (message (format "%s[%s]" prompt (if not-yes "n" "y")))
  241.   (let ((doit t))
  242.     (while doit
  243.       (setq doit nil)
  244.       (let ((ans (read-char)))
  245.         (cond ((or (= ans ?y) (= ans ?Y) (= ans ?\ ))
  246.                (setq tpu-last-answer t))
  247.               ((or (= ans ?n) (= ans ?N) (= ans ?\C-?))
  248.                (setq tpu-last-answer nil))
  249.               ((= ans ?\r) (setq tpu-last-answer (not not-yes)))
  250.               (t
  251.                (setq doit t) (beep)
  252.                (message (format "Please answer y or n.  %s[%s]"
  253.                                 prompt (if not-yes "n" "y"))))))))
  254.   (message "")                ; Clear minibuffer
  255.   tpu-last-answer)
  256.  
  257.  
  258. ;;;
  259. ;;;  Breadcrumbs
  260. ;;;
  261. (defun drop-breadcrumb (num)
  262.   "Drops a breadcrumb that can be returned to later with goto-breadcrumb."
  263.   (interactive "p")
  264.   (put tpu-breadcrumb-plist num (list (current-buffer) (point)))
  265.   (message "Mark %d set." num))
  266.  
  267. (defun goto-breadcrumb (num)
  268.   "Returns to a breadcrumb set with drop-breadcrumb."
  269.   (interactive "p")
  270.   (cond ((get tpu-breadcrumb-plist num)
  271.          (switch-to-buffer (car (get tpu-breadcrumb-plist num)))
  272.          (goto-char (cadr (get tpu-breadcrumb-plist num)))
  273.          (message "mark %d found." num))
  274.         (t
  275.          (message "mark %d not found." num))))
  276.  
  277.  
  278. ;;;
  279. ;;;  miscellaneous
  280. ;;;
  281. (defun replace-global-key (key func)
  282.   "Saves the current global key definition and replaces it with a new one."
  283.   (interactive)
  284.   (if (not (get tpu-global-key-plist key))
  285.       (put tpu-global-key-plist key func))
  286.   (global-set-key key func))
  287.  
  288. (defun restore-global-key (key)
  289.   "Restores the original definition of a global key."
  290.   (interactive)
  291.   (global-set-key key (get tpu-global-key-plist key)))
  292.  
  293. (defun tpu-local-set-key (key func)
  294.   "Replace a key in the TPU-edt local key map.
  295. Create the key map if necessary."
  296.   (cond ((not (keymapp tpu-buffer-local-map))
  297.          (setq tpu-buffer-local-map (if (current-local-map)
  298.                                         (copy-keymap (current-local-map))
  299.                                       (make-sparse-keymap)))
  300.          (use-local-map tpu-buffer-local-map)))
  301.   (local-set-key key func))
  302.  
  303. (defun current-line nil
  304.   "Return the vertical position of point in the selected window.
  305. Top line is 0.  Counts each text line only once, even if it wraps."
  306.   (+ (count-lines (window-start) (point)) (if (= (current-column) 0) 1 0) -1))
  307.  
  308. (defun tpu-change-case (num)
  309.   "Change the case of the character under the cursor or region.
  310. Accepts a prefix argument of the number of characters to invert."
  311.   (interactive "p")
  312.   (cond ((mark)
  313.          (let ((beg (region-beginning)) (end (region-end)))
  314.            (while (> end beg)
  315.              (funcall (if (<= ?a (char-after beg))
  316.                           'upcase-region 'downcase-region)
  317.                       beg (1+ beg))
  318.              (setq beg (1+ beg)))
  319.            (tpu-unselect t)))
  320.         ((tpu-check-match)
  321.          (let ((beg (tpu-match-beginning)) (end (tpu-match-end)))
  322.            (while (> end beg)
  323.              (funcall (if (<= ?a (char-after beg))
  324.                           'upcase-region 'downcase-region)
  325.                       beg (1+ beg))
  326.              (setq beg (1+ beg)))
  327.            (tpu-unset-match)))
  328.         (t
  329.          (while (> num 0)
  330.            (funcall (if (<= ?a (following-char))
  331.                         'upcase-region 'downcase-region)
  332.                     (point) (1+ (point)))
  333.            (forward-char (if tpu-reverse -1 1))
  334.            (setq num (1- num))))))
  335.  
  336. (defun tpu-fill (num)
  337.   "Fill paragraph or marked region.
  338. With argument, fill and justify."
  339.   (interactive "P")
  340.   (cond ((mark)
  341.          (fill-region (point) (mark) num)
  342.          (tpu-unselect t))
  343.         (t
  344.          (fill-paragraph num))))
  345.  
  346. (defun tpu-trim-line-ends nil
  347.   "Removes trailing whitespace from every line in the buffer."
  348.   (interactive)
  349.   (picture-clean))
  350.  
  351. (defun update-mode-line nil
  352.   "Make sure mode-line in the current buffer reflects all changes."
  353.   (setq tpu-mark-flag (if (mark) "M" " "))
  354.   (set-buffer-modified-p (buffer-modified-p))
  355.   (sit-for 0))
  356.  
  357. (defun tpu-version nil
  358.   "Print the TPU-edt version number."
  359.   (interactive)
  360.   (message (concat "TPU-edt revision "
  361.                    (substring tpu-revision 11 -2)
  362.                    " by Rob Riepel (rob@icarus.ssd.loral.com)    "
  363.                    (substring tpu-revision-date 7 -11))))
  364.  
  365. (defun reset-screen-size (height width)
  366.   "Sets the screen size."
  367.   (interactive "nnew screen height: \nnnew screen width: ")
  368.   (set-screen-height height)
  369.   (set-screen-width width))
  370.  
  371. (defun toggle-newline-and-indent nil
  372.   "Toggle between 'newline and indent' and 'simple newline'."
  373.   (interactive)
  374.   (cond (newline-and-indent-p
  375.          (setq newline-and-indent-p-string "")
  376.          (setq newline-and-indent-p nil)
  377.          (tpu-local-set-key '(control m) 'newline))
  378.         (t
  379.          (setq newline-and-indent-p-string " AutoIndent")
  380.          (setq newline-and-indent-p t)
  381.          (tpu-local-set-key '(control m) 'newline-and-indent)))
  382.   (update-mode-line))
  383.  
  384. (defun spell-check nil
  385.   "Checks the spelling of the region, or of the entire buffer if no
  386.  region is selected."
  387.   (interactive)
  388.   (cond (tpu-have-ispell
  389.          (if (mark) (ispell-region (mark) (point)) (ispell-buffer)))
  390.         (t
  391.          (if (mark) (spell-region (mark) (point)) (spell-buffer))))
  392.   (if (mark) (tpu-unselect t)))
  393.  
  394. (defun tpu-what-line nil
  395.   "Tells what line the point is on,
  396.  and the total number of lines in the buffer."
  397.   (interactive)
  398.   (if (eobp)
  399.       (message "You are at the End of Buffer.  The last line is %d."
  400.                (count-lines 1 (point-max)))
  401.     (message "Line %d of %d"
  402.              (count-lines 1 (1+ (point)))
  403.              (count-lines 1 (point-max)))))
  404.  
  405. (defun tpu-select (&optional quiet)
  406.   "Sets the mark to define one end of a region."
  407.   (interactive "P")
  408.   (cond ((mark)
  409.          (tpu-unselect quiet))
  410.         (t
  411.      (push-mark)
  412.      (zmacs-activate-region)
  413.          (update-mode-line)
  414.          (if (not quiet) (message "Move the text cursor to select text.")))))
  415.  
  416. (defun tpu-unselect (&optional quiet)
  417.   "Removes the mark to unselect the current region."
  418.   (interactive "P")
  419.   (setq mark-ring nil)
  420.   (set-mark nil)
  421.   (update-mode-line)
  422.   (if (not quiet) (message "Selection canceled.")))
  423.  
  424. (defun toggle-overwrite-mode nil
  425.    "Switches in and out of overwrite mode"
  426.    (interactive)
  427.    (cond (overwrite-mode
  428.           (tpu-local-set-key "\177" tpu-saved-delete-func)
  429.           (overwrite-mode 0))
  430.          (t
  431.           (setq tpu-saved-delete-func (local-key-binding "\177"))
  432.           (tpu-local-set-key "\177" 'picture-backward-clear-column)
  433.           (overwrite-mode 1))))
  434.  
  435. (defun tpu-special-insert (num)
  436.   "Insert a character or control code according to
  437. its ASCII decimal value."
  438.   (interactive "P")
  439.   (insert (if num num 0)))
  440.  
  441. (defun quit-emacs-now nil
  442.   "Go away.  Now.  Just  g o  a w a y."
  443.   (interactive)
  444.   (kill-emacs t))
  445.  
  446.  
  447. ;;;
  448. ;;;  TPU-alike commands
  449. ;;;
  450. (defun include (file)
  451.   "TPU-like include file"
  452.   (interactive "fInclude file: ")
  453.   (save-excursion
  454.     (insert-file file)
  455.     (message "")))
  456.  
  457. (defun Get (file)
  458.   "TPU-like get file"
  459.   (interactive "FFile to get: ")
  460.   (find-file file))
  461.  
  462. (defun exit nil
  463.   "Exit the way TPU does, save current buffer and ask about others."
  464.   (interactive)
  465.   (if (not (eq (recursion-depth) 0))
  466.     (exit-recursive-edit)
  467.     (progn (save-buffer) (save-buffers-kill-emacs))))
  468.  
  469. (defun quit nil
  470.   "Quit the way TPU does, ask to make sure changes should be abandoned."
  471.   (interactive)
  472.   (let ((list (buffer-list))
  473.         (working t))
  474.     (while (and list working)
  475.       (let ((buffer (car list)))
  476.         (if (and (buffer-file-name buffer) (buffer-modified-p buffer))
  477.             (if (tpu-y-or-n-p
  478.                  (format "Modifications will not be saved, continue quitting? " ))
  479.                 (kill-emacs t) (setq working nil)))
  480.         (setq list (cdr list))))
  481.     (if working (kill-emacs t))))
  482.  
  483.  
  484. ;;;
  485. ;;;  Command and Function Aliases
  486. ;;;
  487. (fset 'EXIT 'exit)
  488. (fset 'GET 'Get)
  489. (fset 'INCLUDE 'include)
  490. (fset 'QUIT 'quit)
  491.  
  492. (fset 'spell 'spell-check)
  493. (fset 'SPELL 'spell-check)
  494.  
  495. (fset 'what\ line 'tpu-what-line)
  496. (fset 'WHAT\ LINE 'tpu-what-line)
  497.  
  498. (fset 'replace 'tpu-lm-replace)
  499. (fset 'REPLACE 'tpu-lm-replace)
  500.  
  501. (fset 'help 'tpu-help)
  502. (fset 'HELP 'tpu-help)
  503.  
  504. ;; Around emacs version 18.57, function line-move was renamed to
  505. ;; next-line-internal.  If we're running under an older emacs,
  506. ;; make next-line-internal equivalent to line-move.
  507.  
  508. (if (not (fboundp 'next-line-internal)) (fset 'next-line-internal 'line-move))
  509.  
  510.  
  511. ;;;
  512. ;;;  Help
  513. ;;;
  514. (defun tpu-help nil
  515.   "Display TPU-edt help."
  516.   (interactive)
  517.   ;; Save current window configuration
  518.   (save-window-excursion
  519.     ;; Create and fill help buffer if necessary
  520.     (if (not (get-buffer "*TPU-edt Help*"))
  521.         (progn (generate-new-buffer "*TPU-edt Help*")
  522.                (switch-to-buffer "*TPU-edt Help*")
  523.                (insert "\f
  524.           _______________________    _______________________________
  525.          | HELP  |      Do       |  |       |       |       |       |
  526.          |KeyDefs|               |  |       |       |       |       |
  527.          |_______|_______________|  |_______|_______|_______|_______|
  528.           _______________________    _______________________________
  529.          | Find  |Insert |Remove |  | Gold  | HELP  |FndNxt | Del L |
  530.          |       |       |Sto Tex|  |  key  |E-Help | Find  |Undel L|
  531.          |_______|_______|_______|  |_______|_______|_______|_______|
  532.          |Select |Pre Scr|Nex Scr|  | Page  | Sect  |Append | Del W |
  533.          | Reset |Pre Win|Nex Win|  |  Do   | Fill  |Replace|Undel W|
  534.          |_______|_______|_______|  |_______|_______|_______|_______|
  535.                  |Move up|          |Forward|Reverse|Remove | Del C |
  536.                  |  Top  |          |Bottom |  Top  |Insert |Undel C|
  537.           _______|_______|_______   |_______|_______|_______|_______|
  538.          |Mov Lef|Mov Dow|Mov Rig|  | Word  |  EOL  | Char  |       |
  539.          |StaOfLi|Bottom |EndOfLi|  |ChngCas|Del EOL|SpecIns| Enter |
  540.          |_______|_______|_______|  |_______|_______|_______|       |
  541.                                     |     Line      |Select | Subs  |
  542.                                     |   Open Line   | Reset |       |
  543.                                     |_______________|_______|_______|
  544.  
  545.  
  546. \f
  547.  
  548.       Control Characters
  549.  
  550.       ^A  toggle insert and overwrite
  551.       ^B  recall
  552.       ^E  end of line
  553.  
  554.       ^G  Cancel current operation
  555.       ^H  beginning of line
  556.       ^J  delete previous word
  557.  
  558.       ^K  learn
  559.       ^L  insert page break
  560.       ^R  remember (during learn), re-center
  561.  
  562.       ^U  delete to beginning of line
  563.       ^V  quote
  564.       ^W  refresh
  565.  
  566.       ^Z  exit
  567.     ^X^X  exchange point and mark - useful for checking region boundaries
  568.  
  569. \f
  570.        Gold-<key> Functions
  571.  
  572.        B     Next Buffer - display the next buffer (all buffers)
  573.        C     Recall - edit and possibly repeat previous commands
  574.        E     Exit - save current buffer and ask about others
  575.  
  576.        G     Get - load a file into a new edit buffer
  577.        I     Include - include a file in this buffer
  578.        K     Kill Buffer - abandon edits and delete buffer
  579.  
  580.        M     Buffer Menu - display a list of all buffers
  581.        N     Next File Buffer - display next buffer containing a file
  582.        O     Occur - show following lines containing REGEXP
  583.  
  584.        Q     Quit - exit without saving anything
  585.        R     Toggle rectangular mode for remove and insert
  586.        S     Search and substitute - line mode REPLACE command
  587.  
  588.        U     Undo - undo the last edit
  589.        W     Write - save current buffer
  590.        X     Exit - save all modified buffers and exit
  591.  
  592. \f
  593.  
  594.    *** No more help, use P to view previous screen")
  595.       (setq buffer-read-only t)))
  596.  
  597.     ;; Display the help buffer
  598.     (switch-to-buffer "*TPU-edt Help*")
  599.     (delete-other-windows)
  600.     (move-to-beginning)
  601.     (forward-line 1)
  602.     (line-to-top-of-window)
  603.  
  604.     ;; Prompt for keys to describe, based on screen state (split/not split)
  605.     (let ((key nil) (split nil))
  606.       (while (not (equal key "\r"))
  607.         (if split
  608.             (setq key
  609.                   (read-key-sequence
  610.                    "Press the key you want help on (RET=exit, ENTER=redisplay, N=next, P=prev): "))
  611.           (setq key
  612.                 (read-key-sequence
  613.                  "Press the key you want help on (RET to exit, N next screen, P prev screen): ")))
  614.  
  615.         ;; Process the read key
  616.         ;;
  617.         ;;    ENTER    Display just the help window
  618.         ;;    N or n   Next help or describe-key screen
  619.         ;;    P or p   Previous help or describe-key screen
  620.         ;;    RETRUN   Exit from TPU-help
  621.         ;;    default  describe the key
  622.         ;;
  623.         (cond ((equal "\eOM" key)
  624.                (setq split nil)
  625.                (delete-other-windows))
  626.               ((or (equal "N" key) (equal "n" key))
  627.                (cond (split
  628.                       (condition-case nil
  629.                           (scroll-other-window 8)
  630.                         (error nil)))
  631.                      (t
  632.                       (forward-page)
  633.                       (forward-line 1)
  634.                       (line-to-top-of-window))))
  635.               ((or (equal "P" key) (equal "p" key))
  636.                (cond (split
  637.                       (condition-case nil
  638.                           (scroll-other-window -8)
  639.                         (error nil)))
  640.                      (t
  641.                       (backward-page 2)
  642.                       (forward-line 1)
  643.                       (line-to-top-of-window))))
  644.               ((not (equal "\r" key))
  645.                (setq split t)
  646.                (describe-key key)
  647.                ;; If the key is undefined, leave the
  648.                ;;   message in the mini-buffer for 3 seconds
  649.                (if (not (key-binding key)) (sit-for 3))))))))
  650.  
  651.  
  652. ;;;
  653. ;;;  Auto-insert
  654. ;;;
  655. (defun insert-escape nil
  656.   "Inserts an escape character, and so becomes the escape-key alias."
  657.   (interactive)
  658.   (insert "\e"))
  659.  
  660. (defun insert-formfeed nil
  661.   "Inserts a formfeed character."
  662.   (interactive)
  663.   (insert "\C-L"))
  664.  
  665.  
  666. ;;;
  667. ;;;  Define key
  668. ;;;
  669. (defun end-define-macro-key (key)
  670.   "Ends the current macro definition"
  671.   (interactive "kPress the key you want to use to do what was just learned: ")
  672.   (end-kbd-macro nil)
  673.   (global-set-key key last-kbd-macro)
  674.   (global-set-key '(control r) 'recenter))
  675.  
  676. (defun define-macro-key nil
  677.   "Bind a set of keystrokes to a single key, or key combination."
  678.   (interactive)
  679.   (global-set-key '(control r) 'end-define-macro-key)
  680.   (start-kbd-macro nil))
  681.  
  682.  
  683. ;;;
  684. ;;;  Counter
  685. ;;;
  686. (defun set-counter nil
  687.   "Set the internal counter to the repeat count."
  688.   (interactive)
  689.   (message "Counter set to %d."
  690.            (setq tpu-counter current-prefix-arg)))
  691.  
  692. (defun region-length-to-counter nil
  693.   "Sets the counter to the length of the region."
  694.   (interactive)
  695.   (cond ((mark)
  696.          (message "Counter set to %d."
  697.                   (setq tpu-counter
  698.                         (- (max (point) (mark)) (min (point) (mark))))))
  699.         (t (message "The mark is not set now; no select range is active."))))
  700.  
  701. (defun decr-counter nil
  702.   "Decrement the internal counter by the repeat count,
  703.  or by one if no repeat count is defined."
  704.  (interactive)
  705.  (message "Counter set to %d."
  706.           (setq tpu-counter (- tpu-counter (or current-prefix-arg 1)))))
  707.  
  708. (defun incr-counter nil
  709.   "Increment the internal counter by the repeat count,
  710.  or by one if no repeat count is defined."
  711.  (interactive)
  712.  (message "Counter set to %d."
  713.           (setq tpu-counter (+ tpu-counter (or current-prefix-arg 1)))))
  714.  
  715. (defun change-counter-format (fmt)
  716.   "Changes the display format for use when inserting the internal tpu counter.
  717.  You may use standard C format expressions."
  718.   (interactive "sFormat (C-like): ")
  719.   (setq tpu-counter-format fmt))
  720.  
  721. (defun insert-counter nil
  722.   "Inserts the internal tpu counter using the tpu counter format."
  723.   (interactive)
  724.   (insert (format tpu-counter-format tpu-counter)))
  725.  
  726. (defun insert-counter-as-char nil
  727.   "Inserts the character value (mod 256) of the internal tpu counter."
  728.   (interactive)
  729.   (insert (mod tpu-counter 256)))
  730.  
  731.  
  732. ;;;
  733. ;;;  Buffer
  734. ;;;
  735. (defun set-buffer-clean nil
  736.   "Toggles the update mode of the buffer."
  737.   (interactive)
  738.   (set-buffer-modified-p (not (buffer-modified-p))))
  739.  
  740. (defun tpu-kill-buffer nil
  741.   "Kills the current buffer.  If tpu-kill-buffers-silently is non-nil,
  742. kills modified buffers without asking."
  743.   (interactive)
  744.   (if tpu-kill-buffers-silently (set-buffer-modified-p nil))
  745.   (kill-buffer (current-buffer)))
  746.  
  747. (defun save-all-buffers-kill-emacs nil
  748.   "Save all buffers and exit emacs."
  749.   (interactive)
  750.   (setq trim-versions-without-asking t)
  751.   (save-buffers-kill-emacs t))
  752.  
  753. (defun write-current-buffers nil
  754.   "Save all modified buffers without exiting."
  755.   (interactive)
  756.   (save-some-buffers t))
  757.  
  758. (defun next-buffer nil
  759.   "Go to next buffer in ring."
  760.   (interactive)
  761.   (switch-to-buffer (car (reverse (buffer-list)))))
  762.  
  763. (defun next-file-buffer nil
  764.   "Go to next buffer in ring that is visiting a file."
  765.   (interactive)
  766.   (setq starting-buffer (buffer-name))
  767.   (switch-to-buffer (car (reverse (buffer-list))))
  768.   (while (and (not (equal (buffer-name) starting-buffer))
  769.               (not (buffer-file-name)))
  770.     (switch-to-buffer (car (reverse (buffer-list)))))
  771.   (if (equal (buffer-name) starting-buffer)
  772.     (progn (beep) (message "No other buffers."))))
  773.  
  774.  
  775. ;;;
  776. ;;;  Repeat count
  777. ;;;
  778. (defun repeat-command-0 nil
  779.   "Repeats the following keystroke."
  780.   (interactive)
  781.   (prefix-arg-internal last-command-event nil nil))
  782.  
  783. (defun repeat-command-1 nil
  784.   "Repeats the following keystroke."
  785.   (interactive)
  786.   (prefix-arg-internal last-command-event nil nil))
  787.  
  788. (defun repeat-command-2 nil
  789.   "Repeats the following keystroke."
  790.   (interactive)
  791.   (prefix-arg-internal last-command-event nil nil))
  792.  
  793. (defun repeat-command-3 nil
  794.   "Repeats the following keystroke."
  795.   (interactive)
  796.   (prefix-arg-internal last-command-event nil nil))
  797.  
  798. (defun repeat-command-4 nil
  799.   "Repeats the following keystroke."
  800.   (interactive)
  801.   (prefix-arg-internal last-command-event nil nil))
  802.  
  803. (defun repeat-command-5 nil
  804.   "Repeats the following keystroke."
  805.   (interactive)
  806.   (prefix-arg-internal last-command-event nil nil))
  807.  
  808. (defun repeat-command-6 nil
  809.   "Repeats the following keystroke."
  810.   (interactive)
  811.   (prefix-arg-internal last-command-event nil nil))
  812.  
  813. (defun repeat-command-7 nil
  814.   "Repeats the following keystroke."
  815.   (interactive)
  816.   (prefix-arg-internal last-command-event nil nil))
  817.  
  818. (defun repeat-command-8 nil
  819.   "Repeats the following keystroke."
  820.   (interactive)
  821.   (prefix-arg-internal last-command-event nil nil))
  822.  
  823. (defun repeat-command-9 nil
  824.   "Repeats the following keystroke."
  825.   (interactive)
  826.   (prefix-arg-internal last-command-event nil nil))
  827.  
  828. (defun repeat-command-- nil
  829.   "Repeats the following keystroke."
  830.   (interactive)
  831.   (prefix-arg-internal last-command-event nil nil))
  832.  
  833.  
  834. ;;;
  835. ;;;  Search
  836. ;;;
  837. (defun tpu-toggle-regexp nil
  838.    "Switches in and out of regular expression search and replace mode."
  839.    (interactive)
  840.    (setq tpu-regexp-p (not tpu-regexp-p))
  841.    (tpu-set-search)
  842.    (message "Regular expression search and substitute %sabled."
  843.             (if tpu-regexp-p "en" "dis")))
  844.  
  845. (defun tpu-regexp-prompt (prompt)
  846.   "Read a string, adding 'RE' to the prompt if tpu-regexp-p is set."
  847.   (read-string (concat (if tpu-regexp-p "RE ") prompt)))
  848.  
  849. (defun tpu-search nil
  850.   "Search for a string or regular expression.
  851. The search is performed in the current direction."
  852.   (interactive)
  853.   (tpu-set-search)
  854.   (tpu-search-internal ""))
  855.  
  856. (defun tpu-search-again nil
  857.   "Search for the same string or regular expression as last time.
  858. The search is performed in the current direction."
  859.   (interactive)
  860.   (tpu-search-internal tpu-search-last-string))
  861.  
  862. ;;  tpu-set-search defines the search functions used by the TPU-edt internal
  863. ;;  search function.  It should be called whenever the direction changes, or
  864. ;;  the regular expression mode is turned on or off.  It can also be called
  865. ;;  to ensure that the next search will be in the current direction.  It is
  866. ;;  called from:
  867.  
  868. ;;       tpu-advance              tpu-backup
  869. ;;       tpu-toggle-regexp        tpu-toggle-search-direction (t)
  870. ;;       tpu-search               tpu-lm-replace
  871.  
  872. (defun tpu-set-search (&optional arg)
  873.   "Set the search functions and set the search direction to the current
  874. direction.  If an argument is specified, don't set the search direction."
  875.   (if (not arg) (setq searching-forward (if tpu-advance t nil)))
  876.   (cond (searching-forward
  877.          (cond (tpu-regexp-p
  878.                 (fset 'tpu-emacs-search 're-search-forward)
  879.                 (fset 'tpu-emacs-rev-search 're-search-backward))
  880.                (t
  881.                 (fset 'tpu-emacs-search 'search-forward)
  882.                 (fset 'tpu-emacs-rev-search 'search-backward))))
  883.         (t
  884.          (cond (tpu-regexp-p
  885.                 (fset 'tpu-emacs-search 're-search-backward)
  886.                 (fset 'tpu-emacs-rev-search 're-search-forward))
  887.                (t
  888.                 (fset 'tpu-emacs-search 'search-backward)
  889.                 (fset 'tpu-emacs-rev-search 'search-forward))))))
  890.  
  891. (defun tpu-search-internal (pat &optional quiet)
  892.   "Search for a string or regular expression."
  893.   (setq tpu-search-last-string
  894.         (if (not (string= "" pat)) pat (tpu-regexp-prompt "Search: ")))
  895.  
  896.   (tpu-unset-match)
  897.   (tpu-adjust-search)
  898.  
  899.   (cond ((tpu-emacs-search tpu-search-last-string nil t)
  900.          (tpu-set-match) (goto-char (tpu-match-beginning)))
  901.  
  902.         (t
  903.          (tpu-adjust-search t)
  904.          (let ((found nil) (pos nil))
  905.            (save-excursion
  906.              (let ((searching-forward (not searching-forward)))
  907.                (tpu-adjust-search)
  908.                (setq found (tpu-emacs-rev-search tpu-search-last-string nil t))
  909.                (setq pos (match-beginning 0))))
  910.  
  911.            (cond (found
  912.                   (cond ((tpu-y-or-n-p
  913.                           (format "Found in %s direction.  Go there? "
  914.                                   (if searching-forward "reverse" "forward")))
  915.                          (goto-char pos) (tpu-set-match)
  916.                          (tpu-toggle-search-direction))))
  917.  
  918.                  (t
  919.                   (if (not quiet)
  920.                       (message
  921.                        "%sSearch failed: \"%s\""
  922.                        (if tpu-regexp-p "RE " "") tpu-search-last-string))))))))
  923.  
  924. (defun tpu-adjust-search (&optional arg)
  925.   "For forward searches, move forward a character before searching,
  926. and backward a character after a failed search.  Arg means end of search."
  927.   (if searching-forward
  928.       (cond (arg (if (not (bobp)) (forward-char -1)))
  929.             (t (if (not (eobp)) (forward-char 1))))))
  930.  
  931. (defun tpu-toggle-search-direction nil
  932.   "Toggle the TPU-edt search direction.
  933. Used for reversing a search in progress."
  934.   (interactive)
  935.   (setq searching-forward (not searching-forward))
  936.   (tpu-set-search t))
  937.  
  938.  
  939. ;;;
  940. ;;;  Delete
  941. ;;;
  942. (defun tpu-toggle-rectangle nil
  943.   "Toggle rectangular mode for remove and insert."
  944.   (interactive)
  945.   (setq tpu-rectangular-p (not tpu-rectangular-p))
  946.   (setq tpu-rectangle-string (if tpu-rectangular-p " Rect" ""))
  947.   (update-mode-line)
  948.   (message "Rectangular cut and paste %sabled."
  949.            (if tpu-rectangular-p "en" "dis")))
  950.  
  951. (defun tpu-arrange-rectangle nil
  952.   "Adjust point and mark to mark upper left and lower right
  953. corners of a rectangle."
  954.   (let ((mc (current-column))
  955.         (pc (progn (exchange-point-and-mark) (current-column))))
  956.  
  957.     (cond ((> (point) (mark))                      ; point on lower line
  958.            (cond ((> pc mc)                        ; point @  lower-right
  959.                   (exchange-point-and-mark))       ; point -> upper-left
  960.  
  961.                  (t                                ; point @  lower-left
  962.                   (move-to-column-force mc)        ; point -> lower-right
  963.                   (exchange-point-and-mark)        ; point -> upper-right
  964.                   (move-to-column-force pc))))     ; point -> upper-left
  965.  
  966.           (t                                       ; point on upper line
  967.            (cond ((> pc mc)                        ; point @  upper-right
  968.                   (move-to-column-force mc)        ; point -> upper-left
  969.                   (exchange-point-and-mark)        ; point -> lower-left
  970.                   (move-to-column-force pc)        ; point -> lower-right
  971.                   (exchange-point-and-mark)))))))  ; point -> upper-left
  972.  
  973. (defun tpu-cut nil
  974.   "Delete the selected region.
  975. The text is saved for the tpu-paste command."
  976.   (interactive)
  977.     (cond ((mark)
  978.            (cond (tpu-rectangular-p
  979.                   (tpu-arrange-rectangle)
  980.                   (picture-clear-rectangle (point) (mark) (not overwrite-mode))
  981.                   (tpu-unselect t))
  982.                  (t
  983.                   (setq tpu-last-deleted-region
  984.                         (buffer-substring (mark) (point)))
  985.                   (delete-region (mark) (point))
  986.                   (tpu-unselect t))))
  987.            ((tpu-check-match)
  988.             (let ((beg (tpu-match-beginning)) (end (tpu-match-end)))
  989.               (setq tpu-last-deleted-region (buffer-substring beg end))
  990.               (delete-region beg end)
  991.               (tpu-unset-match)))
  992.            (t
  993.             (beep) (message "No selection active."))))
  994.  
  995. (defun tpu-store-text nil
  996.   "Copy the selected region to the cut buffer without deleting it.
  997. The text is saved for the tpu-paste command."
  998.   (interactive)
  999.     (cond ((mark)
  1000.            (cond (tpu-rectangular-p
  1001.                   (save-excursion
  1002.                     (tpu-arrange-rectangle)
  1003.                     (setq picture-killed-rectangle
  1004.                           (extract-rectangle (point) (mark))))
  1005.                   (tpu-unselect t))
  1006.                  (t
  1007.                   (setq tpu-last-deleted-region
  1008.                         (buffer-substring (mark) (point)))
  1009.                   (tpu-unselect t))))
  1010.            ((tpu-check-match)
  1011.             (setq tpu-last-deleted-region
  1012.                   (buffer-substring (tpu-match-beginning) (tpu-match-end)))
  1013.             (tpu-unset-match))
  1014.            (t
  1015.             (beep) (message "No selection active."))))
  1016.  
  1017. (defun tpu-append-region nil
  1018.   "Delete the selected region and append it to the tpu-cut buffer."
  1019.   (interactive)
  1020.   (cond ((mark)
  1021.          (let ((beg (region-beginning)) (end (region-end)))
  1022.            (setq tpu-last-deleted-region
  1023.                  (concat tpu-last-deleted-region
  1024.                          (buffer-substring beg end)))
  1025.            (delete-region beg end)
  1026.            (tpu-unselect t)))
  1027.         ((tpu-check-match)
  1028.          (let ((beg (tpu-match-beginning)) (end (tpu-match-end)))
  1029.            (setq tpu-last-deleted-region
  1030.                  (concat tpu-last-deleted-region
  1031.                          (buffer-substring beg end)))
  1032.            (delete-region beg end)
  1033.            (tpu-unset-match)))
  1034.         (t
  1035.          (beep) (message "No selection active."))))
  1036.  
  1037. (defun delete-current-line (num)
  1038.   "Delete one or specified number of lines after point.
  1039. This includes the newline character at the end of each line.
  1040. They are saved for the TPU-edt undelete-lines command."
  1041.   (interactive "p")
  1042.   (let ((beg (point)))
  1043.     (forward-line num)
  1044.     (if (not (eq (preceding-char) ?\n))
  1045.         (insert "\n"))
  1046.     (setq tpu-last-deleted-lines
  1047.           (buffer-substring beg (point)))
  1048.     (delete-region beg (point))))
  1049.  
  1050. (defun delete-to-eol (num)
  1051.   "Delete text up to end of line.
  1052. With argument, delete up to to Nth line-end past point.
  1053. They are saved for the TPU-edt undelete-lines command."
  1054.   (interactive "p")
  1055.   (let ((beg (point)))
  1056.     (forward-char 1)
  1057.     (end-of-line num)
  1058.     (setq tpu-last-deleted-lines
  1059.           (buffer-substring beg (point)))
  1060.     (delete-region beg (point))))
  1061.  
  1062. (defun delete-to-bol (num)
  1063.   "Delete text back to beginning of line.
  1064. With argument, delete up to to Nth line-end past point.
  1065. They are saved for the TPU-edt undelete-lines command."
  1066.   (interactive "p")
  1067.   (let ((beg (point)))
  1068.     (backward-char 1)
  1069.     (beginning-of-line num)
  1070.     (setq tpu-last-deleted-lines
  1071.           (buffer-substring (point) beg))
  1072.     (delete-region (point) beg)))
  1073.  
  1074. (defun delete-current-word (num)
  1075.   "Delete one or specified number of words after point.
  1076. They are saved for the TPU-edt undelete-words command."
  1077.   (interactive "p")
  1078.   (let ((beg (point)))
  1079.     (forward-to-word num)
  1080.     (setq tpu-last-deleted-words
  1081.           (buffer-substring beg (point)))
  1082.     (delete-region beg (point))))
  1083.  
  1084. (defun delete-previous-word (num)
  1085.   "Delete one or specified number of words before point.
  1086. They are saved for the TPU-edt undelete-words command."
  1087.   (interactive "p")
  1088.   (let ((beg (point)))
  1089.     (backward-to-word num)
  1090.     (setq tpu-last-deleted-words
  1091.           (buffer-substring (point) beg))
  1092.     (delete-region beg (point))))
  1093.  
  1094. (defun delete-current-char (num)
  1095.   "Delete one or specified number of characters after point.  The last
  1096. character deleted is saved for the TPU-edt undelete-char command."
  1097.   (interactive "p")
  1098.   (while (and (> num 0) (not (eobp)))
  1099.     (setq tpu-last-deleted-char (char-after (point)))
  1100.     (cond (overwrite-mode
  1101.            (picture-clear-column 1)
  1102.            (forward-char 1))
  1103.           (t
  1104.            (delete-char 1)))
  1105.     (setq num (1- num))))
  1106.  
  1107.  
  1108. ;;;
  1109. ;;;  Undelete
  1110. ;;;
  1111. (defun tpu-paste (num)
  1112.   "Insert the last region or rectangle of killed text.
  1113. With argument reinserts the text that many times."
  1114.   (interactive "p")
  1115.   (while (> num 0)
  1116.     (cond (tpu-rectangular-p
  1117.            (let ((beg (point)))
  1118.              (save-excursion
  1119.                (picture-yank-rectangle (not overwrite-mode))
  1120.                (message ""))
  1121.              (goto-char beg)))
  1122.           (t
  1123.            (insert tpu-last-deleted-region)))
  1124.     (setq num (1- num))))
  1125.  
  1126. (defun undelete-lines (num)
  1127.   "Insert lines deleted by last TPU-edt line-deletion command.
  1128. With argument reinserts lines that many times."
  1129.   (interactive "p")
  1130.   (let ((beg (point)))
  1131.     (while (> num 0)
  1132.       (insert tpu-last-deleted-lines)
  1133.       (setq num (1- num)))
  1134.     (goto-char beg)))
  1135.  
  1136. (defun undelete-words (num)
  1137.   "Insert words deleted by last TPU-edt word-deletion command.
  1138. With argument reinserts words that many times."
  1139.   (interactive "p")
  1140.   (let ((beg (point)))
  1141.     (while (> num 0)
  1142.       (insert tpu-last-deleted-words)
  1143.       (setq num (1- num)))
  1144.     (goto-char beg)))
  1145.  
  1146. (defun undelete-char (num)
  1147.   "Insert character deleted by last TPU-edt character-deletion command.
  1148. With argument reinserts the character that many times."
  1149.   (interactive "p")
  1150.   (while (> num 0)
  1151.     (if overwrite-mode (prog1 (forward-char -1) (delete-char 1)))
  1152.     (insert tpu-last-deleted-char)
  1153.     (forward-char -1)
  1154.     (setq num (1- num))))
  1155.  
  1156.  
  1157. ;;;
  1158. ;;;  Replace and Substitute
  1159. ;;;
  1160. (defun tpu-replace nil
  1161.   "Replace the selected region with the contents of the cut buffer."
  1162.   (interactive)
  1163.   (cond ((mark)
  1164.          (let ((beg (region-beginning)) (end (region-end)))
  1165.            (setq tpu-last-replaced-text (buffer-substring beg end))
  1166.            (delete-region beg end)
  1167.            (insert tpu-last-deleted-region)
  1168.            (tpu-unselect t)))
  1169.         ((tpu-check-match)
  1170.          (let ((beg (tpu-match-beginning)) (end (tpu-match-end)))
  1171.            (setq tpu-last-replaced-text (buffer-substring beg end))
  1172.            (replace-match tpu-last-deleted-region
  1173.                           (not case-replace) (not tpu-regexp-p))
  1174.            (tpu-unset-match)))
  1175.         (t
  1176.          (beep) (message "No selection active."))))
  1177.  
  1178. (defun tpu-substitute (num)
  1179.   "Replace the selected region with the contents of the cut buffer, and
  1180. repeat most recent search.  A numeric argument serves as a repeat count.
  1181. A negative argument means replace all occurrences of the search string."
  1182.   (interactive "p")
  1183.   (cond ((or (mark) (tpu-check-match))
  1184.          (while (and (not (= num 0)) (or (mark) (tpu-check-match)))
  1185.            (let ((beg (point)))
  1186.              (tpu-replace)
  1187.              (if searching-forward (forward-char -1) (goto-char beg))
  1188.              (tpu-search-again))
  1189.            (setq num (1- num))))
  1190.         (t
  1191.          (beep) (message "No selection active."))))
  1192.  
  1193. (defun tpu-lm-replace (from to)
  1194.   "Interactively search for OLD-string and substitute NEW-string."
  1195.   (interactive (list (tpu-regexp-prompt "Old String: ")
  1196.                      (tpu-regexp-prompt "New String: ")))
  1197.  
  1198.   (let ((doit t) (strings 0))
  1199.  
  1200.     ;; Can't replace null strings
  1201.     (if (string= "" from) (error "No string to replace."))
  1202.  
  1203.     ;; Find the first occurrence
  1204.     (tpu-set-search)
  1205.     (tpu-search-internal from t)
  1206.  
  1207.     ;; Loop on replace question - yes, no, all, last, or quit.
  1208.     (while doit
  1209.       (if (not (tpu-check-match)) (setq doit nil)
  1210.         (progn (message "Replace? Type Yes, No, All, Last, or Quit: ")
  1211.                (let ((ans (read-char)))
  1212.  
  1213.                  (cond ((or (= ans ?y) (= ans ?Y) (= ans ?\r) (= ans ?\ ))
  1214.                         (let ((beg (point)))
  1215.                           (replace-match to (not case-replace) (not tpu-regexp-p))
  1216.                           (setq strings (1+ strings))
  1217.                           (if searching-forward (forward-char -1) (goto-char beg)))
  1218.                         (tpu-search-internal from t))
  1219.  
  1220.                        ((or (= ans ?n) (= ans ?N) (= ans ?\C-?))
  1221.                         (tpu-search-internal from t))
  1222.  
  1223.                        ((or (= ans ?a) (= ans ?A))
  1224.                         (save-excursion
  1225.                           (let ((beg (point)))
  1226.                             (replace-match to (not case-replace) (not tpu-regexp-p))
  1227.                             (setq strings (1+ strings))
  1228.                             (if searching-forward (forward-char -1) (goto-char beg)))
  1229.                           (tpu-search-internal from t)
  1230.                           (while (tpu-check-match)
  1231.                             (let ((beg (point)))
  1232.                               (replace-match to (not case-replace) (not tpu-regexp-p))
  1233.                               (setq strings (1+ strings))
  1234.                               (if searching-forward (forward-char -1) (goto-char beg)))
  1235.                             (tpu-search-internal from t)))
  1236.                         (setq doit nil))
  1237.  
  1238.                        ((or (= ans ?l) (= ans ?L))
  1239.                         (let ((beg (point)))
  1240.                           (replace-match to (not case-replace) (not tpu-regexp-p))
  1241.                           (setq strings (1+ strings))
  1242.                           (if searching-forward (forward-char -1) (goto-char beg)))
  1243.                         (setq doit nil))
  1244.  
  1245.                        ((or (= ans ?q) (= ans ?Q))
  1246.                         (setq doit nil)))))))
  1247.  
  1248.     (message "Replaced %s occurrence%s." strings
  1249.              (if (not (= 1 strings)) "s" ""))))
  1250.  
  1251. (defun tpu-emacs-replace (&optional dont-ask)
  1252.   "A TPU-edt interface to the emacs replace functions.  If TPU-edt is
  1253. currently in regular expression mode, the emacs regular expression
  1254. replace functions are used.  If an argument is supplied, replacements
  1255. are performed without asking.  Only works in forward direction."
  1256.   (interactive "P")
  1257.   (cond (dont-ask
  1258.          (setq current-prefix-arg nil)
  1259.          (call-interactively
  1260.           (if tpu-regexp-p 'replace-regexp 'replace-string)))
  1261.         (t
  1262.          (call-interactively
  1263.           (if tpu-regexp-p 'query-replace-regexp 'query-replace)))))
  1264.  
  1265. (defun tpu-add-at-bol (text)
  1266.   "Add text to the beginning of each line."
  1267.   (interactive "sString to add: ")
  1268.   (save-excursion
  1269.     (goto-char (point-min))
  1270.     (replace-regexp "^" text)))
  1271.  
  1272. (defun tpu-add-at-eol (text)
  1273.   "Add text to the end of each line."
  1274.   (interactive "sString to add: ")
  1275.   (save-excursion
  1276.     (goto-char (point-min))
  1277.     (replace-regexp "$" text)))
  1278.  
  1279.  
  1280. ;;;
  1281. ;;;  Position
  1282. ;;;
  1283. (defun tpu-next-line (num)
  1284.   "Move to next line.
  1285. Prefix argument serves as a repeat count."
  1286.   (interactive "p")
  1287.   (next-line-internal num)
  1288.   (setq this-command 'next-line))
  1289.  
  1290. (defun tpu-previous-line (num)
  1291.   "Move to previous line.
  1292. Prefix argument serves as a repeat count."
  1293.   (interactive "p")
  1294.   (next-line-internal (- num))
  1295.   (setq this-command 'previous-line))
  1296.  
  1297. (defun next-beginning-of-line (num)
  1298.   "Move to beginning of line; if at beginning, move to beginning of next line.
  1299. Accepts a prefix argument for the number of lines to move."
  1300.   (interactive "p")
  1301.   (backward-char)
  1302.   (beginning-of-line num))
  1303.  
  1304. (defun tpu-end-of-line (num)
  1305.   "Move to the next end of line in the current direction.
  1306. A repeat count means move that many lines."
  1307.   (interactive "p")
  1308.   (if tpu-advance (next-end-of-line num) (previous-end-of-line num)))
  1309.  
  1310. (defun next-end-of-line (num)
  1311.   "Move to end of line; if at end, move to end of next line.
  1312. Accepts a prefix argument for the number of lines to move."
  1313.   (interactive "p")
  1314.   (forward-char)
  1315.   (end-of-line num))
  1316.  
  1317. (defun previous-end-of-line (num)
  1318.   "Move EOL upward.
  1319. Accepts a prefix argument for the number of lines to move."
  1320.   (interactive "p")
  1321.   (end-of-line (- 1 num)))
  1322.  
  1323. (defun tpu-line (num)
  1324.   "Move to the beginning of the next line in the current direction.
  1325. A repeat count means move that many lines."
  1326.   (interactive "p")
  1327.   (if tpu-advance (tpu-forward-line num) (tpu-backward-line num)))
  1328.  
  1329. (defun tpu-forward-line (num)
  1330.   "Move to beginning of next line.
  1331. Prefix argument serves as a repeat count."
  1332.   (interactive "p")
  1333.   (forward-line num))
  1334.  
  1335. (defun tpu-backward-line (num)
  1336.   "Move to beginning of previous line.
  1337. Prefix argument serves as repeat count."
  1338.   (interactive "p")
  1339.   (forward-line (- num)))
  1340.  
  1341. (defun tpu-paragraph (num)
  1342.   "Move to the next paragraph in the current direction.
  1343. A repeat count means move that many paragraphs."
  1344.   (interactive "p")
  1345.   (if tpu-advance
  1346.       (tpu-next-paragraph num) (tpu-previous-paragraph num)))
  1347.  
  1348. (defun tpu-next-paragraph (num)
  1349.   "Move to beginning of the next paragraph.
  1350. Accepts a prefix argument for the number of paragraphs."
  1351.   (interactive "p")
  1352.   (beginning-of-line)
  1353.   (while (and (not (eobp)) (> num 0))
  1354.     (if (re-search-forward "^[ \t]*$" nil t)
  1355.         (if (re-search-forward "[^ \t\n]" nil t)
  1356.             (goto-char (match-beginning 0))
  1357.           (goto-char (point-max))))
  1358.     (setq num (1- num))))
  1359.  
  1360. (defun tpu-previous-paragraph (num)
  1361.   "Move to beginning of previous paragraph.
  1362. Accepts a prefix argument for the number of paragraphs."
  1363.   (interactive "p")
  1364.   (end-of-line)
  1365.   (while (and (not (bobp)) (> num 0))
  1366.     (if (not (and (re-search-backward "^[ \t]*$" nil t)
  1367.                   (re-search-backward "[^ \t\n]" nil t)
  1368.                   (re-search-backward "^[ \t]*$" nil t)
  1369.                   (progn (re-search-forward "[^ \t\n]" nil t)
  1370.                          (goto-char (match-beginning 0)))))
  1371.         (goto-char (point-min)))
  1372.     (setq num (1- num))))
  1373.  
  1374. (defun move-to-beginning nil
  1375.   "Move cursor to the beginning of buffer, but don't set the mark."
  1376.   (interactive)
  1377.   (goto-char (point-min)))
  1378.  
  1379. (defun move-to-end nil
  1380.   "Move cursor to the end of buffer, but don't set the mark."
  1381.   (interactive)
  1382.   (goto-char (point-max))
  1383.   (recenter -1))
  1384.  
  1385. (defun goto-percent (perc)
  1386.   "Move point to ARG percentage of the buffer."
  1387.   (interactive "NGoto-percentage: ")
  1388.   (if (or (> perc 100) (< perc 0))
  1389.       (error "Percentage %d out of range 0 < percent < 100" perc)
  1390.     (goto-char (/ (* (point-max) perc) 100))))
  1391.  
  1392.  
  1393. ;;;
  1394. ;;;  Movement by character
  1395. ;;;
  1396. (defun tpu-char (num)
  1397.   "Move to the next character in the current direction.
  1398. A repeat count means move that many characters."
  1399.   (interactive "p")
  1400.   (if tpu-advance (forward-char num) (backward-char num)))
  1401.  
  1402.  
  1403. ;;;
  1404. ;;;  Movement by word
  1405. ;;;
  1406. (defconst tpu-word-separator-list '()
  1407.   "List of additional word separators.")
  1408. (defconst tpu-skip-chars "^ \t"
  1409.   "Characters to skip when moving by word.
  1410. Additional word separators are added to this string.")
  1411.  
  1412. (defun tpu-word (num)
  1413.   "Move to the beginning of the next word in the current direction.
  1414. A repeat count means move that many words."
  1415.   (interactive "p")
  1416.   (if tpu-advance (forward-to-word num) (backward-to-word num)))
  1417.  
  1418. (defun forward-to-word (num)
  1419.   "Move forward until encountering the beginning of a word.
  1420. With argument, do this that many times."
  1421.   (interactive "p")
  1422.   (while (and (> num 0) (not (eobp)))
  1423.     (let* ((beg (point))
  1424.            (end (prog2 (end-of-line) (point) (goto-char beg))))
  1425.       (cond ((eolp)
  1426.              (forward-char 1))
  1427.             ((memq (char-after (point)) tpu-word-separator-list)
  1428.              (forward-char 1)
  1429.              (skip-chars-forward " \t" end))
  1430.             (t
  1431.              (skip-chars-forward tpu-skip-chars end)
  1432.              (skip-chars-forward " \t" end))))
  1433.     (setq num (1- num))))
  1434.  
  1435. (defun backward-to-word (num)
  1436.   "Move backward until encountering the beginning of a word.
  1437. With argument, do this that many times."
  1438.   (interactive "p")
  1439.   (while (and (> num 0) (not (bobp)))
  1440.     (let* ((beg (point))
  1441.            (end (prog2 (beginning-of-line) (point) (goto-char beg))))
  1442.       (cond ((bolp)
  1443.              ( forward-char -1))
  1444.             ((memq (char-after (1- (point)))  tpu-word-separator-list)
  1445.              (forward-char -1))
  1446.             (t
  1447.              (skip-chars-backward " \t" end)
  1448.              (skip-chars-backward tpu-skip-chars end)
  1449.              (if (and (not (bolp)) (= ?  (char-syntax (char-after (point)))))
  1450.                  (forward-char -1)))))
  1451.     (setq num (1- num))))
  1452.  
  1453. (defun tpu-add-word-separators (separators)
  1454.   "Add new word separators for TPU-edt word commands."
  1455.   (interactive "sSeparators: ")
  1456.   (let* ((n 0) (length (length separators)))
  1457.     (while (< n length)
  1458.       (let ((char (aref separators n))
  1459.             (ss (substring separators n (1+ n))))
  1460.         (cond ((not (memq char tpu-word-separator-list))
  1461.                (setq tpu-word-separator-list
  1462.                      (append ss tpu-word-separator-list))
  1463.                (cond ((= char ?-)
  1464.                       (setq tpu-skip-chars (concat tpu-skip-chars "\\-")))
  1465.                      ((= char ?\\)
  1466.                       (setq tpu-skip-chars (concat tpu-skip-chars "\\\\")))
  1467.                      ((= char ?^)
  1468.                       (setq tpu-skip-chars (concat tpu-skip-chars "\\^")))
  1469.                      (t
  1470.                       (setq tpu-skip-chars (concat tpu-skip-chars ss))))))
  1471.         (setq n (1+ n))))))
  1472.  
  1473. (defun tpu-reset-word-separators nil
  1474.   "Reset word separators to default value."
  1475.   (interactive)
  1476.   (setq tpu-word-separator-list nil)
  1477.   (setq tpu-skip-chars "^ \t"))
  1478.  
  1479. (defun tpu-set-word-separators (separators)
  1480.   "Set new word separators for TPU-edt word commands."
  1481.   (interactive "sSeparators: ")
  1482.   (tpu-reset-word-separators)
  1483.   (tpu-add-word-separators separators))
  1484.  
  1485.  
  1486. ;;;
  1487. ;;;  Movement by page
  1488. ;;;
  1489. (defun tpu-page (num)
  1490.   "Move to the next page in the current direction.
  1491. A repeat count means move that many pages."
  1492.   (interactive "p")
  1493.   (if tpu-advance (forward-page num) (backward-page num))
  1494.   (if (eobp) (recenter -1)))
  1495.  
  1496.  
  1497. ;;;
  1498. ;;;  Window
  1499. ;;;
  1500. (defun tpu-scroll-window (num)
  1501.   "Scroll the display to the next section in the current direction.
  1502. A repeat count means scroll that many sections."
  1503.   (interactive "p")
  1504.   (if tpu-advance (scroll-window-up num) (scroll-window-down num)))
  1505.  
  1506. (defun scroll-window-down (num)
  1507.   "Scroll the display down to the next section.
  1508. A repeat count means scroll that many sections."
  1509.   (interactive "p")
  1510.   (let* ((beg (current-line))
  1511.          (height (1- (window-height)))
  1512.          (lines (* num (/ (* height tpu-percent-scroll) 100))))
  1513.     (next-line-internal (- lines))
  1514.     (if (> lines beg) (recenter 0))))
  1515.  
  1516. (defun scroll-window-up (num)
  1517.   "Scroll the display up to the next section.
  1518. A repeat count means scroll that many sections."
  1519.   (interactive "p")
  1520.   (let* ((beg (current-line))
  1521.          (height (1- (window-height)))
  1522.          (lines (* num (/ (* height tpu-percent-scroll) 100))))
  1523.     (next-line-internal lines)
  1524.     (if (>= (+ lines beg) height) (recenter -1))))
  1525.  
  1526. (defun beginning-of-window nil
  1527.   "Move cursor to top of window."
  1528.   (interactive)
  1529.   (move-to-window-line 0))
  1530.  
  1531. (defun end-of-window nil
  1532.   "Move cursor to bottom of window."
  1533.   (interactive)
  1534.   (move-to-window-line -1))
  1535.  
  1536. (defun line-to-bottom-of-window nil
  1537.   "Move the current line to the bottom of the window."
  1538.   (interactive)
  1539.   (recenter -1))
  1540.  
  1541. (defun line-to-top-of-window nil
  1542.   "Move the current line to the top of the window."
  1543.   (interactive)
  1544.   (recenter 0))
  1545.  
  1546. (defun tpu-pan-right (num)
  1547.   "Pan right 16 characters.
  1548. Accepts a prefix argument for the number of 16 character sets to scroll."
  1549.   (interactive "p")
  1550.   (scroll-left (* 16 num)))
  1551.  
  1552. (defun tpu-pan-left (num)
  1553.   "Pan left 16 characters.
  1554. Accepts a prefix argument for the number of 16 character sets to scroll."
  1555.   (interactive "p")
  1556.   (scroll-right (* 16 num)))
  1557.  
  1558. (defun tpu-next-window nil
  1559.   "Move to the next window."
  1560.   (interactive)
  1561.   (if (one-window-p) (message "There is only one window on screen.")
  1562.     (other-window 1)))
  1563.  
  1564. (defun tpu-previous-window nil
  1565.   "Move to the previous window."
  1566.   (interactive)
  1567.   (if (one-window-p) (message "There is only one window on screen.")
  1568.     (select-window (previous-window))))
  1569.  
  1570.  
  1571. ;;;
  1572. ;;;  Keyboard-style specific
  1573. ;;;
  1574. (defun DEC-mode nil
  1575.   "Defines the DEC style keyboard."
  1576.   (interactive)
  1577.   (global-set-key '(control h) 'next-beginning-of-line)        ; ^H (BS)
  1578.   )
  1579.  
  1580. (defun SGI-mode nil
  1581.   "Defines the SGI style keyboard."
  1582.   (interactive)
  1583.   (global-set-key '(control h) 'backward-delete-char)          ; ^H (BS)
  1584.   )
  1585.  
  1586.  
  1587. ;;;
  1588. ;;;  Direction
  1589. ;;;
  1590. (defun advance-direction nil
  1591.   "Set TPU Advance mode so keypad commands move forward."
  1592.   (interactive)
  1593.   (setq tpu-direction-string " Advance")
  1594.   (setq tpu-advance t)
  1595.   (setq tpu-reverse nil)
  1596.   (tpu-set-search)
  1597.   (update-mode-line))
  1598.  
  1599. (defun backup-direction nil
  1600.   "Set TPU Backup mode so keypad commands move backward."
  1601.   (interactive)
  1602.   (setq tpu-direction-string " Reverse")
  1603.   (setq tpu-advance nil)
  1604.   (setq tpu-reverse t)
  1605.   (tpu-set-search)
  1606.   (update-mode-line))
  1607.  
  1608.  
  1609. ;;;
  1610. ;;;  CSI-map key definitions
  1611. ;;;
  1612. (global-set-key 'up 'tpu-previous-line)                ; up
  1613. (global-set-key 'down 'tpu-next-line)                ; down
  1614. (global-set-key 'left 'backward-char)
  1615. (global-set-key 'right 'forward-char)
  1616. ;; left and right are defined in DEC-mode and SGI-mode
  1617. ;; Sun type key
  1618. (global-set-key 'home 'move-to-beginning)            ; Home
  1619. (global-set-key 'end 'move-to-end)                ; End
  1620. (global-set-key 'pgup 'scroll-window-down)            ; PgUp
  1621. (global-set-key 'pgdn 'scroll-window-up)            ; PgDn
  1622. (global-set-key 'prscr nil)                                 ; PrScr
  1623. (global-set-key 'scrlck nil)                    ; ScrLck
  1624. (global-set-key 'pause nil)                                 ; Pause
  1625. (global-set-key 'delete 'backward-delete-char)            ; Delete
  1626. ;; Dec keys
  1627. (global-set-key 'find 'tpu-search)                ; Find
  1628. (global-set-key 'insert 'tpu-paste)                ; Insert Here
  1629. (global-set-key 'apXK_LineDel 'tpu-cut)                ; Remove
  1630. (global-set-key 'DRemove 'tpu-cut)                ; Remove
  1631. (global-set-key 'select 'tpu-select)                ; Select
  1632. (global-set-key 'prior 'scroll-window-down)            ; Prev Screen
  1633. (global-set-key 'next 'scroll-window-up)            ; Next Screen
  1634. (global-set-key 'f1 'nil)                    ; F1
  1635. (global-set-key 'f2 'nil)                    ; F2
  1636. (global-set-key 'f3 'nil)                    ; F3
  1637. (global-set-key 'f4 'nil)                    ; F4
  1638. (global-set-key 'f5 'nil)                    ; F5
  1639. (global-set-key 'f6 'nil)                    ; F6
  1640. (global-set-key 'f7 'nil)                    ; F7
  1641. (global-set-key 'f8 'nil)                    ; F8
  1642. (global-set-key 'f9 'nil)                    ; F9
  1643. (global-set-key 'f10 'nil)                    ; F10 (was exit)
  1644. (global-set-key 'f11 'insert-escape)                ; F11 (ESC)
  1645. (global-set-key 'f12 'next-beginning-of-line)            ; F12 (BS)
  1646. (global-set-key 'f13 'delete-previous-word)            ; F13 (LF)
  1647. (global-set-key 'f14 'toggle-overwrite-mode)            ; F14
  1648. (global-set-key 'help 'tpu-help)                            ; HELP
  1649. (global-set-key 'menu 'execute-extended-command)            ; DO
  1650. (global-set-key 'f17 'goto-breadcrumb)                ; F17
  1651. (global-set-key 'f18 'nil)                    ; F18
  1652. (global-set-key 'f19 'nil)                    ; F19
  1653. (global-set-key 'f20 'nil)                    ; F20
  1654.  
  1655.  
  1656. ;;;
  1657. ;;;  SS3-map key definitions
  1658. ;;;
  1659. (global-set-key 'kp_f2 'tpu-help)                ; PF2
  1660. (global-set-key 'kp_f3 'tpu-search-again)            ; PF3
  1661. (global-set-key 'kp_f4 'delete-current-line)            ; PF4
  1662. (global-set-key 'kp_equal 'describe-key)            ; Apple KP=
  1663. (global-set-key 'kp_multiply 'delete-current-line)        ; Apple KP*
  1664. (global-set-key 'kp_plus 'delete-current-char)            ; Apple KP+
  1665. (global-set-key 'kp_separator 'delete-current-char)        ; KP,
  1666. (global-set-key 'kp_subtract 'delete-current-word)        ; KP-
  1667. (global-set-key 'kp_decimal 'tpu-select)            ; KP.
  1668. (global-set-key 'kp_0 'tpu-line)                ; KP0
  1669. (global-set-key 'kp_1 'tpu-word)                ; KP1
  1670. (global-set-key 'kp_2 'tpu-end-of-line)                ; KP2
  1671. (global-set-key 'kp_3 'tpu-char)                ; KP3
  1672. (global-set-key 'kp_4 'advance-direction)            ; KP4
  1673. (global-set-key 'kp_5 'backup-direction)            ; KP5
  1674. (global-set-key 'kp_6 'tpu-cut)                    ; KP6
  1675. (global-set-key 'kp_7 'tpu-page)                ; KP7
  1676. (global-set-key 'kp_8 'tpu-scroll-window)            ; KP8
  1677. (global-set-key 'kp_9 'tpu-append-region)            ; KP9
  1678. (global-set-key 'kp_enter 'newline)                ; KPenter
  1679.                                 ;
  1680.                                 ;
  1681. ;;;
  1682. ;;;  GOLD-map key definitions
  1683. ;;;
  1684. (global-set-key '[kp_f1 (control a)] 'nil)            ; ^A
  1685. (global-set-key '[kp_f1 (control b)] 'nil)            ; ^B
  1686. (global-set-key '[kp_f1 (control c)] 'nil)            ; ^C
  1687. (global-set-key '[kp_f1 (control d)] 'nil)            ; ^D
  1688. (global-set-key '[kp_f1 (control e)] 'nil)            ; ^E
  1689. (global-set-key '[kp_f1 (control f)] 'nil)            ; ^F
  1690. (global-set-key '[kp_f1 (control g)] 'keyboard-quit)        ; safety first
  1691. (global-set-key '[kp_f1 (control h)] 'delete-other-windows)    ; BS
  1692. (global-set-key '[kp_f1 (control i)] 'other-window)        ; TAB
  1693. (global-set-key '[kp_f1 (control j)] 'nil)            ; ^J
  1694. (global-set-key '[kp_f1 (control k)] 'nil)            ; ^K
  1695. (global-set-key '[kp_f1 (control l)] 'downcase-region)        ; ^L
  1696. (global-set-key '[kp_f1 (control m)] 'nil)            ; ^M
  1697. (global-set-key '[kp_f1 (control n)] 'nil)            ; ^N
  1698. (global-set-key '[kp_f1 (control o)] 'nil)            ; ^O
  1699. (global-set-key '[kp_f1 (control p)] 'nil)            ; ^P
  1700. (global-set-key '[kp_f1 (control q)] 'nil)            ; ^Q
  1701. (global-set-key '[kp_f1 (control r)] 'nil)            ; ^R
  1702. (global-set-key '[kp_f1 (control s)] 'nil)            ; ^S
  1703. (global-set-key '[kp_f1 (control t)] 'nil)            ; ^T
  1704. (global-set-key '[kp_f1 (control u)] 'upcase-region)        ; ^U
  1705. (global-set-key '[kp_f1 (control v)] 'nil)            ; ^V
  1706. (global-set-key '[kp_f1 (control w)] 'write-current-buffers)    ; ^W
  1707. (global-set-key '[kp_f1 (control x)] 'nil)            ; ^X
  1708. (global-set-key '[kp_f1 (control y)] 'nil)            ; ^Y
  1709. (global-set-key '[kp_f1 (control z)] 'nil)            ; ^Z
  1710. (global-set-key '[kp_f1 ? ] 'undo)                ; SPC
  1711. (global-set-key '[kp_f1 ?!] 'change-counter-format)        ; !
  1712. (global-set-key '[kp_f1 ?#] 'insert-counter)            ; #
  1713. (global-set-key '[kp_f1 ?$] 'tpu-add-at-eol)            ; $
  1714. (global-set-key '[kp_f1 ?%] 'goto-percent)            ; %
  1715. (global-set-key '[kp_f1 ?&] nil)                ; &
  1716. (global-set-key '[kp_f1 ?(] nil)                ; (
  1717. (global-set-key '[kp_f1 ?)] nil)                ; )
  1718. (global-set-key '[kp_f1 ?*] 'tpu-toggle-regexp)            ; *
  1719. (global-set-key '[kp_f1 ?+] 'region-length-to-counter)        ; +
  1720. (global-set-key '[kp_f1 ?,] 'goto-breadcrumb)            ; ,
  1721. (global-set-key '[kp_f1 ?-] 'repeat-command--)            ; -
  1722. (global-set-key '[kp_f1 ?.] 'drop-breadcrumb)            ; .
  1723. (global-set-key '[kp_f1 ?/] 'tpu-emacs-replace)            ; /
  1724. (global-set-key '[kp_f1 ?0] 'repeat-command-0)            ; 0
  1725. (global-set-key '[kp_f1 ?1] 'repeat-command-1)            ; 1
  1726. (global-set-key '[kp_f1 ?2] 'repeat-command-2)            ; 2
  1727. (global-set-key '[kp_f1 ?3] 'repeat-command-3)            ; 3
  1728. (global-set-key '[kp_f1 ?4] 'repeat-command-4)            ; 4
  1729. (global-set-key '[kp_f1 ?5] 'repeat-command-5)            ; 5
  1730. (global-set-key '[kp_f1 ?6] 'repeat-command-6)            ; 6
  1731. (global-set-key '[kp_f1 ?7] 'repeat-command-7)            ; 7
  1732. (global-set-key '[kp_f1 ?8] 'repeat-command-8)            ; 8
  1733. (global-set-key '[kp_f1 ?9] 'repeat-command-9)            ; 9
  1734. (global-set-key '[kp_f1 ?:] 'nil)                ; :
  1735. (global-set-key '[kp_f1 ?;] 'tpu-trim-line-ends)                ; ;
  1736. (global-set-key '[kp_f1 ?<] 'decr-counter)            ; <
  1737. (global-set-key '[kp_f1 ?=] 'set-counter)            ; =
  1738. (global-set-key '[kp_f1 ?>] 'incr-counter)            ; >
  1739. (global-set-key '[kp_f1 ??] 'spell-check)            ; ?
  1740. (global-set-key '[kp_f1 ?A] 'toggle-newline-and-indent)        ; A
  1741. (global-set-key '[kp_f1 ?B] 'next-buffer)            ; B
  1742. (global-set-key '[kp_f1 ?C] 'repeat-complex-command)        ; C
  1743. (global-set-key '[kp_f1 ?D] 'shell-command)            ; D
  1744. (global-set-key '[kp_f1 ?E] nil)                ; E (was exit)
  1745. (global-set-key '[kp_f1 ?F] 'nil)                ; F
  1746. (global-set-key '[kp_f1 ?G] 'Get)                ; G
  1747. (global-set-key '[kp_f1 ?H] 'nil)                ; H
  1748. (global-set-key '[kp_f1 ?I] 'include)                ; I
  1749. (global-set-key '[kp_f1 ?K] 'tpu-kill-buffer)            ; K
  1750. (global-set-key '[kp_f1 ?L] 'tpu-what-line)            ; L
  1751. (global-set-key '[kp_f1 ?M] 'buffer-menu)            ; M
  1752. (global-set-key '[kp_f1 ?N] 'next-file-buffer)            ; N
  1753. (global-set-key '[kp_f1 ?O] 'occur)                ; O
  1754. (global-set-key '[kp_f1 ?P] 'lpr-buffer)            ; P
  1755. (global-set-key '[kp_f1 ?Q] 'nil)                ; Q (was quit)
  1756. (global-set-key '[kp_f1 ?R] 'tpu-toggle-rectangle)        ; R
  1757. (global-set-key '[kp_f1 ?S] 'replace)                ; S
  1758. (global-set-key '[kp_f1 ?T] 'line-to-top-of-window)        ; T
  1759. (global-set-key '[kp_f1 ?U] 'undo)                ; U
  1760. (global-set-key '[kp_f1 ?V] 'tpu-version)            ; V
  1761. (global-set-key '[kp_f1 ?W] 'save-buffer)            ; W
  1762. (global-set-key '[kp_f1 ?X] 'save-all-buffers-kill-emacs)    ; X
  1763. (global-set-key '[kp_f1 ?Y] 'copy-region-as-kill)        ; Y
  1764. (global-set-key '[kp_f1 ?Z] 'suspend-emacs)            ; Z
  1765. (global-set-key '[kp_f1 ?\[] 'blink-matching-open)        ; [
  1766. (global-set-key '[kp_f1 ?\\] 'nil)                ; \
  1767. (global-set-key '[kp_f1 ?\]] 'blink-matching-open)        ; ]
  1768. (global-set-key '[kp_f1 ?^] 'tpu-add-at-bol)            ; ^
  1769. (global-set-key '[kp_f1 ?_] 'split-window-vertically)        ; -
  1770. (global-set-key '[kp_f1 ?`] 'what-line)                ; `
  1771. (global-set-key '[kp_f1 ?a] 'toggle-newline-and-indent)        ; a
  1772. (global-set-key '[kp_f1 ?b] 'next-buffer)            ; b
  1773. (global-set-key '[kp_f1 ?c] 'repeat-complex-command)        ; c
  1774. (global-set-key '[kp_f1 ?d] 'shell-command)            ; d
  1775. (global-set-key '[kp_f1 ?e] 'nil)                ; e (was exit)
  1776. (global-set-key '[kp_f1 ?f] 'nil)                ; f
  1777. (global-set-key '[kp_f1 ?g] 'Get)                ; g
  1778. (global-set-key '[kp_f1 ?h] 'nil)                ; h
  1779. (global-set-key '[kp_f1 ?i] 'include)                ; i
  1780. (global-set-key '[kp_f1 ?k] 'tpu-kill-buffer)            ; k
  1781. (global-set-key '[kp_f1 ?l] 'goto-line)                ; l
  1782. (global-set-key '[kp_f1 ?m] 'buffer-menu)            ; m
  1783. (global-set-key '[kp_f1 ?n] 'next-file-buffer)            ; n
  1784. (global-set-key '[kp_f1 ?o] 'occur)                ; o
  1785. (global-set-key '[kp_f1 ?p] 'lpr-region)            ; p
  1786. (global-set-key '[kp_f1 ?q] 'nil)                ; q (was quit)
  1787. (global-set-key '[kp_f1 ?r] 'tpu-toggle-rectangle)        ; r
  1788. (global-set-key '[kp_f1 ?s] 'replace)                ; s
  1789. (global-set-key '[kp_f1 ?t] 'line-to-top-of-window)        ; t
  1790. (global-set-key '[kp_f1 ?u] 'undo)                ; u
  1791. (global-set-key '[kp_f1 ?v] 'tpu-version)            ; v
  1792. (global-set-key '[kp_f1 ?w] 'save-buffer)            ; w
  1793. (global-set-key '[kp_f1 ?x] 'save-all-buffers-kill-emacs)    ; x
  1794. (global-set-key '[kp_f1 ?y] 'copy-region-as-kill)        ; y
  1795. (global-set-key '[kp_f1 ?z] 'suspend-emacs)            ; z
  1796. (global-set-key '[kp_f1 ?{] 'nil)                ; {
  1797. (global-set-key '[kp_f1 ?|] 'split-window-horizontally)        ; |
  1798. (global-set-key '[kp_f1 ?}] 'nil)                ; }
  1799. (global-set-key '[kp_f1 ?~] 'exchange-point-and-mark)        ; ~
  1800. (global-set-key '[kp_f1 delete] 'delete-window)            ; <X]
  1801.  
  1802.  
  1803. ;;;
  1804. ;;;  GOLD-CSI-map key definitions
  1805. ;;;
  1806. (global-set-key '[kp_f1 find] 'nil)                ; Find
  1807. (global-set-key '[kp_f1 insert] 'nil)                ; Insert Here
  1808. (global-set-key '[kp_f1 apXK_LineDel] 'tpu-store-text)        ; Remove
  1809. (global-set-key '[kp_f1 select] 'tpu-unselect)            ; Select
  1810. (global-set-key '[kp_f1 prior] 'tpu-previous-window)        ; Prev Screen
  1811. (global-set-key '[kp_f1 next] 'tpu-next-window)                 ; Next Screen
  1812.  
  1813. (global-set-key '[kp_f1 f1] 'nil)                ; F1
  1814. (global-set-key '[kp_f1 f2] 'nil)                ; F2
  1815. (global-set-key '[kp_f1 f3] 'nil)                ; F3
  1816. (global-set-key '[kp_f1 f4] 'nil)                ; F4
  1817. (global-set-key '[kp_f1 f5] 'nil)                    ; F5
  1818. (global-set-key '[kp_f1 f6] 'nil)                     ; F6
  1819. (global-set-key '[kp_f1 f7] 'nil)                ; F7
  1820. (global-set-key '[kp_f1 f8] 'nil)                ; F8
  1821. (global-set-key '[kp_f1 f9] 'nil)                ; F9
  1822. (global-set-key '[kp_f1 f10] 'nil)                ; F10
  1823. (global-set-key '[kp_f1 f11] 'nil)                ; F11
  1824. (global-set-key '[kp_f1 f12] 'nil)                ; F12
  1825. (global-set-key '[kp_f1 f13] 'nil)                ; F13
  1826. (global-set-key '[kp_f1 f14] 'nil)                ; F14
  1827. (global-set-key '[kp_f1 help] 'describe-bindings)        ; HELP
  1828. (global-set-key '[kp_f1 menu] 'nil)                ; DO
  1829. (global-set-key '[kp_f1 f17] 'drop-breadcrumb)            ; F17
  1830. (global-set-key '[kp_f1 f18] 'nil)                ; F18
  1831. (global-set-key '[kp_f1 f19] 'nil)                ; F19
  1832. (global-set-key '[kp_f1 f20] 'nil)                ; F20
  1833. (global-set-key '[kp_f1 up] 'move-to-beginning)            ; up-arrow
  1834. (global-set-key '[kp_f1 down] 'move-to-end)            ; down-arrow
  1835. (global-set-key '[kp_f1 right] 'end-of-line)            ; right-arrow
  1836. (global-set-key '[kp_f1 left] 'beginning-of-line)        ; left-arrow
  1837. (global-set-key '[kp_f1 home] 'move-to-beginning)        ; Home
  1838. (global-set-key '[kp_f1 delete] 'backward-delete-char)        ; Delete
  1839. (global-set-key '[kp_f1 end] 'move-to-end)            ; End
  1840. (global-set-key '[kp_f1 pgup] 'scroll-window-down)        ; PgUp
  1841. (global-set-key '[kp_f1 pgdn] 'scroll-window-up)        ; PgDn
  1842. (global-set-key '[kp_f1 prscr] nil)                ; PrScr
  1843. (global-set-key '[kp_f1 scrlck] nil)                ; ScrLck
  1844. (global-set-key '[kp_f1 pause] nil)                ; Pause
  1845.  
  1846.  
  1847. ;;;
  1848. ;;;  GOLD-SS3-map key definitions
  1849. ;;;
  1850. (global-set-key '[kp_f1 kp_f1] 'keyboard-quit)            ; PF1
  1851. (global-set-key '[kp_f1 kp_f2] 'help-for-help)            ; PF2
  1852. (global-set-key '[kp_f1 kp_f3] 'tpu-search)            ; PF3
  1853. (global-set-key '[kp_f1 kp_f4] 'undelete-lines)            ; PF4
  1854. (global-set-key '[kp_f1 kp_0] 'open-line)            ; KP0
  1855. (global-set-key '[kp_f1 kp_1] 'tpu-change-case)            ; KP1
  1856. (global-set-key '[kp_f1 kp_2] 'delete-to-eol)            ; KP2
  1857. (global-set-key '[kp_f1 kp_3] 'tpu-special-insert)        ; KP3
  1858. (global-set-key '[kp_f1 kp_4] 'move-to-end)            ; KP4
  1859. (global-set-key '[kp_f1 kp_5] 'move-to-beginning)        ; KP5
  1860. (global-set-key '[kp_f1 kp_6] 'tpu-paste)            ; KP6
  1861. (global-set-key '[kp_f1 kp_7] 'execute-extended-command)    ; KP7
  1862. (global-set-key '[kp_f1 kp_8] 'tpu-fill)            ; KP8
  1863. (global-set-key '[kp_f1 kp_9] 'tpu-replace)            ; KP9
  1864. (global-set-key '[kp_f1 kp_subtract] 'undelete-words)        ; KP-
  1865. (global-set-key '[kp_f1 kp_separator] 'undelete-char)        ; KP,
  1866. (global-set-key '[kp_f1 kp_decimal] 'tpu-unselect)        ; KP.
  1867. (global-set-key '[kp_f1 kp_enter] 'tpu-substitute)        ; KPenter
  1868.  
  1869.  
  1870. ;;;
  1871. ;;;  Repeat complex command map additions to make arrows work
  1872. ;;;
  1873. ;(define-key repeat-complex-command-map "\e[A" 'previous-complex-command)
  1874. ;(define-key repeat-complex-command-map "\e[B" 'next-complex-command)
  1875. ;(define-key repeat-complex-command-map "\eOA" 'previous-complex-command)
  1876. ;(define-key repeat-complex-command-map "\eOB" 'next-complex-command)
  1877.  
  1878.  
  1879. ;;;
  1880. ;;;  Minibuffer map additions to make KP_enter = RET
  1881. ;;;
  1882. ;(define-key minibuffer-local-map "\eOM" 'exit-minibuffer)
  1883. ;(define-key minibuffer-local-ns-map "\eOM" 'exit-minibuffer)
  1884. ;(define-key minibuffer-local-completion-map "\eOM" 'exit-minibuffer)
  1885. ;(define-key minibuffer-local-must-match-map "\eOM" 'minibuffer-complete-and-exit)
  1886. ;(define-key repeat-complex-command-map "\eOM" 'exit-minibuffer)
  1887.  
  1888.  
  1889. ;;;
  1890. ;;;  Start and Stop TPU-edt
  1891. ;;;
  1892. (defun use-tpu nil
  1893.   "Sets TPU-edt emulation on."
  1894.   (interactive)
  1895. ;  (replace-global-key "\e[" CSI-map)                           ; CSI map
  1896. ;  (replace-global-key "\eO" SS3-map)                           ; SS3 map
  1897.   (replace-global-key '(control ?\\) 'quoted-insert)        ; ^\
  1898.   (replace-global-key '(control a) 'toggle-overwrite-mode)    ; ^A
  1899.   (replace-global-key '(control b) 'repeat-complex-command)    ; ^B
  1900.   (replace-global-key '(control f) 'set-visited-file-name)    ; ^F
  1901.   (replace-global-key '(control j) 'delete-previous-word)    ; ^J (LF)
  1902.   (replace-global-key '(control k) 'define-macro-key)        ; ^K
  1903.   (replace-global-key '(control l) 'insert-formfeed)        ; ^L (FF)
  1904.   (replace-global-key '(control r) 'recenter)            ; ^R
  1905.   (replace-global-key '(control u) 'delete-to-bol)        ; ^U
  1906.   (replace-global-key '(control v) 'quoted-insert)        ; ^V
  1907.   (replace-global-key '(control w) 'redraw-display)        ; ^W
  1908. ;  (replace-global-key '(control z) 'exit)            ; ^Z
  1909. ;  (define-key SS3-map "P" GOLD-map)                            ; GOLD map
  1910. ;  (define-key GOLD-map "\e[" GOLD-CSI-map)                     ; GOLD-CSI map
  1911. ;  (define-key GOLD-map "\eO" GOLD-SS3-map)                     ; GOLD-SS3 map
  1912.   (require 'picture)
  1913.   (DEC-mode)
  1914.   (advance-direction)
  1915.   ;; define ispell functions
  1916.   (autoload 'ispell-word "ispell" "Check spelling of word at or before point" t)
  1917.   (autoload 'ispell-complete-word "ispell" "Complete word at or before point" t)
  1918.   (autoload 'ispell-buffer "ispell" "Check spelling of entire buffer" t)
  1919.   (autoload 'ispell-region "ispell" "Check spelling of region" t)
  1920.   ;; set display line truncation and scrolling like TPU
  1921.   (setq-default page-delimiter "\f")
  1922.   (setq-default truncate-lines t)
  1923.   (setq scroll-step 1)
  1924.   ;; Make direction of motion show in mode line
  1925.   ;; while TPU emulation is turned on.
  1926.   ;; Note that the keypad is always turned on when in Emacs.
  1927.   (or (assq 'tpu-rectangular-p minor-mode-alist)
  1928.       (setq minor-mode-alist (cons '(tpu-rectangular-p tpu-rectangle-string)
  1929.                                    minor-mode-alist)))
  1930.   (or (assq 'tpu-direction-string minor-mode-alist)
  1931.       (setq minor-mode-alist (cons '(tpu-direction-string tpu-direction-string)
  1932.                                    minor-mode-alist)))
  1933.   (or (assq 'newline-and-indent-p minor-mode-alist)
  1934.       (setq minor-mode-alist
  1935.             (cons '(newline-and-indent-p newline-and-indent-p-string)
  1936.                   minor-mode-alist))))
  1937.  
  1938. (defun cancel-tpu nil
  1939.   "Sets TPU-edt emulation off."
  1940.   (interactive)
  1941. ;  (restore-global-key "\e[")
  1942. ;  (restore-global-key "\eO")
  1943.   (restore-global-key '(control a))                ;
  1944.   (restore-global-key '(control b))                ;
  1945.   (restore-global-key '(control ?\\))                ;
  1946.   (restore-global-key '(control f))                ;
  1947.   (restore-global-key '(control h))                ;
  1948.   (restore-global-key '(control j))                ;
  1949.   (restore-global-key '(control k))                ;
  1950.   (restore-global-key '(control l))                ;
  1951.   (restore-global-key '(control r))                ;
  1952.   (restore-global-key '(control u))                ;
  1953.   (restore-global-key '(control v))                ;
  1954.   (restore-global-key '(control w))                ;
  1955. ;  (restore-global-key '(control z))                ;
  1956.   (setq tpu-direction-string nil)
  1957.   (setq-default page-delimiter "^\f")
  1958.   (setq-default truncate-lines nil)
  1959.   (setq scroll-step 0))
  1960.  
  1961. (use-tpu)
  1962.