1 ;;; tpu-extras.el --- scroll margins and free cursor mode for TPU-edt
3 ;; Copyright (C) 1993-1995, 2000-2017 Free Software Foundation, Inc.
5 ;; Author: Rob Riepel <riepel@networking.stanford.edu>
6 ;; Maintainer: Rob Riepel <riepel@networking.stanford.edu>
7 ;; Keywords: emulations
9 ;; Obsolete-since: 24.5
11 ;; This file is part of GNU Emacs.
13 ;; GNU Emacs is free software: you can redistribute it and/or modify
14 ;; it under the terms of the GNU General Public License as published by
15 ;; the Free Software Foundation, either version 3 of the License, or
16 ;; (at your option) any later version.
18 ;; GNU Emacs is distributed in the hope that it will be useful,
19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21 ;; GNU General Public License for more details.
23 ;; You should have received a copy of the GNU General Public License
24 ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
28 ;; Use the functions defined here to customize TPU-edt to your tastes by
29 ;; setting scroll margins and/or turning on free cursor mode. Here's an
30 ;; example for your init file.
32 ;; (tpu-set-cursor-free) ; Set cursor free.
33 ;; (tpu-set-scroll-margins "10%" "15%") ; Set scroll margins.
35 ;; Scroll margins and cursor binding can be changed from within emacs using
36 ;; the following commands:
38 ;; tpu-set-scroll-margins or set scroll margins
39 ;; tpu-set-cursor-bound or set cursor bound
40 ;; tpu-set-cursor-free or set cursor free
42 ;; Additionally, Gold-F toggles between bound and free cursor modes.
44 ;; Note that switching out of free cursor mode or exiting TPU-edt while in
45 ;; free cursor mode strips trailing whitespace from every line in the file.
50 ;; The functions contained in this file implement scroll margins and free
51 ;; cursor mode. The following keys and commands are affected.
53 ;; key/command function scroll cursor
55 ;; Up-Arrow previous line x x
56 ;; Down-Arrow next line x x
57 ;; Right-Arrow next character x
58 ;; Left-Arrow previous character x
59 ;; KP0 next or previous line x
60 ;; KP7 next or previous page x
61 ;; KP8 next or previous screen x
62 ;; KP2 next or previous end-of-line x x
63 ;; Control-e current end-of-line x
64 ;; Control-h previous beginning-of-line x
65 ;; Next Scr next screen x
66 ;; Prev Scr previous screen x
67 ;; Search find a string x
68 ;; Replace find and replace a string x
69 ;; Newline insert a newline x
70 ;; Paragraph next or previous paragraph x
71 ;; Auto-Fill break lines on spaces x
73 ;; These functions are not part of the base TPU-edt for the following
76 ;; Free cursor mode is implemented with the emacs picture-mode functions.
77 ;; These functions support moving the cursor all over the screen, however,
78 ;; when the cursor is moved past the end of a line, spaces or tabs are
79 ;; appended to the line - even if no text is entered in that area. In
80 ;; order for a free cursor mode to work exactly like TPU/edt, this trailing
81 ;; whitespace needs to be dealt with in every function that might encounter
82 ;; it. Such global changes are impractical, however, free cursor mode is
83 ;; too valuable to abandon completely, so it has been implemented in those
84 ;; functions where it serves best.
86 ;; The implementation of scroll margins adds overhead to previously
87 ;; simple and often used commands. These commands are now responsible
88 ;; for their normal operation and part of the display function. There
89 ;; is a possibility that this display overhead could adversely affect the
90 ;; performance of TPU-edt on slower computers. In order to support the
91 ;; widest range of computers, scroll margin support is optional.
93 ;; It's actually not known whether the overhead associated with scroll
94 ;; margin support is significant. If you find that it is, please send
95 ;; a note describing the extent of the performance degradation. Be sure
96 ;; to include a description of the platform where you're running TPU-edt.
97 ;; Send your note to the address provided by Gold-V.
99 ;; Even with these differences and limitations, these functions implement
100 ;; important aspects of the real TPU/edt. Those who miss free cursor mode
101 ;; and/or scroll margins will appreciate these implementations.
106 ;;; Gotta have tpu-edt
111 ;;; Customization variables
113 (defcustom tpu-top-scroll-margin
0
114 "Scroll margin at the top of the screen.
115 Interpreted as a percent of the current window size."
118 (defcustom tpu-bottom-scroll-margin
0
119 "Scroll margin at the bottom of the screen.
120 Interpreted as a percent of the current window size."
124 (defcustom tpu-backward-char-like-tpu t
125 "If non-nil, in free cursor mode backward-char (left-arrow) works
126 just like TPU/edt. Otherwise, backward-char will move to the end of
127 the previous line when starting from a line beginning."
135 (define-minor-mode tpu-cursor-free-mode
136 "Minor mode to allow the cursor to move freely about the screen.
137 With a prefix argument ARG, enable the mode if ARG is positive,
138 and disable it otherwise. If called from Lisp, enable the mode
139 if ARG is omitted or nil."
141 (if (not tpu-cursor-free-mode
)
142 (tpu-trim-line-ends))
143 (if (not tpu-cursor-free-mode
)
144 (message "The cursor is now bound to the flow of your text.")
145 (message "The cursor will now move freely about the screen.")))
148 ;;; Hooks -- Set cursor free in picture mode.
149 ;;; Clean up when writing a file from cursor free mode.
151 (add-hook 'picture-mode-hook
'tpu-set-cursor-free
)
153 (defun tpu-trim-line-ends-if-needed ()
154 "Eliminate whitespace at ends of lines, if the cursor is free."
155 (if (and (buffer-modified-p) tpu-cursor-free-mode
) (tpu-trim-line-ends)))
156 (add-hook 'before-save-hook
'tpu-trim-line-ends-if-needed
)
159 ;;; Utility routines for implementing scroll margins
161 (defun tpu-top-check (beg lines
)
162 "Enforce scroll margin at the top of screen."
163 (let ((margin (/ (* (window-height) tpu-top-scroll-margin
) 100)))
164 (cond ((< beg margin
) (recenter beg
))
165 ((< (- beg lines
) margin
) (recenter margin
)))))
167 (defun tpu-bottom-check (beg lines
)
168 "Enforce scroll margin at the bottom of screen."
169 (let* ((height (window-height))
170 (margin (+ 1 (/ (* height tpu-bottom-scroll-margin
) 100)))
171 ;; subtract 1 from height because it includes mode line
172 (difference (- height margin
1)))
173 (cond ((> beg difference
) (recenter beg
))
174 ((> (+ beg lines
) difference
) (recenter (- margin
))))))
177 ;;; Movement by character
179 (defun tpu-forward-char (num)
180 "Move right ARG characters (left if ARG is negative)."
182 (if tpu-cursor-free-mode
(picture-forward-column num
) (forward-char num
)))
184 (defun tpu-backward-char (num)
185 "Move left ARG characters (right if ARG is negative)."
187 (cond ((not tpu-cursor-free-mode
)
189 (tpu-backward-char-like-tpu
190 (picture-backward-column num
))
193 (picture-end-of-line)
194 (picture-backward-column (1- num
)))
196 (picture-backward-column num
))))
201 (defun tpu-next-line (num)
203 Prefix argument serves as a repeat count."
205 (let ((beg (tpu-current-line)))
206 (if tpu-cursor-free-mode
(or (eobp) (picture-move-down num
))
208 (tpu-bottom-check beg num
)
209 (setq this-command
'next-line
)))
211 (defun tpu-previous-line (num)
212 "Move to previous line.
213 Prefix argument serves as a repeat count."
215 (let ((beg (tpu-current-line)))
216 (if tpu-cursor-free-mode
(picture-move-up num
) (line-move (- num
)))
217 (tpu-top-check beg num
)
218 (setq this-command
'previous-line
)))
220 (defun tpu-next-beginning-of-line (num)
221 "Move to beginning of line; if at beginning, move to beginning of next line.
222 Accepts a prefix argument for the number of lines to move."
224 (let ((beg (tpu-current-line)))
226 (forward-visible-line (- 1 num
))
227 (tpu-top-check beg num
)))
229 (defun tpu-next-end-of-line (num)
230 "Move to end of line; if at end, move to end of next line.
231 Accepts a prefix argument for the number of lines to move."
233 (let ((beg (tpu-current-line)))
234 (cond (tpu-cursor-free-mode
236 (if (< 1 num
) (forward-line num
))
237 (picture-end-of-line)
238 (if (<= (point) beg
) (progn (forward-line) (picture-end-of-line)))))
242 (tpu-bottom-check beg num
)))
244 (defun tpu-previous-end-of-line (num)
246 Accepts a prefix argument for the number of lines to move."
248 (let ((beg (tpu-current-line)))
249 (cond (tpu-cursor-free-mode
250 (picture-end-of-line (- 1 num
)))
252 (end-of-line (- 1 num
))))
253 (tpu-top-check beg num
)))
255 (defun tpu-current-end-of-line ()
256 "Move point to end of current line."
259 (if tpu-cursor-free-mode
(picture-end-of-line) (end-of-line))
260 (if (= beg
(point)) (message "You are already at the end of a line."))))
262 (defun tpu-forward-line (num)
263 "Move to beginning of next line.
264 Prefix argument serves as a repeat count."
266 (let ((beg (tpu-current-line)))
268 (tpu-bottom-check beg num
)))
270 (defun tpu-backward-line (num)
271 "Move to beginning of previous line.
272 Prefix argument serves as repeat count."
274 (let ((beg (tpu-current-line)))
275 (or (bolp) (>= 0 num
) (setq num
(- num
1)))
276 (forward-line (- num
))
277 (tpu-top-check beg num
)))
280 ;;; Movement by paragraph
282 ;; Cf edt-with-position.
283 (defmacro tpu-with-position
(&rest body
)
284 "Execute BODY with some position-related variables bound."
286 (beg (tpu-current-line))
287 (height (window-height))
289 (if (zerop tpu-top-scroll-margin
) 10 tpu-top-scroll-margin
))
291 (if (zerop tpu-bottom-scroll-margin
) 15 tpu-bottom-scroll-margin
))
292 (top-margin (/ (* height top-percent
) 100))
293 (bottom-up-margin (1+ (/ (* height bottom-percent
) 100)))
294 (bottom-margin (max beg
(- height bottom-up-margin
1)))
295 (top (save-excursion (move-to-window-line top-margin
) (point)))
296 (bottom (save-excursion (move-to-window-line bottom-margin
) (point)))
299 (point-at-bol (1- height
)))))
302 (defun tpu-paragraph (num)
303 "Move to the next paragraph in the current direction.
304 A repeat count means move that many paragraphs."
309 (tpu-next-paragraph num
)
311 (if (zerop (setq left
(save-excursion (forward-line height
))))
312 (recenter top-margin
)
313 (recenter (- left bottom-up-margin
)))
314 (and (> (point) bottom
) (recenter bottom-margin
))))
315 (tpu-previous-paragraph num
)
316 (and (< (point) top
) (recenter (min beg top-margin
))))))
320 (defun tpu-page (num)
321 "Move to the next page in the current direction.
322 A repeat count means move that many pages."
329 (if (zerop (setq left
(save-excursion (forward-line height
))))
330 (recenter top-margin
)
331 (recenter (- left bottom-up-margin
)))
332 (and (> (point) bottom
) (recenter bottom-margin
))))
334 (and (< (point) top
) (recenter (min beg top-margin
))))))
338 (defun tpu-scroll-window-down (num)
339 "Scroll the display down to the next section.
340 A repeat count means scroll that many sections."
342 (let* ((beg (tpu-current-line))
343 (height (1- (window-height)))
344 (lines (* num
(/ (* height tpu-percent-scroll
) 100))))
345 (line-move (- lines
))
346 (tpu-top-check beg lines
)))
348 (defun tpu-scroll-window-up (num)
349 "Scroll the display up to the next section.
350 A repeat count means scroll that many sections."
352 (let* ((beg (tpu-current-line))
353 (height (1- (window-height)))
354 (lines (* num
(/ (* height tpu-percent-scroll
) 100))))
356 (tpu-bottom-check beg lines
)))
359 ;;; Replace the TPU-edt internal search function
361 (defun tpu-search-internal (pat &optional quiet
)
362 "Search for a string or regular expression."
364 (tpu-search-internal-core pat quiet
)
365 (if tpu-searching-forward
368 (if (zerop (setq left
(save-excursion (forward-line height
))))
369 (recenter top-margin
)
370 (recenter (- left bottom-up-margin
)))
371 (and (> (point) bottom
) (recenter bottom-margin
))))
372 (and (< (point) top
) (recenter (min beg top-margin
))))))
374 ;; Advise the newline, newline-and-indent, and do-auto-fill functions.
375 (defadvice newline
(around tpu-respect-bottom-scroll-margin activate disable
)
376 "Respect `tpu-bottom-scroll-margin'."
377 (let ((beg (tpu-current-line))
378 (num (prefix-numeric-value (ad-get-arg 0))))
380 (tpu-bottom-check beg num
)))
382 (defadvice newline-and-indent
(around tpu-respect-bottom-scroll-margin
)
383 "Respect `tpu-bottom-scroll-margin'."
384 (let ((beg (tpu-current-line)))
386 (tpu-bottom-check beg
1)))
388 (defadvice do-auto-fill
(around tpu-respect-bottom-scroll-margin
)
389 "Respect `tpu-bottom-scroll-margin'."
390 (let ((beg (tpu-current-line)))
392 (tpu-bottom-check beg
1)))
395 ;;; Function to set scroll margins
398 (defun tpu-set-scroll-margins (top bottom
)
399 "Set scroll margins."
401 "sEnter top scroll margin (N lines or N%% or RETURN for current value): \
402 \nsEnter bottom scroll margin (N lines or N%% or RETURN for current value): ")
403 ;; set top scroll margin
405 (setq tpu-top-scroll-margin
406 (if (string= "%" (substring top -
1))
407 (string-to-number top
)
408 (/ (1- (+ (* (string-to-number top
) 100) (window-height)))
410 ;; set bottom scroll margin
411 (or (string= bottom
"")
412 (setq tpu-bottom-scroll-margin
413 (if (string= "%" (substring bottom -
1))
414 (string-to-number bottom
)
415 (/ (1- (+ (* (string-to-number bottom
) 100) (window-height)))
417 (dolist (f '(newline newline-and-indent do-auto-fill
))
418 (ad-enable-advice f
'around
'tpu-respect-bottom-scroll-margin
)
420 ;; report scroll margin settings if running interactively
421 (and (called-interactively-p 'interactive
)
422 (message "Scroll margins set. Top = %s%%, Bottom = %s%%"
423 tpu-top-scroll-margin tpu-bottom-scroll-margin
)))
426 ;;; Functions to set cursor bound or free
429 (defun tpu-set-cursor-free ()
430 "Allow the cursor to move freely about the screen."
432 (tpu-cursor-free-mode 1))
435 (defun tpu-set-cursor-bound ()
436 "Constrain the cursor to the flow of the text."
438 (tpu-cursor-free-mode -
1))
440 (provide 'tpu-extras
)
443 ;; generated-autoload-file: "tpu-edt.el"
446 ;;; tpu-extras.el ends here