Source

tpu / tpu-extras.el

Full commit
  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
;;; tpu-extras.el --- Scroll margins and free cursor mode for TPU-edt

;; Copyright (C) 1993, 1994, 1995 Free Software Foundation, Inc.

;; Author: Rob Riepel <riepel@networking.stanford.edu>
;; Maintainer: Rob Riepel <riepel@networking.stanford.edu>
;; Keywords: emulations

;; This file is part of XEmacs.
;; XEmacs modifications by Kevin Oberman <oberman@es.net>

;; XEmacs is free software; you can redistribute it and/or modify it
;; under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; XEmacs is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with XEmacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Synced up with FSF 19.34 and XEmacs 19.16

;;; Commentary:

;;  Use the functions defined here to customize TPU-edt to your tastes by
;;  setting scroll margins and/or turning on free cursor mode.  Here's an
;;  example for your .emacs file.

;;     (tpu-set-cursor-free)                   ; Set cursor free.
;;     (tpu-set-scroll-margins "10%" "15%")    ; Set scroll margins.

;;  Scroll margins and cursor binding can be changed from within emacs using
;;  the following commands:

;;     tpu-set-scroll-margins  or   set scroll margins
;;     tpu-set-cursor-bound    or   set cursor bound
;;     tpu-set-cursor-free     or   set cursor free

;;  Additionally, Gold-F toggles between bound and free cursor modes.

;;  Note that switching out of free cursor mode or exiting TPU-edt while in
;;  free cursor mode strips trailing whitespace from every line in the file.


;;; Details:

;;  The functions contained in this file implement scroll margins and free
;;  cursor mode.  The following keys and commands are affected.

;;       key/command   function                        scroll   cursor

;;       Up-Arrow      previous line                     x        x
;;       Down-Arrow    next line                         x        x
;;       Right-Arrow   next character                             x
;;       Left-Arrow    previous character                         x
;;       KP0           next or previous line             x
;;       KP7           next or previous page             x
;;       KP8           next or previous screen           x
;;       KP2           next or previous end-of-line      x        x
;;       Control-e     current end-of-line                        x
;;       Control-h     previous beginning-of-line        x
;;       Next Scr      next screen                       x
;;       Prev Scr      previous screen                   x
;;       Search        find a string                     x
;;       Replace       find and replace a string         x
;;       Newline       insert a newline                  x
;;       Paragraph     next or previous paragraph        x
;;       Auto-Fill     break lines on spaces             x

;;  These functions are not part of the base TPU-edt for the following
;;  reasons:

;;  Free cursor mode is implemented with the emacs picture-mode functions.
;;  These functions support moving the cursor all over the screen, however,
;;  when the cursor is moved past the end of a line, spaces or tabs are
;;  appended to the line - even if no text is entered in that area.  In
;;  order for a free cursor mode to work exactly like TPU/edt, this trailing
;;  whitespace needs to be dealt with in every function that might encounter
;;  it.  Such global changes are impractical, however, free cursor mode is
;;  too valuable to abandon completely, so it has been implemented in those
;;  functions where it serves best.

;;  The implementation of scroll margins adds overhead to previously
;;  simple and often used commands.  These commands are now responsible
;;  for their normal operation and part of the display function.  There
;;  is a possibility that this display overhead could adversely affect the
;;  performance of TPU-edt on slower computers.  In order to support the
;;  widest range of computers, scroll margin support is optional.

;;  It's actually not known whether the overhead associated with scroll
;;  margin support is significant.  If you find that it is, please send
;;  a note describing the extent of the performance degradation.  Be sure
;;  to include a description of the platform where you're running TPU-edt.
;;  Send your note to the address provided by Gold-V.

;;  Even with these differences and limitations, these functions implement
;;  important aspects of the real TPU/edt.  Those who miss free cursor mode
;;  and/or scroll margins will appreciate these implementations.

;;; Code:


;;;  Gotta have tpu-edt

(require 'tpu-edt)


;;;  Customization variables

(defconst tpu-top-scroll-margin 0
  "*Scroll margin at the top of the screen.
Interpreted as a percent of the current window size.")
(defconst tpu-bottom-scroll-margin 0
  "*Scroll margin at the bottom of the screen.
Interpreted as a percent of the current window size.")

(defvar tpu-backward-char-like-tpu t
  "*If non-nil, in free cursor mode backward-char (left-arrow) works
just like TPU/edt.  Otherwise, backward-char will move to the end of
the previous line when starting from a line beginning.")


;;;  Global variables

(defvar tpu-cursor-free nil
  "If non-nil, let the cursor roam free.")


;;;  Hooks  --  Set cursor free in picture mode.
;;;             Clean up when writing a file from cursor free mode.

(add-hook 'picture-mode-hook 'tpu-set-cursor-free)

(defun tpu-write-file-hook nil
  "Eliminate whitespace at ends of lines, if the cursor is free."
  (if (and (buffer-modified-p) tpu-cursor-free) (picture-clean)))

(or (memq 'tpu-write-file-hook write-file-hooks)
    (setq write-file-hooks
	  (cons 'tpu-write-file-hook write-file-hooks)))


;;;  Utility routines for implementing scroll margins

(defun tpu-top-check (beg lines)
  "Enforce scroll margin at the top of screen."
  (let ((margin	 (/ (* (window-height) tpu-top-scroll-margin) 100)))
    (cond ((< beg margin) (recenter beg))
	  ((< (- beg lines) margin) (recenter margin)))))

(defun tpu-bottom-check (beg lines)
  "Enforce scroll margin at the bottom of screen."
  (let* ((height (window-height))
	 (margin (+ 1 (/ (* height tpu-bottom-scroll-margin) 100)))
	 ;; subtract 1 from height because it includes mode line
	 (difference (- height margin 1)))
    (cond ((> beg difference) (recenter beg))
	  ((> (+ beg lines) difference) (recenter (- margin))))))


;;;  Movement by character

(defun tpu-forward-char (num)
  "Move right ARG characters (left if ARG is negative)."
  (interactive "p")
  (setq zmacs-region-stays t)
  (if tpu-cursor-free (picture-forward-column num) (forward-char num)))

(defun tpu-backward-char (num)
  "Move left ARG characters (right if ARG is negative)."
  (interactive "p")
  (setq zmacs-region-stays t)
  (cond ((not tpu-cursor-free)
	 (backward-char num))
	(tpu-backward-char-like-tpu
	 (picture-backward-column num))
	((bolp)
	 (backward-char 1)
	 (picture-end-of-line)
	 (picture-backward-column (1- num)))
	(t
	 (picture-backward-column num))))


;;;  Movement by line

(defun tpu-next-line (num)
  "Move to next line.
Prefix argument serves as a repeat count."
  (interactive "p")
  (setq zmacs-region-stays t)
  (let ((beg (tpu-current-line)))
    (if tpu-cursor-free (or (eobp) (picture-move-down num))
      (next-line-internal num))
    (tpu-bottom-check beg num)
    (setq this-command 'next-line)))

(defun tpu-previous-line (num)
  "Move to previous line.
Prefix argument serves as a repeat count."
  (interactive "p")
  (setq zmacs-region-stays t)
  (let ((beg (tpu-current-line)))
    (if tpu-cursor-free (picture-move-up num) (next-line-internal (- num)))
    (tpu-top-check beg num)
    (setq this-command 'previous-line)))

(defun tpu-next-beginning-of-line (num)
  "Move to beginning of line; if at beginning, move to beginning of next line.
Accepts a prefix argument for the number of lines to move."
  (interactive "p")
  (setq zmacs-region-stays t)
  (let ((beg (tpu-current-line)))
    (backward-char 1)
    (forward-line (- 1 num))
    (tpu-top-check beg num)))

(defun tpu-next-end-of-line (num)
  "Move to end of line; if at end, move to end of next line.
Accepts a prefix argument for the number of lines to move."
  (interactive "p")
  (setq zmacs-region-stays t)
  (let ((beg (tpu-current-line)))
    (cond (tpu-cursor-free
	   (let ((beg (point)))
	     (if (< 1 num) (forward-line num))
	     (picture-end-of-line)
	     (if (<= (point) beg) (progn (forward-line) (picture-end-of-line)))))
	  (t
	   (forward-char)
	   (end-of-line num)))
    (tpu-bottom-check beg num)))

(defun tpu-previous-end-of-line (num)
  "Move EOL upward.
Accepts a prefix argument for the number of lines to move."
  (interactive "p")
  (setq zmacs-region-stays t)
  (let ((beg (tpu-current-line)))
    (cond (tpu-cursor-free
	   (picture-end-of-line (- 1 num)))
	  (t
	   (end-of-line (- 1 num))))
    (tpu-top-check beg num)))

(defun tpu-current-end-of-line nil
  "Move point to end of current line."
  (interactive)
  (setq zmacs-region-stays t)
  (let ((beg (point)))
    (if tpu-cursor-free (picture-end-of-line) (end-of-line))
    (if (= beg (point)) (message "You are already at the end of a line."))))

(defun tpu-forward-line (num)
  "Move to beginning of next line.
Prefix argument serves as a repeat count."
  (interactive "p")
  (let ((beg (tpu-current-line)))
    (next-line-internal num)
    (tpu-bottom-check beg num)
    (beginning-of-line)))

(defun tpu-backward-line (num)
  "Move to beginning of previous line.
Prefix argument serves as repeat count."
  (interactive "p")
  (setq zmacs-region-stays t)
  (let ((beg (tpu-current-line)))
    (or (bolp) (>= 0 num) (setq num (- num 1)))
    (next-line-internal (- num))
    (tpu-top-check beg num)
    (beginning-of-line)))


;;;  Movement by paragraph

(defun tpu-paragraph (num)
  "Move to the next paragraph in the current direction.
A repeat count means move that many paragraphs."
  (interactive "p")
  (setq zmacs-region-stays t)
  (let* ((left nil)
	 (beg (tpu-current-line))
	 (height (window-height))
	 (top-percent
	  (if (= 0 tpu-top-scroll-margin) 10 tpu-top-scroll-margin))
	 (bottom-percent
	  (if (= 0 tpu-bottom-scroll-margin) 15 tpu-bottom-scroll-margin))
	 (top-margin (/ (* height top-percent) 100))
	 (bottom-up-margin (+ 1 (/ (* height bottom-percent) 100)))
	 (bottom-margin (max beg (- height bottom-up-margin 1)))
	 (top (save-excursion (move-to-window-line top-margin) (point)))
	 (bottom (save-excursion (move-to-window-line bottom-margin) (point)))
	 (far (save-excursion
		(goto-char bottom) (forward-line (- height 2)) (point))))
    (cond (tpu-advance
	   (tpu-next-paragraph num)
	   (cond((> (point) far)
		 (setq left (save-excursion (forward-line height)))
		 (if (= 0 left) (recenter top-margin)
		   (recenter (- left bottom-up-margin))))
		(t
		 (and (> (point) bottom) (recenter bottom-margin)))))
	  (t
	   (tpu-previous-paragraph num)
	   (and (< (point) top) (recenter (min beg top-margin)))))))


;;;  Movement by page

(defun tpu-page (num)
  "Move to the next page in the current direction.
A repeat count means move that many pages."
  (interactive "p")
  (setq zmacs-region-stays t)
  (let* ((left nil)
	 (beg (tpu-current-line))
	 (height (window-height))
	 (top-percent
	  (if (= 0 tpu-top-scroll-margin) 10 tpu-top-scroll-margin))
	 (bottom-percent
	  (if (= 0 tpu-bottom-scroll-margin) 15 tpu-bottom-scroll-margin))
	 (top-margin (/ (* height top-percent) 100))
	 (bottom-up-margin (+ 1 (/ (* height bottom-percent) 100)))
	 (bottom-margin (max beg (- height bottom-up-margin 1)))
	 (top (save-excursion (move-to-window-line top-margin) (point)))
	 (bottom (save-excursion (move-to-window-line bottom-margin) (point)))
	 (far (save-excursion
		(goto-char bottom) (forward-line (- height 2)) (point))))
    (cond (tpu-advance
	   (forward-page num)
	   (cond((> (point) far)
		 (setq left (save-excursion (forward-line height)))
		 (if (= 0 left) (recenter top-margin)
		   (recenter (- left bottom-up-margin))))
		(t
		 (and (> (point) bottom) (recenter bottom-margin)))))
	  (t
	   (backward-page num)
	   (and (< (point) top) (recenter (min beg top-margin)))))))


;;;  Scrolling

(defun tpu-scroll-window-down (num)
  "Scroll the display down to the next section.
A repeat count means scroll that many sections."
  (interactive "p")
  (setq zmacs-region-stays t)
  (let* ((beg (tpu-current-line))
	 (height (1- (window-height)))
	 (lines (* num (/ (* height tpu-percent-scroll) 100))))
    (next-line-internal (- lines))
    (tpu-top-check beg lines)))

(defun tpu-scroll-window-up (num)
  "Scroll the display up to the next section.
A repeat count means scroll that many sections."
  (interactive "p")
  (setq zmacs-region-stays t)
  (let* ((beg (tpu-current-line))
	 (height (1- (window-height)))
	 (lines (* num (/ (* height tpu-percent-scroll) 100))))
    (next-line-internal lines)
    (tpu-bottom-check beg lines)))


;;;  Replace the TPU-edt internal search function

(defun tpu-search-internal (pat &optional quiet)
  "Search for a string or regular expression."
  (let* ((left nil)
	 (beg (tpu-current-line))
	 (height (window-height))
	 (top-percent
	  (if (= 0 tpu-top-scroll-margin) 10 tpu-top-scroll-margin))
	 (bottom-percent
	  (if (= 0 tpu-bottom-scroll-margin) 15 tpu-bottom-scroll-margin))
	 (top-margin (/ (* height top-percent) 100))
	 (bottom-up-margin (+ 1 (/ (* height bottom-percent) 100)))
	 (bottom-margin (max beg (- height bottom-up-margin 1)))
	 (top (save-excursion (move-to-window-line top-margin) (point)))
	 (bottom (save-excursion (move-to-window-line bottom-margin) (point)))
	 (far (save-excursion
		(goto-char bottom) (forward-line (- height 2)) (point))))
    (tpu-search-internal-core pat quiet)
    (if tpu-searching-forward
	(cond((> (point) far)
	      (setq left (save-excursion (forward-line height)))
	      (if (= 0 left) (recenter top-margin)
		(recenter (- left bottom-up-margin))))
	     (t
	      (and (> (point) bottom) (recenter bottom-margin))))
      (and (< (point) top) (recenter (min beg top-margin))))))



;;;  Replace the newline, newline-and-indent, and do-auto-fill functions

(or (fboundp 'tpu-old-newline)
    (fset 'tpu-old-newline (symbol-function 'newline)))
(or (fboundp 'tpu-old-do-auto-fill)
    (fset 'tpu-old-do-auto-fill (symbol-function 'do-auto-fill)))
(or (fboundp 'tpu-old-newline-and-indent)
    (fset 'tpu-old-newline-and-indent (symbol-function 'newline-and-indent)))

(defun newline (&optional num)
  "Insert a newline.  With arg, insert that many newlines.
In Auto Fill mode, can break the preceding line if no numeric arg.
This is the TPU-edt version that respects the bottom scroll margin."
  (interactive "p")
  (setq zmacs-region-stays t)
  (let ((beg (tpu-current-line)))
    (or num (setq num 1))
    (tpu-old-newline num)
    (tpu-bottom-check beg num)))

(defun newline-and-indent nil
  "Insert a newline, then indent according to major mode.
Indentation is done using the current indent-line-function.
In programming language modes, this is the same as TAB.
In some text modes, where TAB inserts a tab, this indents
to the specified left-margin column.  This is the TPU-edt
version that respects the bottom scroll margin."
  (interactive)
  (setq zmacs-region-stays t)
  (let ((beg (tpu-current-line)))
    (tpu-old-newline-and-indent)
    (tpu-bottom-check beg 1)))

(defun do-auto-fill nil
  "TPU-edt version that respects the bottom scroll margin."
  (let ((beg (tpu-current-line)))
    (tpu-old-do-auto-fill)
    (tpu-bottom-check beg 1)))


;;;  Function to set scroll margins

;;;###autoload
(defun tpu-set-scroll-margins (top bottom)
  "Set scroll margins."
  (interactive
   "sEnter top scroll margin (N lines or N%% or RETURN for current value): \
\nsEnter bottom scroll margin (N lines or N%% or RETURN for current value): ")
  (setq zmacs-region-stays t)
  ;; set top scroll margin
  (or (string= top "")
      (if (string= "%" (substring top -1))
	  (setq tpu-top-scroll-margin (string-to-int top))
	(setq tpu-top-scroll-margin
	      (/ (1- (+ (* (string-to-int top) 100) (window-height)))
		 (window-height)))))
  ;; set bottom scroll margin
  (or (string= bottom "")
      (if (string= "%" (substring bottom -1))
	  (setq tpu-bottom-scroll-margin (string-to-int bottom))
	(setq tpu-bottom-scroll-margin
	      (/ (1- (+ (* (string-to-int bottom) 100) (window-height)))
		 (window-height)))))
  ;; report scroll margin settings if running interactively
  (and (interactive-p)
       (message "Scroll margins set.  Top = %s%%, Bottom = %s%%"
		tpu-top-scroll-margin tpu-bottom-scroll-margin)))


;;;  Functions to set cursor bound or free

;;;###autoload
(defun tpu-set-cursor-free nil
  "Allow the cursor to move freely about the screen."
  (interactive)
  (setq zmacs-region-stays t)
  (setq tpu-cursor-free t)
  (substitute-key-definition 'tpu-set-cursor-free
			     'tpu-set-cursor-bound
			     GOLD-map)
  (message "The cursor will now move freely about the screen."))

;;;###autoload
(defun tpu-set-cursor-bound nil
  "Constrain the cursor to the flow of the text."
  (interactive)
  (setq zmacs-region-stays t)
  (picture-clean)
  (setq tpu-cursor-free nil)
  (substitute-key-definition 'tpu-set-cursor-bound
			     'tpu-set-cursor-free
			     GOLD-map)
  (message "The cursor is now bound to the flow of your text."))

;;; tpu-extras.el ends here