1 ;;; tpu-extras.el --- Scroll margins and free cursor mode for TPU-edt
3 ;; Copyright (C) 1993, 1994, 1995 Free Software Foundation, Inc.
5 ;; Author: Rob Riepel <riepel@networking.stanford.edu>
6 ;; Maintainer: Rob Riepel <riepel@networking.stanford.edu>
7 ;; Keywords: emulations
9 ;; This file is part of GNU Emacs.
11 ;; GNU Emacs is free software; you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation; either version 2, or (at your option)
16 ;; GNU Emacs is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;; GNU General Public License for more details.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs; see the file COPYING. If not, write to
23 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
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 (defconst tpu-top-scroll-margin
0
113 "*Scroll margin at the top of the screen.
114 Interpreted as a percent of the current window size.")
115 (defconst tpu-bottom-scroll-margin
0
116 "*Scroll margin at the bottom of the screen.
117 Interpreted as a percent of the current window size.")
119 (defvar tpu-backward-char-like-tpu t
120 "*If non-nil, in free cursor mode backward-char (left-arrow) works
121 just like TPU/edt. Otherwise, backward-char will move to the end of
122 the previous line when starting from a line beginning.")
127 (defvar tpu-cursor-free nil
128 "If non-nil, let the cursor roam free.")
131 ;;; Hooks -- Set cursor free in picture mode.
132 ;;; Clean up when writing a file from cursor free mode.
134 (add-hook 'picture-mode-hook
'tpu-set-cursor-free
)
136 (defun tpu-write-file-hook nil
137 "Eliminate whitespace at ends of lines, if the cursor is free."
138 (if (and (buffer-modified-p) tpu-cursor-free
) (picture-clean)))
140 (or (memq 'tpu-write-file-hook write-file-hooks
)
141 (setq write-file-hooks
142 (cons 'tpu-write-file-hook write-file-hooks
)))
145 ;;; Utility routines for implementing scroll margins
147 (defun tpu-top-check (beg lines
)
148 "Enforce scroll margin at the top of screen."
149 (let ((margin (/ (* (window-height) tpu-top-scroll-margin
) 100)))
150 (cond ((< beg margin
) (recenter beg
))
151 ((< (- beg lines
) margin
) (recenter margin
)))))
153 (defun tpu-bottom-check (beg lines
)
154 "Enforce scroll margin at the bottom of screen."
155 (let* ((height (window-height))
156 (margin (+ 1 (/ (* height tpu-bottom-scroll-margin
) 100)))
157 ;; subtract 1 from height because it includes mode line
158 (difference (- height margin
1)))
159 (cond ((> beg difference
) (recenter beg
))
160 ((> (+ beg lines
) difference
) (recenter (- margin
))))))
163 ;;; Movement by character
165 (defun tpu-forward-char (num)
166 "Move right ARG characters (left if ARG is negative)."
168 (if tpu-cursor-free
(picture-forward-column num
) (forward-char num
)))
170 (defun tpu-backward-char (num)
171 "Move left ARG characters (right if ARG is negative)."
173 (cond ((not tpu-cursor-free
)
175 (tpu-backward-char-like-tpu
176 (picture-backward-column num
))
179 (picture-end-of-line)
180 (picture-backward-column (1- num
)))
182 (picture-backward-column num
))))
187 (defun tpu-next-line (num)
189 Prefix argument serves as a repeat count."
191 (let ((beg (tpu-current-line)))
192 (if tpu-cursor-free
(or (eobp) (picture-move-down num
))
193 (next-line-internal num
))
194 (tpu-bottom-check beg num
)
195 (setq this-command
'next-line
)))
197 (defun tpu-previous-line (num)
198 "Move to previous line.
199 Prefix argument serves as a repeat count."
201 (let ((beg (tpu-current-line)))
202 (if tpu-cursor-free
(picture-move-up num
) (next-line-internal (- num
)))
203 (tpu-top-check beg num
)
204 (setq this-command
'previous-line
)))
206 (defun tpu-next-beginning-of-line (num)
207 "Move to beginning of line; if at beginning, move to beginning of next line.
208 Accepts a prefix argument for the number of lines to move."
210 (let ((beg (tpu-current-line)))
212 (forward-line (- 1 num
))
213 (tpu-top-check beg num
)))
215 (defun tpu-next-end-of-line (num)
216 "Move to end of line; if at end, move to end of next line.
217 Accepts a prefix argument for the number of lines to move."
219 (let ((beg (tpu-current-line)))
220 (cond (tpu-cursor-free
222 (if (< 1 num
) (forward-line num
))
223 (picture-end-of-line)
224 (if (<= (point) beg
) (progn (forward-line) (picture-end-of-line)))))
228 (tpu-bottom-check beg num
)))
230 (defun tpu-previous-end-of-line (num)
232 Accepts a prefix argument for the number of lines to move."
234 (let ((beg (tpu-current-line)))
235 (cond (tpu-cursor-free
236 (picture-end-of-line (- 1 num
)))
238 (end-of-line (- 1 num
))))
239 (tpu-top-check beg num
)))
241 (defun tpu-current-end-of-line nil
242 "Move point to end of current line."
245 (if tpu-cursor-free
(picture-end-of-line) (end-of-line))
246 (if (= beg
(point)) (message "You are already at the end of a line."))))
248 (defun tpu-forward-line (num)
249 "Move to beginning of next line.
250 Prefix argument serves as a repeat count."
252 (let ((beg (tpu-current-line)))
253 (next-line-internal num
)
254 (tpu-bottom-check beg num
)
255 (beginning-of-line)))
257 (defun tpu-backward-line (num)
258 "Move to beginning of previous line.
259 Prefix argument serves as repeat count."
261 (let ((beg (tpu-current-line)))
262 (or (bolp) (>= 0 num
) (setq num
(- num
1)))
263 (next-line-internal (- num
))
264 (tpu-top-check beg num
)
265 (beginning-of-line)))
268 ;;; Movement by paragraph
270 (defun tpu-paragraph (num)
271 "Move to the next paragraph in the current direction.
272 A repeat count means move that many paragraphs."
275 (beg (tpu-current-line))
276 (height (window-height))
278 (if (= 0 tpu-top-scroll-margin
) 10 tpu-top-scroll-margin
))
280 (if (= 0 tpu-bottom-scroll-margin
) 15 tpu-bottom-scroll-margin
))
281 (top-margin (/ (* height top-percent
) 100))
282 (bottom-up-margin (+ 1 (/ (* height bottom-percent
) 100)))
283 (bottom-margin (max beg
(- height bottom-up-margin
1)))
284 (top (save-excursion (move-to-window-line top-margin
) (point)))
285 (bottom (save-excursion (move-to-window-line bottom-margin
) (point)))
287 (goto-char bottom
) (forward-line (- height
2)) (point))))
289 (tpu-next-paragraph num
)
290 (cond((> (point) far
)
291 (setq left
(save-excursion (forward-line height
)))
292 (if (= 0 left
) (recenter top-margin
)
293 (recenter (- left bottom-up-margin
))))
295 (and (> (point) bottom
) (recenter bottom-margin
)))))
297 (tpu-previous-paragraph num
)
298 (and (< (point) top
) (recenter (min beg top-margin
)))))))
303 (defun tpu-page (num)
304 "Move to the next page in the current direction.
305 A repeat count means move that many pages."
308 (beg (tpu-current-line))
309 (height (window-height))
311 (if (= 0 tpu-top-scroll-margin
) 10 tpu-top-scroll-margin
))
313 (if (= 0 tpu-bottom-scroll-margin
) 15 tpu-bottom-scroll-margin
))
314 (top-margin (/ (* height top-percent
) 100))
315 (bottom-up-margin (+ 1 (/ (* height bottom-percent
) 100)))
316 (bottom-margin (max beg
(- height bottom-up-margin
1)))
317 (top (save-excursion (move-to-window-line top-margin
) (point)))
318 (bottom (save-excursion (move-to-window-line bottom-margin
) (point)))
320 (goto-char bottom
) (forward-line (- height
2)) (point))))
323 (cond((> (point) far
)
324 (setq left
(save-excursion (forward-line height
)))
325 (if (= 0 left
) (recenter top-margin
)
326 (recenter (- left bottom-up-margin
))))
328 (and (> (point) bottom
) (recenter bottom-margin
)))))
331 (and (< (point) top
) (recenter (min beg top-margin
)))))))
336 (defun tpu-scroll-window-down (num)
337 "Scroll the display down to the next section.
338 A repeat count means scroll that many sections."
340 (let* ((beg (tpu-current-line))
341 (height (1- (window-height)))
342 (lines (* num
(/ (* height tpu-percent-scroll
) 100))))
343 (next-line-internal (- lines
))
344 (tpu-top-check beg lines
)))
346 (defun tpu-scroll-window-up (num)
347 "Scroll the display up to the next section.
348 A repeat count means scroll that many sections."
350 (let* ((beg (tpu-current-line))
351 (height (1- (window-height)))
352 (lines (* num
(/ (* height tpu-percent-scroll
) 100))))
353 (next-line-internal lines
)
354 (tpu-bottom-check beg lines
)))
357 ;;; Replace the TPU-edt internal search function
359 (defun tpu-search-internal (pat &optional quiet
)
360 "Search for a string or regular expression."
362 (beg (tpu-current-line))
363 (height (window-height))
365 (if (= 0 tpu-top-scroll-margin
) 10 tpu-top-scroll-margin
))
367 (if (= 0 tpu-bottom-scroll-margin
) 15 tpu-bottom-scroll-margin
))
368 (top-margin (/ (* height top-percent
) 100))
369 (bottom-up-margin (+ 1 (/ (* height bottom-percent
) 100)))
370 (bottom-margin (max beg
(- height bottom-up-margin
1)))
371 (top (save-excursion (move-to-window-line top-margin
) (point)))
372 (bottom (save-excursion (move-to-window-line bottom-margin
) (point)))
374 (goto-char bottom
) (forward-line (- height
2)) (point))))
375 (tpu-search-internal-core pat quiet
)
376 (if tpu-searching-forward
377 (cond((> (point) far
)
378 (setq left
(save-excursion (forward-line height
)))
379 (if (= 0 left
) (recenter top-margin
)
380 (recenter (- left bottom-up-margin
))))
382 (and (> (point) bottom
) (recenter bottom-margin
))))
383 (and (< (point) top
) (recenter (min beg top-margin
))))))
387 ;;; Replace the newline, newline-and-indent, and do-auto-fill functions
389 (or (fboundp 'tpu-old-newline
)
390 (fset 'tpu-old-newline
(symbol-function 'newline
)))
391 (or (fboundp 'tpu-old-do-auto-fill
)
392 (fset 'tpu-old-do-auto-fill
(symbol-function 'do-auto-fill
)))
393 (or (fboundp 'tpu-old-newline-and-indent
)
394 (fset 'tpu-old-newline-and-indent
(symbol-function 'newline-and-indent
)))
396 (defun newline (&optional num
)
397 "Insert a newline. With arg, insert that many newlines.
398 In Auto Fill mode, can break the preceding line if no numeric arg.
399 This is the TPU-edt version that respects the bottom scroll margin."
401 (let ((beg (tpu-current-line)))
402 (or num
(setq num
1))
403 (tpu-old-newline num
)
404 (tpu-bottom-check beg num
)))
406 (defun newline-and-indent nil
407 "Insert a newline, then indent according to major mode.
408 Indentation is done using the current indent-line-function.
409 In programming language modes, this is the same as TAB.
410 In some text modes, where TAB inserts a tab, this indents
411 to the specified left-margin column. This is the TPU-edt
412 version that respects the bottom scroll margin."
414 (let ((beg (tpu-current-line)))
415 (tpu-old-newline-and-indent)
416 (tpu-bottom-check beg
1)))
418 (defun do-auto-fill nil
419 "TPU-edt version that respects the bottom scroll margin."
420 (let ((beg (tpu-current-line)))
421 (tpu-old-do-auto-fill)
422 (tpu-bottom-check beg
1)))
425 ;;; Function to set scroll margins
428 (defun tpu-set-scroll-margins (top bottom
)
429 "Set scroll margins."
431 "sEnter top scroll margin (N lines or N%% or RETURN for current value): \
432 \nsEnter bottom scroll margin (N lines or N%% or RETURN for current value): ")
433 ;; set top scroll margin
435 (if (string= "%" (substring top -
1))
436 (setq tpu-top-scroll-margin
(string-to-int top
))
437 (setq tpu-top-scroll-margin
438 (/ (1- (+ (* (string-to-int top
) 100) (window-height)))
440 ;; set bottom scroll margin
441 (or (string= bottom
"")
442 (if (string= "%" (substring bottom -
1))
443 (setq tpu-bottom-scroll-margin
(string-to-int bottom
))
444 (setq tpu-bottom-scroll-margin
445 (/ (1- (+ (* (string-to-int bottom
) 100) (window-height)))
447 ;; report scroll margin settings if running interactively
449 (message "Scroll margins set. Top = %s%%, Bottom = %s%%"
450 tpu-top-scroll-margin tpu-bottom-scroll-margin
)))
453 ;;; Functions to set cursor bound or free
456 (defun tpu-set-cursor-free nil
457 "Allow the cursor to move freely about the screen."
459 (setq tpu-cursor-free t
)
460 (substitute-key-definition 'tpu-set-cursor-free
461 'tpu-set-cursor-bound
463 (message "The cursor will now move freely about the screen."))
466 (defun tpu-set-cursor-bound nil
467 "Constrain the cursor to the flow of the text."
470 (setq tpu-cursor-free nil
)
471 (substitute-key-definition 'tpu-set-cursor-bound
474 (message "The cursor is now bound to the flow of your text."))
476 ;;; tpu-extras.el ends here