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, 2009, 2010 Free Software Foundation, Inc.
6 ;; Author: Rob Riepel <riepel@networking.stanford.edu>
7 ;; Maintainer: Rob Riepel <riepel@networking.stanford.edu>
8 ;; Keywords: emulations
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 <http://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 .emacs 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."
138 (if (not tpu-cursor-free-mode
)
139 (tpu-trim-line-ends))
140 (if (not tpu-cursor-free-mode
)
141 (message "The cursor is now bound to the flow of your text.")
142 (message "The cursor will now move freely about the screen.")))
145 ;;; Hooks -- Set cursor free in picture mode.
146 ;;; Clean up when writing a file from cursor free mode.
148 (add-hook 'picture-mode-hook
'tpu-set-cursor-free
)
150 (defun tpu-trim-line-ends-if-needed ()
151 "Eliminate whitespace at ends of lines, if the cursor is free."
152 (if (and (buffer-modified-p) tpu-cursor-free-mode
) (tpu-trim-line-ends)))
153 (add-hook 'before-save-hook
'tpu-trim-line-ends-if-needed
)
156 ;;; Utility routines for implementing scroll margins
158 (defun tpu-top-check (beg lines
)
159 "Enforce scroll margin at the top of screen."
160 (let ((margin (/ (* (window-height) tpu-top-scroll-margin
) 100)))
161 (cond ((< beg margin
) (recenter beg
))
162 ((< (- beg lines
) margin
) (recenter margin
)))))
164 (defun tpu-bottom-check (beg lines
)
165 "Enforce scroll margin at the bottom of screen."
166 (let* ((height (window-height))
167 (margin (+ 1 (/ (* height tpu-bottom-scroll-margin
) 100)))
168 ;; subtract 1 from height because it includes mode line
169 (difference (- height margin
1)))
170 (cond ((> beg difference
) (recenter beg
))
171 ((> (+ beg lines
) difference
) (recenter (- margin
))))))
174 ;;; Movement by character
176 (defun tpu-forward-char (num)
177 "Move right ARG characters (left if ARG is negative)."
179 (if tpu-cursor-free-mode
(picture-forward-column num
) (forward-char num
)))
181 (defun tpu-backward-char (num)
182 "Move left ARG characters (right if ARG is negative)."
184 (cond ((not tpu-cursor-free-mode
)
186 (tpu-backward-char-like-tpu
187 (picture-backward-column num
))
190 (picture-end-of-line)
191 (picture-backward-column (1- num
)))
193 (picture-backward-column num
))))
198 (defun tpu-next-line (num)
200 Prefix argument serves as a repeat count."
202 (let ((beg (tpu-current-line)))
203 (if tpu-cursor-free-mode
(or (eobp) (picture-move-down num
))
205 (tpu-bottom-check beg num
)
206 (setq this-command
'next-line
)))
208 (defun tpu-previous-line (num)
209 "Move to previous line.
210 Prefix argument serves as a repeat count."
212 (let ((beg (tpu-current-line)))
213 (if tpu-cursor-free-mode
(picture-move-up num
) (line-move (- num
)))
214 (tpu-top-check beg num
)
215 (setq this-command
'previous-line
)))
217 (defun tpu-next-beginning-of-line (num)
218 "Move to beginning of line; if at beginning, move to beginning of next line.
219 Accepts a prefix argument for the number of lines to move."
221 (let ((beg (tpu-current-line)))
223 (forward-visible-line (- 1 num
))
224 (tpu-top-check beg num
)))
226 (defun tpu-next-end-of-line (num)
227 "Move to end of line; if at end, move to end of next line.
228 Accepts a prefix argument for the number of lines to move."
230 (let ((beg (tpu-current-line)))
231 (cond (tpu-cursor-free-mode
233 (if (< 1 num
) (forward-line num
))
234 (picture-end-of-line)
235 (if (<= (point) beg
) (progn (forward-line) (picture-end-of-line)))))
239 (tpu-bottom-check beg num
)))
241 (defun tpu-previous-end-of-line (num)
243 Accepts a prefix argument for the number of lines to move."
245 (let ((beg (tpu-current-line)))
246 (cond (tpu-cursor-free-mode
247 (picture-end-of-line (- 1 num
)))
249 (end-of-line (- 1 num
))))
250 (tpu-top-check beg num
)))
252 (defun tpu-current-end-of-line ()
253 "Move point to end of current line."
256 (if tpu-cursor-free-mode
(picture-end-of-line) (end-of-line))
257 (if (= beg
(point)) (message "You are already at the end of a line."))))
259 (defun tpu-forward-line (num)
260 "Move to beginning of next line.
261 Prefix argument serves as a repeat count."
263 (let ((beg (tpu-current-line)))
265 (tpu-bottom-check beg num
)))
267 (defun tpu-backward-line (num)
268 "Move to beginning of previous line.
269 Prefix argument serves as repeat count."
271 (let ((beg (tpu-current-line)))
272 (or (bolp) (>= 0 num
) (setq num
(- num
1)))
273 (forward-line (- num
))
274 (tpu-top-check beg num
)))
277 ;;; Movement by paragraph
279 (defun tpu-paragraph (num)
280 "Move to the next paragraph in the current direction.
281 A repeat count means move that many paragraphs."
284 (beg (tpu-current-line))
285 (height (window-height))
287 (if (= 0 tpu-top-scroll-margin
) 10 tpu-top-scroll-margin
))
289 (if (= 0 tpu-bottom-scroll-margin
) 15 tpu-bottom-scroll-margin
))
290 (top-margin (/ (* height top-percent
) 100))
291 (bottom-up-margin (+ 1 (/ (* height bottom-percent
) 100)))
292 (bottom-margin (max beg
(- height bottom-up-margin
1)))
293 (top (save-excursion (move-to-window-line top-margin
) (point)))
294 (bottom (save-excursion (move-to-window-line bottom-margin
) (point)))
296 (goto-char bottom
) (forward-line (- height
2)) (point))))
298 (tpu-next-paragraph num
)
299 (cond((> (point) far
)
300 (setq left
(save-excursion (forward-line height
)))
301 (if (= 0 left
) (recenter top-margin
)
302 (recenter (- left bottom-up-margin
))))
304 (and (> (point) bottom
) (recenter bottom-margin
)))))
306 (tpu-previous-paragraph num
)
307 (and (< (point) top
) (recenter (min beg top-margin
)))))))
312 (defun tpu-page (num)
313 "Move to the next page in the current direction.
314 A repeat count means move that many pages."
317 (beg (tpu-current-line))
318 (height (window-height))
320 (if (= 0 tpu-top-scroll-margin
) 10 tpu-top-scroll-margin
))
322 (if (= 0 tpu-bottom-scroll-margin
) 15 tpu-bottom-scroll-margin
))
323 (top-margin (/ (* height top-percent
) 100))
324 (bottom-up-margin (+ 1 (/ (* height bottom-percent
) 100)))
325 (bottom-margin (max beg
(- height bottom-up-margin
1)))
326 (top (save-excursion (move-to-window-line top-margin
) (point)))
327 (bottom (save-excursion (move-to-window-line bottom-margin
) (point)))
329 (goto-char bottom
) (forward-line (- height
2)) (point))))
332 (cond((> (point) far
)
333 (setq left
(save-excursion (forward-line height
)))
334 (if (= 0 left
) (recenter top-margin
)
335 (recenter (- left bottom-up-margin
))))
337 (and (> (point) bottom
) (recenter bottom-margin
)))))
340 (and (< (point) top
) (recenter (min beg top-margin
)))))))
345 (defun tpu-scroll-window-down (num)
346 "Scroll the display down to the next section.
347 A repeat count means scroll that many sections."
349 (let* ((beg (tpu-current-line))
350 (height (1- (window-height)))
351 (lines (* num
(/ (* height tpu-percent-scroll
) 100))))
352 (line-move (- lines
))
353 (tpu-top-check beg lines
)))
355 (defun tpu-scroll-window-up (num)
356 "Scroll the display up to the next section.
357 A repeat count means scroll that many sections."
359 (let* ((beg (tpu-current-line))
360 (height (1- (window-height)))
361 (lines (* num
(/ (* height tpu-percent-scroll
) 100))))
363 (tpu-bottom-check beg lines
)))
366 ;;; Replace the TPU-edt internal search function
368 (defun tpu-search-internal (pat &optional quiet
)
369 "Search for a string or regular expression."
371 (beg (tpu-current-line))
372 (height (window-height))
374 (if (= 0 tpu-top-scroll-margin
) 10 tpu-top-scroll-margin
))
376 (if (= 0 tpu-bottom-scroll-margin
) 15 tpu-bottom-scroll-margin
))
377 (top-margin (/ (* height top-percent
) 100))
378 (bottom-up-margin (+ 1 (/ (* height bottom-percent
) 100)))
379 (bottom-margin (max beg
(- height bottom-up-margin
1)))
380 (top (save-excursion (move-to-window-line top-margin
) (point)))
381 (bottom (save-excursion (move-to-window-line bottom-margin
) (point)))
383 (goto-char bottom
) (forward-line (- height
2)) (point))))
384 (tpu-search-internal-core pat quiet
)
385 (if tpu-searching-forward
386 (cond((> (point) far
)
387 (setq left
(save-excursion (forward-line height
)))
388 (if (= 0 left
) (recenter top-margin
)
389 (recenter (- left bottom-up-margin
))))
391 (and (> (point) bottom
) (recenter bottom-margin
))))
392 (and (< (point) top
) (recenter (min beg top-margin
))))))
396 ;; Advise the newline, newline-and-indent, and do-auto-fill functions.
397 (defadvice newline
(around tpu-respect-bottom-scroll-margin activate disable
)
398 "Respect `tpu-bottom-scroll-margin'."
399 (let ((beg (tpu-current-line))
400 (num (prefix-numeric-value (ad-get-arg 0))))
402 (tpu-bottom-check beg num
)))
404 (defadvice newline-and-indent
(around tpu-respect-bottom-scroll-margin
)
405 "Respect `tpu-bottom-scroll-margin'."
406 (let ((beg (tpu-current-line)))
408 (tpu-bottom-check beg
1)))
410 (defadvice do-auto-fill
(around tpu-respect-bottom-scroll-margin
)
411 "Respect `tpu-bottom-scroll-margin'."
412 (let ((beg (tpu-current-line)))
414 (tpu-bottom-check beg
1)))
417 ;;; Function to set scroll margins
420 (defun tpu-set-scroll-margins (top bottom
)
421 "Set scroll margins."
423 "sEnter top scroll margin (N lines or N%% or RETURN for current value): \
424 \nsEnter bottom scroll margin (N lines or N%% or RETURN for current value): ")
425 ;; set top scroll margin
427 (setq tpu-top-scroll-margin
428 (if (string= "%" (substring top -
1))
429 (string-to-number top
)
430 (/ (1- (+ (* (string-to-number top
) 100) (window-height)))
432 ;; set bottom scroll margin
433 (or (string= bottom
"")
434 (setq tpu-bottom-scroll-margin
435 (if (string= "%" (substring bottom -
1))
436 (string-to-number bottom
)
437 (/ (1- (+ (* (string-to-number bottom
) 100) (window-height)))
439 (dolist (f '(newline newline-and-indent do-auto-fill
))
440 (ad-enable-advice f
'around
'tpu-respect-bottom-scroll-margin
)
442 ;; report scroll margin settings if running interactively
443 (and (called-interactively-p 'interactive
)
444 (message "Scroll margins set. Top = %s%%, Bottom = %s%%"
445 tpu-top-scroll-margin tpu-bottom-scroll-margin
)))
448 ;;; Functions to set cursor bound or free
451 (defun tpu-set-cursor-free ()
452 "Allow the cursor to move freely about the screen."
454 (tpu-cursor-free-mode 1))
457 (defun tpu-set-cursor-bound ()
458 "Constrain the cursor to the flow of the text."
460 (tpu-cursor-free-mode -
1))
463 ;; generated-autoload-file: "tpu-edt.el"
466 ;; arch-tag: 89676fa4-33ec-48cb-9135-6f3bf230ab1a
467 ;;; tpu-extras.el ends here