lisp/emulation/tpu-edt.el

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