1 ;;; tpu-extras.el --- scroll margins and free cursor mode for TPU-edt
3 ;; Copyright (C) 1993, 1994, 1995, 2000, 2001, 2002, 2003, 2004,
4 ;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
6 ;; Author: Rob Riepel <riepel@networking.stanford.edu>
7 ;; Maintainer: Rob Riepel <riepel@networking.stanford.edu>
8 ;; Keywords: emulations
10 ;; This file is part of GNU Emacs.
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 3 of the License, or
15 ;; (at your option) any later version.
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.
22 ;; You should have received a copy of the GNU General Public License
23 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
27 ;; Use the functions defined here to customize TPU-edt to your tastes by
28 ;; setting scroll margins and/or turning on free cursor mode. Here's an
29 ;; example for your .emacs file.
31 ;; (tpu-set-cursor-free) ; Set cursor free.
32 ;; (tpu-set-scroll-margins "10%" "15%") ; Set scroll margins.
34 ;; Scroll margins and cursor binding can be changed from within emacs using
35 ;; the following commands:
37 ;; tpu-set-scroll-margins or set scroll margins
38 ;; tpu-set-cursor-bound or set cursor bound
39 ;; tpu-set-cursor-free or set cursor free
41 ;; Additionally, Gold-F toggles between bound and free cursor modes.
43 ;; Note that switching out of free cursor mode or exiting TPU-edt while in
44 ;; free cursor mode strips trailing whitespace from every line in the file.
49 ;; The functions contained in this file implement scroll margins and free
50 ;; cursor mode. The following keys and commands are affected.
52 ;; key/command function scroll cursor
54 ;; Up-Arrow previous line x x
55 ;; Down-Arrow next line x x
56 ;; Right-Arrow next character x
57 ;; Left-Arrow previous character x
58 ;; KP0 next or previous line x
59 ;; KP7 next or previous page x
60 ;; KP8 next or previous screen x
61 ;; KP2 next or previous end-of-line x x
62 ;; Control-e current end-of-line x
63 ;; Control-h previous beginning-of-line x
64 ;; Next Scr next screen x
65 ;; Prev Scr previous screen x
66 ;; Search find a string x
67 ;; Replace find and replace a string x
68 ;; Newline insert a newline x
69 ;; Paragraph next or previous paragraph x
70 ;; Auto-Fill break lines on spaces x
72 ;; These functions are not part of the base TPU-edt for the following
75 ;; Free cursor mode is implemented with the emacs picture-mode functions.
76 ;; These functions support moving the cursor all over the screen, however,
77 ;; when the cursor is moved past the end of a line, spaces or tabs are
78 ;; appended to the line - even if no text is entered in that area. In
79 ;; order for a free cursor mode to work exactly like TPU/edt, this trailing
80 ;; whitespace needs to be dealt with in every function that might encounter
81 ;; it. Such global changes are impractical, however, free cursor mode is
82 ;; too valuable to abandon completely, so it has been implemented in those
83 ;; functions where it serves best.
85 ;; The implementation of scroll margins adds overhead to previously
86 ;; simple and often used commands. These commands are now responsible
87 ;; for their normal operation and part of the display function. There
88 ;; is a possibility that this display overhead could adversely affect the
89 ;; performance of TPU-edt on slower computers. In order to support the
90 ;; widest range of computers, scroll margin support is optional.
92 ;; It's actually not known whether the overhead associated with scroll
93 ;; margin support is significant. If you find that it is, please send
94 ;; a note describing the extent of the performance degradation. Be sure
95 ;; to include a description of the platform where you're running TPU-edt.
96 ;; Send your note to the address provided by Gold-V.
98 ;; Even with these differences and limitations, these functions implement
99 ;; important aspects of the real TPU/edt. Those who miss free cursor mode
100 ;; and/or scroll margins will appreciate these implementations.
105 ;;; Gotta have tpu-edt
110 ;;; Customization variables
112 (defcustom tpu-top-scroll-margin 0
113 "Scroll margin at the top of the screen.
114 Interpreted as a percent of the current window size."
117 (defcustom tpu-bottom-scroll-margin 0
118 "Scroll margin at the bottom of the screen.
119 Interpreted as a percent of the current window size."
123 (defcustom tpu-backward-char-like-tpu t
124 "If non-nil, in free cursor mode backward-char (left-arrow) works
125 just like TPU/edt. Otherwise, backward-char will move to the end of
126 the previous line when starting from a line beginning."
134 (define-minor-mode tpu-cursor-free-mode
135 "Minor mode to allow the cursor to move freely about the screen."
137 (if (not tpu-cursor-free-mode)
138 (tpu-trim-line-ends)))
141 ;;; Hooks -- Set cursor free in picture mode.
142 ;;; Clean up when writing a file from cursor free mode.
144 (add-hook 'picture-mode-hook 'tpu-set-cursor-free)
146 (defun tpu-trim-line-ends-if-needed ()
147 "Eliminate whitespace at ends of lines, if the cursor is free."
148 (if (and (buffer-modified-p) tpu-cursor-free-mode) (tpu-trim-line-ends)))
149 (add-hook 'before-save-hook 'tpu-trim-line-ends-if-needed)
152 ;;; Utility routines for implementing scroll margins
154 (defun tpu-top-check (beg lines)
155 "Enforce scroll margin at the top of screen."
156 (let ((margin (/ (* (window-height) tpu-top-scroll-margin) 100)))
157 (cond ((< beg margin) (recenter beg))
158 ((< (- beg lines) margin) (recenter margin)))))
160 (defun tpu-bottom-check (beg lines)
161 "Enforce scroll margin at the bottom of screen."
162 (let* ((height (window-height))
163 (margin (+ 1 (/ (* height tpu-bottom-scroll-margin) 100)))
164 ;; subtract 1 from height because it includes mode line
165 (difference (- height margin 1)))
166 (cond ((> beg difference) (recenter beg))
167 ((> (+ beg lines) difference) (recenter (- margin))))))
170 ;;; Movement by character
172 (defun tpu-forward-char (num)
173 "Move right ARG characters (left if ARG is negative)."
175 (if tpu-cursor-free-mode (picture-forward-column num) (forward-char num)))
177 (defun tpu-backward-char (num)
178 "Move left ARG characters (right if ARG is negative)."
180 (cond ((not tpu-cursor-free-mode)
182 (tpu-backward-char-like-tpu
183 (picture-backward-column num))
186 (picture-end-of-line)
187 (picture-backward-column (1- num)))
189 (picture-backward-column num))))
194 (defun tpu-next-line (num)
196 Prefix argument serves as a repeat count."
198 (let ((beg (tpu-current-line)))
199 (if tpu-cursor-free-mode (or (eobp) (picture-move-down num))
201 (tpu-bottom-check beg num)
202 (setq this-command 'next-line)))
204 (defun tpu-previous-line (num)
205 "Move to previous line.
206 Prefix argument serves as a repeat count."
208 (let ((beg (tpu-current-line)))
209 (if tpu-cursor-free-mode (picture-move-up num) (line-move (- num)))
210 (tpu-top-check beg num)
211 (setq this-command 'previous-line)))
213 (defun tpu-next-beginning-of-line (num)
214 "Move to beginning of line; if at beginning, move to beginning of next line.
215 Accepts a prefix argument for the number of lines to move."
217 (let ((beg (tpu-current-line)))
219 (forward-visible-line (- 1 num))
220 (tpu-top-check beg num)))
222 (defun tpu-next-end-of-line (num)
223 "Move to end of line; if at end, move to end of next line.
224 Accepts a prefix argument for the number of lines to move."
226 (let ((beg (tpu-current-line)))
227 (cond (tpu-cursor-free-mode
229 (if (< 1 num) (forward-line num))
230 (picture-end-of-line)
231 (if (<= (point) beg) (progn (forward-line) (picture-end-of-line)))))
235 (tpu-bottom-check beg num)))
237 (defun tpu-previous-end-of-line (num)
239 Accepts a prefix argument for the number of lines to move."
241 (let ((beg (tpu-current-line)))
242 (cond (tpu-cursor-free-mode
243 (picture-end-of-line (- 1 num)))
245 (end-of-line (- 1 num))))
246 (tpu-top-check beg num)))
248 (defun tpu-current-end-of-line ()
249 "Move point to end of current line."
252 (if tpu-cursor-free-mode (picture-end-of-line) (end-of-line))
253 (if (= beg (point)) (message "You are already at the end of a line."))))
255 (defun tpu-forward-line (num)
256 "Move to beginning of next line.
257 Prefix argument serves as a repeat count."
259 (let ((beg (tpu-current-line)))
261 (tpu-bottom-check beg num)))
263 (defun tpu-backward-line (num)
264 "Move to beginning of previous line.
265 Prefix argument serves as repeat count."
267 (let ((beg (tpu-current-line)))
268 (or (bolp) (>= 0 num) (setq num (- num 1)))
269 (forward-line (- num))
270 (tpu-top-check beg num)))
273 ;;; Movement by paragraph
275 (defun tpu-paragraph (num)
276 "Move to the next paragraph in the current direction.
277 A repeat count means move that many paragraphs."
280 (beg (tpu-current-line))
281 (height (window-height))
283 (if (= 0 tpu-top-scroll-margin) 10 tpu-top-scroll-margin))
285 (if (= 0 tpu-bottom-scroll-margin) 15 tpu-bottom-scroll-margin))
286 (top-margin (/ (* height top-percent) 100))
287 (bottom-up-margin (+ 1 (/ (* height bottom-percent) 100)))
288 (bottom-margin (max beg (- height bottom-up-margin 1)))
289 (top (save-excursion (move-to-window-line top-margin) (point)))
290 (bottom (save-excursion (move-to-window-line bottom-margin) (point)))
292 (goto-char bottom) (forward-line (- height 2)) (point))))
294 (tpu-next-paragraph num)
295 (cond((> (point) far)
296 (setq left (save-excursion (forward-line height)))
297 (if (= 0 left) (recenter top-margin)
298 (recenter (- left bottom-up-margin))))
300 (and (> (point) bottom) (recenter bottom-margin)))))
302 (tpu-previous-paragraph num)
303 (and (< (point) top) (recenter (min beg top-margin)))))))
308 (defun tpu-page (num)
309 "Move to the next page in the current direction.
310 A repeat count means move that many pages."
313 (beg (tpu-current-line))
314 (height (window-height))
316 (if (= 0 tpu-top-scroll-margin) 10 tpu-top-scroll-margin))
318 (if (= 0 tpu-bottom-scroll-margin) 15 tpu-bottom-scroll-margin))
319 (top-margin (/ (* height top-percent) 100))
320 (bottom-up-margin (+ 1 (/ (* height bottom-percent) 100)))
321 (bottom-margin (max beg (- height bottom-up-margin 1)))
322 (top (save-excursion (move-to-window-line top-margin) (point)))
323 (bottom (save-excursion (move-to-window-line bottom-margin) (point)))
325 (goto-char bottom) (forward-line (- height 2)) (point))))
328 (cond((> (point) far)
329 (setq left (save-excursion (forward-line height)))
330 (if (= 0 left) (recenter top-margin)
331 (recenter (- left bottom-up-margin))))
333 (and (> (point) bottom) (recenter bottom-margin)))))
336 (and (< (point) top) (recenter (min beg top-margin)))))))
341 (defun tpu-scroll-window-down (num)
342 "Scroll the display down to the next section.
343 A repeat count means scroll that many sections."
345 (let* ((beg (tpu-current-line))
346 (height (1- (window-height)))
347 (lines (* num (/ (* height tpu-percent-scroll) 100))))
348 (line-move (- lines))
349 (tpu-top-check beg lines)))
351 (defun tpu-scroll-window-up (num)
352 "Scroll the display up to the next section.
353 A repeat count means scroll that many sections."
355 (let* ((beg (tpu-current-line))
356 (height (1- (window-height)))
357 (lines (* num (/ (* height tpu-percent-scroll) 100))))
359 (tpu-bottom-check beg lines)))
362 ;;; Replace the TPU-edt internal search function
364 (defun tpu-search-internal (pat &optional quiet)
365 "Search for a string or regular expression."
367 (beg (tpu-current-line))
368 (height (window-height))
370 (if (= 0 tpu-top-scroll-margin) 10 tpu-top-scroll-margin))
372 (if (= 0 tpu-bottom-scroll-margin) 15 tpu-bottom-scroll-margin))
373 (top-margin (/ (* height top-percent) 100))
374 (bottom-up-margin (+ 1 (/ (* height bottom-percent) 100)))
375 (bottom-margin (max beg (- height bottom-up-margin 1)))
376 (top (save-excursion (move-to-window-line top-margin) (point)))
377 (bottom (save-excursion (move-to-window-line bottom-margin) (point)))
379 (goto-char bottom) (forward-line (- height 2)) (point))))
380 (tpu-search-internal-core pat quiet)
381 (if tpu-searching-forward
382 (cond((> (point) far)
383 (setq left (save-excursion (forward-line height)))
384 (if (= 0 left) (recenter top-margin)
385 (recenter (- left bottom-up-margin))))
387 (and (> (point) bottom) (recenter bottom-margin))))
388 (and (< (point) top) (recenter (min beg top-margin))))))
392 ;; Advise the newline, newline-and-indent, and do-auto-fill functions.
393 (defadvice newline (around tpu-respect-bottom-scroll-margin activate disable)
394 "Respect `tpu-bottom-scroll-margin'."
395 (let ((beg (tpu-current-line))
396 (num (prefix-numeric-value (ad-get-arg 0))))
398 (tpu-bottom-check beg num)))
400 (defadvice newline-and-indent (around tpu-respect-bottom-scroll-margin)
401 "Respect `tpu-bottom-scroll-margin'."
402 (let ((beg (tpu-current-line)))
404 (tpu-bottom-check beg 1)))
406 (defadvice do-auto-fill (around tpu-respect-bottom-scroll-margin)
407 "Respect `tpu-bottom-scroll-margin'."
408 (let ((beg (tpu-current-line)))
410 (tpu-bottom-check beg 1)))
413 ;;; Function to set scroll margins
416 (defun tpu-set-scroll-margins (top bottom)
417 "Set scroll margins."
419 "sEnter top scroll margin (N lines or N%% or RETURN for current value): \
420 \nsEnter bottom scroll margin (N lines or N%% or RETURN for current value): ")
421 ;; set top scroll margin
423 (setq tpu-top-scroll-margin
424 (if (string= "%" (substring top -1))
425 (string-to-number top)
426 (/ (1- (+ (* (string-to-number top) 100) (window-height)))
428 ;; set bottom scroll margin
429 (or (string= bottom "")
430 (setq tpu-bottom-scroll-margin
431 (if (string= "%" (substring bottom -1))
432 (string-to-number bottom)
433 (/ (1- (+ (* (string-to-number bottom) 100) (window-height)))
435 (dolist (f '(newline newline-and-indent do-auto-fill))
436 (ad-enable-advice f 'around 'tpu-respect-bottom-scroll-margin)
438 ;; report scroll margin settings if running interactively
440 (message "Scroll margins set. Top = %s%%, Bottom = %s%%"
441 tpu-top-scroll-margin tpu-bottom-scroll-margin)))
444 ;;; Functions to set cursor bound or free
447 (defun tpu-set-cursor-free ()
448 "Allow the cursor to move freely about the screen."
450 (tpu-cursor-free-mode 1)
451 (message "The cursor will now move freely about the screen."))
454 (defun tpu-set-cursor-bound ()
455 "Constrain the cursor to the flow of the text."
457 (tpu-cursor-free-mode -1)
458 (message "The cursor is now bound to the flow of your text."))
461 ;; generated-autoload-file: "tpu-edt.el"
464 ;; arch-tag: 89676fa4-33ec-48cb-9135-6f3bf230ab1a
465 ;;; tpu-extras.el ends here