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