unofficial mirror of bug-gnu-emacs@gnu.org 
 help / color / mirror / code / Atom feed
blob 8739e1b2152ee04db5de59edfe068a8c9025e309 15935 bytes (raw)
name: lisp/obsolete/tpu-extras.el 	 # note: path name is non-authoritative(*)

  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
 
;;; tpu-extras.el --- scroll margins and free cursor mode for TPU-edt

;; Copyright (C) 1993-1995, 2000-2018 Free Software Foundation, Inc.

;; Author: Rob Riepel <riepel@networking.stanford.edu>
;; Maintainer: Rob Riepel <riepel@networking.stanford.edu>
;; Keywords: emulations
;; Package: tpu-edt
;; Obsolete-since: 24.5

;; This file is part of GNU Emacs.

;; GNU Emacs 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 3 of the License, or
;; (at your option) any later version.

;; GNU Emacs 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 GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.

;;; 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 init 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

(defcustom tpu-top-scroll-margin 0
  "Scroll margin at the top of the screen.
Interpreted as a percent of the current window size."
  :type 'integer
  :group 'tpu)
(defcustom tpu-bottom-scroll-margin 0
  "Scroll margin at the bottom of the screen.
Interpreted as a percent of the current window size."
  :type 'integer
  :group 'tpu)

(defcustom 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."
  :type 'boolean
  :group 'tpu)


;;;  Global variables

;;;###autoload
(define-minor-mode tpu-cursor-free-mode
  "Minor mode to allow the cursor to move freely about the screen.
With a prefix argument ARG, enable the mode if ARG is positive,
and disable it otherwise.  If called from Lisp, enable the mode
if ARG is omitted or nil."
  :init-value nil
  (if (not tpu-cursor-free-mode)
      (tpu-trim-line-ends))
  (if (not tpu-cursor-free-mode)
      (message "The cursor is now bound to the flow of your text.")
    (message "The cursor will now move freely about the screen.")))


;;;  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-trim-line-ends-if-needed ()
  "Eliminate whitespace at ends of lines, if the cursor is free."
  (if (and (buffer-modified-p) tpu-cursor-free-mode) (tpu-trim-line-ends)))
(add-hook 'before-save-hook 'tpu-trim-line-ends-if-needed)


;;;  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")
  (if tpu-cursor-free-mode (picture-forward-column num) (forward-char num)))

(defun tpu-backward-char (num)
  "Move left ARG characters (right if ARG is negative)."
  (interactive "p")
  (cond ((not tpu-cursor-free-mode)
	 (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")
  (let ((beg (tpu-current-line)))
    (if tpu-cursor-free-mode (or (eobp) (picture-move-down num))
      (line-move 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")
  (let ((beg (tpu-current-line)))
    (if tpu-cursor-free-mode (picture-move-up num) (line-move (- 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")
  (let ((beg (tpu-current-line)))
    (backward-char 1)
    (forward-visible-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")
  (let ((beg (tpu-current-line)))
    (cond (tpu-cursor-free-mode
	   (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")
  (let ((beg (tpu-current-line)))
    (cond (tpu-cursor-free-mode
	   (picture-end-of-line (- 1 num)))
	  (t
	   (end-of-line (- 1 num))))
    (tpu-top-check beg num)))

(defun tpu-current-end-of-line ()
  "Move point to end of current line."
  (interactive)
  (let ((beg (point)))
    (if tpu-cursor-free-mode (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)))
    (forward-line num)
    (tpu-bottom-check beg num)))

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


;;;  Movement by paragraph

;; Cf edt-with-position.
(defmacro tpu-with-position (&rest body)
  "Execute BODY with some position-related variables bound."
  `(let* ((left nil)
          (beg (tpu-current-line))
          (height (window-height))
          (top-percent
           (if (zerop tpu-top-scroll-margin) 10 tpu-top-scroll-margin))
          (bottom-percent
           (if (zerop 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)
                 (point-at-bol (1- height)))))
     ,@body))

(defun tpu-paragraph (num)
  "Move to the next paragraph in the current direction.
A repeat count means move that many paragraphs."
  (interactive "p")
  (tpu-with-position
   (if tpu-advance
       (progn
         (tpu-next-paragraph num)
         (if (> (point) far)
             (if (zerop (setq left (save-excursion (forward-line height))))
                 (recenter top-margin)
               (recenter (- left bottom-up-margin)))
           (and (> (point) bottom) (recenter bottom-margin))))
     (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")
  (tpu-with-position
   (if tpu-advance
       (progn
         (forward-page num)
         (if (> (point) far)
               (if (zerop (setq left (save-excursion (forward-line height))))
                   (recenter top-margin)
                 (recenter (- left bottom-up-margin)))
           (and (> (point) bottom) (recenter bottom-margin))))
     (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")
  (let* ((beg (tpu-current-line))
	 (height (1- (window-height)))
	 (lines (* num (/ (* height tpu-percent-scroll) 100))))
    (line-move (- 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")
  (let* ((beg (tpu-current-line))
	 (height (1- (window-height)))
	 (lines (* num (/ (* height tpu-percent-scroll) 100))))
    (line-move 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."
  (tpu-with-position
   (tpu-search-internal-core pat quiet)
   (if tpu-searching-forward
       (progn
         (if (> (point) far)
             (if (zerop (setq left (save-excursion (forward-line height))))
                 (recenter top-margin)
               (recenter (- left bottom-up-margin)))
           (and (> (point) bottom) (recenter bottom-margin))))
     (and (< (point) top) (recenter (min beg top-margin))))))

;; Advise the newline, newline-and-indent, and do-auto-fill functions.
(defadvice newline (around tpu-respect-bottom-scroll-margin activate disable)
  "Respect `tpu-bottom-scroll-margin'."
  (let ((beg (tpu-current-line))
        (num (prefix-numeric-value (ad-get-arg 0))))
    ad-do-it
    (tpu-bottom-check beg num)))

(defadvice newline-and-indent (around tpu-respect-bottom-scroll-margin)
  "Respect `tpu-bottom-scroll-margin'."
  (let ((beg (tpu-current-line)))
    ad-do-it
    (tpu-bottom-check beg 1)))

(defadvice do-auto-fill (around tpu-respect-bottom-scroll-margin)
  "Respect `tpu-bottom-scroll-margin'."
  (let ((beg (tpu-current-line)))
    ad-do-it
    (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): ")
  ;; set top scroll margin
  (or (string= top "")
      (setq tpu-top-scroll-margin
            (if (string= "%" (substring top -1))
                (string-to-number top)
	      (/ (1- (+ (* (string-to-number top) 100) (window-height)))
		 (window-height)))))
  ;; set bottom scroll margin
  (or (string= bottom "")
      (setq tpu-bottom-scroll-margin
            (if (string= "%" (substring bottom -1))
                (string-to-number bottom)
	      (/ (1- (+ (* (string-to-number bottom) 100) (window-height)))
		 (window-height)))))
  (dolist (f '(newline newline-and-indent do-auto-fill))
    (ad-enable-advice f 'around 'tpu-respect-bottom-scroll-margin)
    (ad-activate f))
  ;; report scroll margin settings if running interactively
  (and (called-interactively-p 'interactive)
       (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 ()
  "Allow the cursor to move freely about the screen."
  (interactive)
  (tpu-cursor-free-mode 1))

;;;###autoload
(defun tpu-set-cursor-bound ()
  "Constrain the cursor to the flow of the text."
  (interactive)
  (tpu-cursor-free-mode -1))

(provide 'tpu-extras)

;; Local Variables:
;; generated-autoload-file: "tpu-edt.el"
;; End:

;;; tpu-extras.el ends here

debug log:

solving 8739e1b215 ...
found 8739e1b215 in https://git.savannah.gnu.org/cgit/emacs.git

(*) Git path names are given by the tree(s) the blob belongs to.
    Blobs themselves have no identifier aside from the hash of its contents.^

Code repositories for project(s) associated with this public inbox

	https://git.savannah.gnu.org/cgit/emacs.git

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).