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