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, or (at your option)
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; see the file COPYING. If not, write to the
24 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
25 ;; Boston, MA 02110-1301, USA.
29 ;; Use the functions defined here to customize TPU-edt to your tastes by
30 ;; setting scroll margins and/or turning on free cursor mode. Here's an
31 ;; example for your .emacs file.
33 ;; (tpu-set-cursor-free) ; Set cursor free.
34 ;; (tpu-set-scroll-margins "10%" "15%") ; Set scroll margins.
36 ;; Scroll margins and cursor binding can be changed from within emacs using
37 ;; the following commands:
39 ;; tpu-set-scroll-margins or set scroll margins
40 ;; tpu-set-cursor-bound or set cursor bound
41 ;; tpu-set-cursor-free or set cursor free
43 ;; Additionally, Gold-F toggles between bound and free cursor modes.
45 ;; Note that switching out of free cursor mode or exiting TPU-edt while in
46 ;; free cursor mode strips trailing whitespace from every line in the file.
51 ;; The functions contained in this file implement scroll margins and free
52 ;; cursor mode. The following keys and commands are affected.
54 ;; key/command function scroll cursor
56 ;; Up-Arrow previous line x x
57 ;; Down-Arrow next line x x
58 ;; Right-Arrow next character x
59 ;; Left-Arrow previous character x
60 ;; KP0 next or previous line x
61 ;; KP7 next or previous page x
62 ;; KP8 next or previous screen x
63 ;; KP2 next or previous end-of-line x x
64 ;; Control-e current end-of-line x
65 ;; Control-h previous beginning-of-line x
66 ;; Next Scr next screen x
67 ;; Prev Scr previous screen x
68 ;; Search find a string x
69 ;; Replace find and replace a string x
70 ;; Newline insert a newline x
71 ;; Paragraph next or previous paragraph x
72 ;; Auto-Fill break lines on spaces x
74 ;; These functions are not part of the base TPU-edt for the following
77 ;; Free cursor mode is implemented with the emacs picture-mode functions.
78 ;; These functions support moving the cursor all over the screen, however,
79 ;; when the cursor is moved past the end of a line, spaces or tabs are
80 ;; appended to the line - even if no text is entered in that area. In
81 ;; order for a free cursor mode to work exactly like TPU/edt, this trailing
82 ;; whitespace needs to be dealt with in every function that might encounter
83 ;; it. Such global changes are impractical, however, free cursor mode is
84 ;; too valuable to abandon completely, so it has been implemented in those
85 ;; functions where it serves best.
87 ;; The implementation of scroll margins adds overhead to previously
88 ;; simple and often used commands. These commands are now responsible
89 ;; for their normal operation and part of the display function. There
90 ;; is a possibility that this display overhead could adversely affect the
91 ;; performance of TPU-edt on slower computers. In order to support the
92 ;; widest range of computers, scroll margin support is optional.
94 ;; It's actually not known whether the overhead associated with scroll
95 ;; margin support is significant. If you find that it is, please send
96 ;; a note describing the extent of the performance degradation. Be sure
97 ;; to include a description of the platform where you're running TPU-edt.
98 ;; Send your note to the address provided by Gold-V.
100 ;; Even with these differences and limitations, these functions implement
101 ;; important aspects of the real TPU/edt. Those who miss free cursor mode
102 ;; and/or scroll margins will appreciate these implementations.
107 ;;; Gotta have tpu-edt
112 ;;; Customization variables
114 (defcustom tpu-top-scroll-margin
0
115 "*Scroll margin at the top of the screen.
116 Interpreted as a percent of the current window size."
119 (defcustom tpu-bottom-scroll-margin
0
120 "*Scroll margin at the bottom of the screen.
121 Interpreted as a percent of the current window size."
125 (defcustom tpu-backward-char-like-tpu t
126 "*If non-nil, in free cursor mode backward-char (left-arrow) works
127 just like TPU/edt. Otherwise, backward-char will move to the end of
128 the previous line when starting from a line beginning."
135 (defvar tpu-cursor-free nil
136 "If non-nil, let the cursor roam free.")
139 ;;; Hooks -- Set cursor free in picture mode.
140 ;;; Clean up when writing a file from cursor free mode.
142 (add-hook 'picture-mode-hook
'tpu-set-cursor-free
)
144 (defun tpu-before-save-hook ()
145 "Eliminate whitespace at ends of lines, if the cursor is free."
146 (if (and (buffer-modified-p) tpu-cursor-free
) (tpu-trim-line-ends)))
148 (add-hook 'before-save-hook
'tpu-before-save-hook
)
151 ;;; Utility routines for implementing scroll margins
153 (defun tpu-top-check (beg lines
)
154 "Enforce scroll margin at the top of screen."
155 (let ((margin (/ (* (window-height) tpu-top-scroll-margin
) 100)))
156 (cond ((< beg margin
) (recenter beg
))
157 ((< (- beg lines
) margin
) (recenter margin
)))))
159 (defun tpu-bottom-check (beg lines
)
160 "Enforce scroll margin at the bottom of screen."
161 (let* ((height (window-height))
162 (margin (+ 1 (/ (* height tpu-bottom-scroll-margin
) 100)))
163 ;; subtract 1 from height because it includes mode line
164 (difference (- height margin
1)))
165 (cond ((> beg difference
) (recenter beg
))
166 ((> (+ beg lines
) difference
) (recenter (- margin
))))))
169 ;;; Movement by character
171 (defun tpu-forward-char (num)
172 "Move right ARG characters (left if ARG is negative)."
174 (if tpu-cursor-free
(picture-forward-column num
) (forward-char num
)))
176 (defun tpu-backward-char (num)
177 "Move left ARG characters (right if ARG is negative)."
179 (cond ((not tpu-cursor-free
)
181 (tpu-backward-char-like-tpu
182 (picture-backward-column num
))
185 (picture-end-of-line)
186 (picture-backward-column (1- num
)))
188 (picture-backward-column num
))))
193 (defun tpu-next-line (num)
195 Prefix argument serves as a repeat count."
197 (let ((beg (tpu-current-line)))
198 (if tpu-cursor-free
(or (eobp) (picture-move-down num
))
200 (tpu-bottom-check beg num
)
201 (setq this-command
'next-line
)))
203 (defun tpu-previous-line (num)
204 "Move to previous line.
205 Prefix argument serves as a repeat count."
207 (let ((beg (tpu-current-line)))
208 (if tpu-cursor-free
(picture-move-up num
) (line-move (- num
)))
209 (tpu-top-check beg num
)
210 (setq this-command
'previous-line
)))
212 (defun tpu-next-beginning-of-line (num)
213 "Move to beginning of line; if at beginning, move to beginning of next line.
214 Accepts a prefix argument for the number of lines to move."
216 (let ((beg (tpu-current-line)))
218 (forward-visible-line (- 1 num
))
219 (tpu-top-check beg num
)))
221 (defun tpu-next-end-of-line (num)
222 "Move to end of line; if at end, move to end of next line.
223 Accepts a prefix argument for the number of lines to move."
225 (let ((beg (tpu-current-line)))
226 (cond (tpu-cursor-free
228 (if (< 1 num
) (forward-line num
))
229 (picture-end-of-line)
230 (if (<= (point) beg
) (progn (forward-line) (picture-end-of-line)))))
234 (tpu-bottom-check beg num
)))
236 (defun tpu-previous-end-of-line (num)
238 Accepts a prefix argument for the number of lines to move."
240 (let ((beg (tpu-current-line)))
241 (cond (tpu-cursor-free
242 (picture-end-of-line (- 1 num
)))
244 (end-of-line (- 1 num
))))
245 (tpu-top-check beg num
)))
247 (defun tpu-current-end-of-line ()
248 "Move point to end of current line."
251 (if tpu-cursor-free
(picture-end-of-line) (end-of-line))
252 (if (= beg
(point)) (message "You are already at the end of a line."))))
254 (defun tpu-forward-line (num)
255 "Move to beginning of next line.
256 Prefix argument serves as a repeat count."
258 (let ((beg (tpu-current-line)))
260 (tpu-bottom-check beg num
)
261 (beginning-of-line)))
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)))
270 (tpu-top-check beg num
)
271 (beginning-of-line)))
274 ;;; Movement by paragraph
276 (defun tpu-paragraph (num)
277 "Move to the next paragraph in the current direction.
278 A repeat count means move that many paragraphs."
281 (beg (tpu-current-line))
282 (height (window-height))
284 (if (= 0 tpu-top-scroll-margin
) 10 tpu-top-scroll-margin
))
286 (if (= 0 tpu-bottom-scroll-margin
) 15 tpu-bottom-scroll-margin
))
287 (top-margin (/ (* height top-percent
) 100))
288 (bottom-up-margin (+ 1 (/ (* height bottom-percent
) 100)))
289 (bottom-margin (max beg
(- height bottom-up-margin
1)))
290 (top (save-excursion (move-to-window-line top-margin
) (point)))
291 (bottom (save-excursion (move-to-window-line bottom-margin
) (point)))
293 (goto-char bottom
) (forward-line (- height
2)) (point))))
295 (tpu-next-paragraph num
)
296 (cond((> (point) far
)
297 (setq left
(save-excursion (forward-line height
)))
298 (if (= 0 left
) (recenter top-margin
)
299 (recenter (- left bottom-up-margin
))))
301 (and (> (point) bottom
) (recenter bottom-margin
)))))
303 (tpu-previous-paragraph num
)
304 (and (< (point) top
) (recenter (min beg top-margin
)))))))
309 (defun tpu-page (num)
310 "Move to the next page in the current direction.
311 A repeat count means move that many pages."
314 (beg (tpu-current-line))
315 (height (window-height))
317 (if (= 0 tpu-top-scroll-margin
) 10 tpu-top-scroll-margin
))
319 (if (= 0 tpu-bottom-scroll-margin
) 15 tpu-bottom-scroll-margin
))
320 (top-margin (/ (* height top-percent
) 100))
321 (bottom-up-margin (+ 1 (/ (* height bottom-percent
) 100)))
322 (bottom-margin (max beg
(- height bottom-up-margin
1)))
323 (top (save-excursion (move-to-window-line top-margin
) (point)))
324 (bottom (save-excursion (move-to-window-line bottom-margin
) (point)))
326 (goto-char bottom
) (forward-line (- height
2)) (point))))
329 (cond((> (point) far
)
330 (setq left
(save-excursion (forward-line height
)))
331 (if (= 0 left
) (recenter top-margin
)
332 (recenter (- left bottom-up-margin
))))
334 (and (> (point) bottom
) (recenter bottom-margin
)))))
337 (and (< (point) top
) (recenter (min beg top-margin
)))))))
342 (defun tpu-scroll-window-down (num)
343 "Scroll the display down to the next section.
344 A repeat count means scroll that many sections."
346 (let* ((beg (tpu-current-line))
347 (height (1- (window-height)))
348 (lines (* num
(/ (* height tpu-percent-scroll
) 100))))
349 (line-move (- lines
))
350 (tpu-top-check beg lines
)))
352 (defun tpu-scroll-window-up (num)
353 "Scroll the display up to the next section.
354 A repeat count means scroll that many sections."
356 (let* ((beg (tpu-current-line))
357 (height (1- (window-height)))
358 (lines (* num
(/ (* height tpu-percent-scroll
) 100))))
360 (tpu-bottom-check beg lines
)))
363 ;;; Replace the TPU-edt internal search function
365 (defun tpu-search-internal (pat &optional quiet
)
366 "Search for a string or regular expression."
368 (beg (tpu-current-line))
369 (height (window-height))
371 (if (= 0 tpu-top-scroll-margin
) 10 tpu-top-scroll-margin
))
373 (if (= 0 tpu-bottom-scroll-margin
) 15 tpu-bottom-scroll-margin
))
374 (top-margin (/ (* height top-percent
) 100))
375 (bottom-up-margin (+ 1 (/ (* height bottom-percent
) 100)))
376 (bottom-margin (max beg
(- height bottom-up-margin
1)))
377 (top (save-excursion (move-to-window-line top-margin
) (point)))
378 (bottom (save-excursion (move-to-window-line bottom-margin
) (point)))
380 (goto-char bottom
) (forward-line (- height
2)) (point))))
381 (tpu-search-internal-core pat quiet
)
382 (if tpu-searching-forward
383 (cond((> (point) far
)
384 (setq left
(save-excursion (forward-line height
)))
385 (if (= 0 left
) (recenter top-margin
)
386 (recenter (- left bottom-up-margin
))))
388 (and (> (point) bottom
) (recenter bottom-margin
))))
389 (and (< (point) top
) (recenter (min beg top-margin
))))))
393 ;; Advise the newline, newline-and-indent, and do-auto-fill functions.
394 (defadvice newline
(around tpu-respect-bottom-scroll-margin activate disable
)
395 "Respect `tpu-bottom-scroll-margin'."
396 (let ((beg (tpu-current-line))
397 (num (prefix-numeric-value (ad-get-arg 0))))
399 (tpu-bottom-check beg num
)))
401 (defadvice newline-and-indent
(around tpu-respect-bottom-scroll-margin
)
402 "Respect `tpu-bottom-scroll-margin'."
403 (let ((beg (tpu-current-line)))
405 (tpu-bottom-check beg
1)))
407 (defadvice do-auto-fill
(around tpu-respect-bottom-scroll-margin
)
408 "Respect `tpu-bottom-scroll-margin'."
409 (let ((beg (tpu-current-line)))
411 (tpu-bottom-check beg
1)))
414 ;;; Function to set scroll margins
417 (defun tpu-set-scroll-margins (top bottom
)
418 "Set scroll margins."
420 "sEnter top scroll margin (N lines or N%% or RETURN for current value): \
421 \nsEnter bottom scroll margin (N lines or N%% or RETURN for current value): ")
422 ;; set top scroll margin
424 (setq tpu-top-scroll-margin
425 (if (string= "%" (substring top -
1))
426 (string-to-number top
)
427 (/ (1- (+ (* (string-to-number top
) 100) (window-height)))
429 ;; set bottom scroll margin
430 (or (string= bottom
"")
431 (setq tpu-bottom-scroll-margin
432 (if (string= "%" (substring bottom -
1))
433 (string-to-number bottom
)
434 (/ (1- (+ (* (string-to-number bottom
) 100) (window-height)))
436 (dolist (f '(newline newline-and-indent do-auto-fill
))
437 (ad-enable-advice f
'around
'tpu-respect-bottom-scroll-margin
)
439 ;; report scroll margin settings if running interactively
441 (message "Scroll margins set. Top = %s%%, Bottom = %s%%"
442 tpu-top-scroll-margin tpu-bottom-scroll-margin
)))
445 ;;; Functions to set cursor bound or free
448 (defun tpu-set-cursor-free ()
449 "Allow the cursor to move freely about the screen."
451 (setq tpu-cursor-free t
)
452 (substitute-key-definition 'tpu-set-cursor-free
453 'tpu-set-cursor-bound
455 (message "The cursor will now move freely about the screen."))
458 (defun tpu-set-cursor-bound ()
459 "Constrain the cursor to the flow of the text."
462 (setq tpu-cursor-free nil
)
463 (substitute-key-definition 'tpu-set-cursor-bound
466 (message "The cursor is now bound to the flow of your text."))
468 ;; arch-tag: 89676fa4-33ec-48cb-9135-6f3bf230ab1a
469 ;;; tpu-extras.el ends here