|
|
1.1 root 1: ;; "Picture mode" -- editing using quarter-plane screen model.
2: ;; Copyright (C) 1985 Free Software Foundation, Inc.
3: ;; Principal author K. Shane Hartman
4:
5: ;; This file is part of GNU Emacs.
6:
7: ;; GNU Emacs is free software; you can redistribute it and/or modify
8: ;; it under the terms of the GNU General Public License as published by
9: ;; the Free Software Foundation; either version 1, or (at your option)
10: ;; any later version.
11:
12: ;; GNU Emacs is distributed in the hope that it will be useful,
13: ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14: ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15: ;; GNU General Public License for more details.
16:
17: ;; You should have received a copy of the GNU General Public License
18: ;; along with GNU Emacs; see the file COPYING. If not, write to
19: ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
20:
21:
22: (provide 'picture)
23:
24: (defun move-to-column-force (column)
25: "Move to column COLUMN in current line.
26: Differs from move-to-column in that it creates or modifies whitespace
27: if necessary to attain exactly the specified column."
28: (move-to-column column)
29: (let ((col (current-column)))
30: (if (< col column)
31: (indent-to column)
32: (if (and (/= col column)
33: (= (preceding-char) ?\t))
34: (let (indent-tabs-mode)
35: (delete-char -1)
36: (indent-to col)
37: (move-to-column column))))))
38:
39:
40: ;; Picture Movement Commands
41:
42: (defun picture-end-of-line (&optional arg)
43: "Position point after last non-blank character on current line.
44: With ARG not nil, move forward ARG - 1 lines first.
45: If scan reaches end of buffer, stop there without error."
46: (interactive "P")
47: (if arg (forward-line (1- (prefix-numeric-value arg))))
48: (beginning-of-line)
49: (skip-chars-backward " \t" (prog1 (point) (end-of-line))))
50:
51: (defun picture-forward-column (arg)
52: "Move cursor right, making whitespace if necessary.
53: With argument, move that many columns."
54: (interactive "p")
55: (move-to-column-force (+ (current-column) arg)))
56:
57: (defun picture-backward-column (arg)
58: "Move cursor left, making whitespace if necessary.
59: With argument, move that many columns."
60: (interactive "p")
61: (move-to-column-force (- (current-column) arg)))
62:
63: (defun picture-move-down (arg)
64: "Move vertically down, making whitespace if necessary.
65: With argument, move that many lines."
66: (interactive "p")
67: (let ((col (current-column)))
68: (picture-newline arg)
69: (move-to-column-force col)))
70:
71: (defconst picture-vertical-step 0
72: "Amount to move vertically after text character in Picture mode.")
73:
74: (defconst picture-horizontal-step 1
75: "Amount to move horizontally after text character in Picture mode.")
76:
77: (defun picture-move-up (arg)
78: "Move vertically up, making whitespace if necessary.
79: With argument, move that many lines."
80: (interactive "p")
81: (picture-move-down (- arg)))
82:
83: (defun picture-movement-right ()
84: "Move right after self-inserting character in Picture mode."
85: (interactive)
86: (picture-set-motion 0 1))
87:
88: (defun picture-movement-left ()
89: "Move left after self-inserting character in Picture mode."
90: (interactive)
91: (picture-set-motion 0 -1))
92:
93: (defun picture-movement-up ()
94: "Move up after self-inserting character in Picture mode."
95: (interactive)
96: (picture-set-motion -1 0))
97:
98: (defun picture-movement-down ()
99: "Move down after self-inserting character in Picture mode."
100: (interactive)
101: (picture-set-motion 1 0))
102:
103: (defun picture-movement-nw ()
104: "Move up and left after self-inserting character in Picture mode."
105: (interactive)
106: (picture-set-motion -1 -1))
107:
108: (defun picture-movement-ne ()
109: "Move up and right after self-inserting character in Picture mode."
110: (interactive)
111: (picture-set-motion -1 1))
112:
113: (defun picture-movement-sw ()
114: "Move down and left after self-inserting character in Picture mode."
115: (interactive)
116: (picture-set-motion 1 -1))
117:
118: (defun picture-movement-se ()
119: "Move down and right after self-inserting character in Picture mode."
120: (interactive)
121: (picture-set-motion 1 1))
122:
123: (defun picture-set-motion (vert horiz)
124: "Set VERTICAL and HORIZONTAL increments for movement in Picture mode.
125: The mode line is updated to reflect the current direction."
126: (setq picture-vertical-step vert
127: picture-horizontal-step horiz)
128: (setq mode-name
129: (format "Picture:%s"
130: (car (nthcdr (+ 1 (% horiz 2) (* 3 (1+ (% vert 2))))
131: '(nw up ne left none right sw down se)))))
132: ;; Kludge - force the mode line to be updated. Is there a better
133: ;; way to this?
134: (set-buffer-modified-p (buffer-modified-p))
135: (message ""))
136:
137: (defun picture-move ()
138: "Move in direction of picture-vertical-step and picture-horizontal-step."
139: (picture-move-down picture-vertical-step)
140: (picture-forward-column picture-horizontal-step))
141:
142: (defun picture-motion (arg)
143: "Move point in direction of current picture motion in Picture mode.
144: With ARG do it that many times. Useful for delineating rectangles in
145: conjunction with diagonal picture motion.
146: Do \\[command-apropos] picture-movement to see commands which control motion."
147: (interactive "p")
148: (picture-move-down (* arg picture-vertical-step))
149: (picture-forward-column (* arg picture-horizontal-step)))
150:
151: (defun picture-motion-reverse (arg)
152: "Move point in direction opposite of current picture motion in Picture mode.
153: With ARG do it that many times. Useful for delineating rectangles in
154: conjunction with diagonal picture motion.
155: Do \\[command-apropos] picture-movement to see commands which control motion."
156: (interactive "p")
157: (picture-motion (- arg)))
158:
159:
160: ;; Picture insertion and deletion.
161:
162: (defun picture-self-insert (arg)
163: "Insert this character in place of character previously at the cursor.
164: The cursor then moves in the direction you previously specified
165: with the commands picture-movement-right, picture-movement-up, etc.
166: Do \\[command-apropos] picture-movement to see those commands."
167: (interactive "p")
168: (while (> arg 0)
169: (setq arg (1- arg))
170: (move-to-column-force (1+ (current-column)))
171: (delete-char -1)
172: (insert last-input-char)
173: (forward-char -1)
174: (picture-move)))
175:
176: (defun picture-clear-column (arg)
177: "Clear out ARG columns after point without moving."
178: (interactive "p")
179: (let* ((opoint (point))
180: (original-col (current-column))
181: (target-col (+ original-col arg)))
182: (move-to-column-force target-col)
183: (delete-region opoint (point))
184: (save-excursion
185: (indent-to (max target-col original-col)))))
186:
187: (defun picture-backward-clear-column (arg)
188: "Clear out ARG columns before point, moving back over them."
189: (interactive "p")
190: (picture-clear-column (- arg)))
191:
192: (defun picture-clear-line (arg)
193: "Clear out rest of line; if at end of line, advance to next line.
194: Cleared-out line text goes into the kill ring, as do
195: newlines that are advanced over.
196: With argument, clear out (and save in kill ring) that many lines."
197: (interactive "P")
198: (if arg
199: (progn
200: (setq arg (prefix-numeric-value arg))
201: (kill-line arg)
202: (newline (if (> arg 0) arg (- arg))))
203: (if (looking-at "[ \t]*$")
204: (kill-ring-save (point) (progn (forward-line 1) (point)))
205: (kill-region (point) (progn (end-of-line) (point))))))
206:
207: (defun picture-newline (arg)
208: "Move to the beginning of the following line.
209: With argument, moves that many lines (up, if negative argument);
210: always moves to the beginning of a line."
211: (interactive "p")
212: (if (< arg 0)
213: (forward-line arg)
214: (while (> arg 0)
215: (end-of-line)
216: (if (eobp) (newline) (forward-char 1))
217: (setq arg (1- arg)))))
218:
219: (defun picture-open-line (arg)
220: "Insert an empty line after the current line.
221: With positive argument insert that many lines."
222: (interactive "p")
223: (save-excursion
224: (end-of-line)
225: (open-line arg)))
226:
227: (defun picture-duplicate-line ()
228: "Insert a duplicate of the current line, below it."
229: (interactive)
230: (save-excursion
231: (let ((contents
232: (buffer-substring
233: (progn (beginning-of-line) (point))
234: (progn (picture-newline 1) (point)))))
235: (forward-line -1)
236: (insert contents))))
237:
238:
239: ;; Picture Tabs
240:
241: (defvar picture-tab-chars "!-~"
242: "*A character set which controls behavior of commands
243: \\[picture-set-tab-stops] and \\[picture-tab-search]. It is NOT a
244: regular expression, any regexp special characters will be quoted.
245: It defines a set of \"interesting characters\" to look for when setting
246: \(or searching for) tab stops, initially \"!-~\" (all printing characters).
247: For example, suppose that you are editing a table which is formatted thus:
248: | foo | bar + baz | 23 *
249: | bubbles | and + etc | 97 *
250: and that picture-tab-chars is \"|+*\". Then invoking
251: \\[picture-set-tab-stops] on either of the previous lines would result
252: in the following tab stops
253: : : : :
254: Another example - \"A-Za-z0-9\" would produce the tab stops
255: : : : :
256:
257: Note that if you want the character `-' to be in the set, it must be
258: included in a range or else appear in a context where it cannot be
259: taken for indicating a range (e.g. \"-A-Z\" declares the set to be the
260: letters `A' through `Z' and the character `-'). If you want the
261: character `\\' in the set it must be preceded by itself: \"\\\\\".
262:
263: The command \\[picture-tab-search] is defined to move beneath (or to) a
264: character belonging to this set independent of the tab stops list.")
265:
266: (defun picture-set-tab-stops (&optional arg)
267: "Set value of tab-stop-list according to context of this line.
268: This controls the behavior of \\[picture-tab]. A tab stop
269: is set at every column occupied by an \"interesting character\" that is
270: preceded by whitespace. Interesting characters are defined by the
271: variable picture-tab-chars, see its documentation for an example
272: of usage. With ARG, just (re)set tab-stop-list to its default value.
273: The tab stops computed are displayed in the minibuffer with `:' at
274: each stop."
275: (interactive "P")
276: (save-excursion
277: (let (tabs)
278: (if arg
279: (setq tabs (default-value 'tab-stop-list))
280: (let ((regexp (concat "[ \t]+[" (regexp-quote picture-tab-chars) "]")))
281: (beginning-of-line)
282: (let ((bol (point)))
283: (end-of-line)
284: (while (re-search-backward regexp bol t)
285: (skip-chars-forward " \t")
286: (setq tabs (cons (current-column) tabs)))
287: (if (null tabs)
288: (error "No characters in set %s on this line."
289: (regexp-quote picture-tab-chars))))))
290: (setq tab-stop-list tabs)
291: (let ((blurb (make-string (1+ (nth (1- (length tabs)) tabs)) ?\ )))
292: (while tabs
293: (aset blurb (car tabs) ?:)
294: (setq tabs (cdr tabs)))
295: (message blurb)))))
296:
297: (defun picture-tab-search (&optional arg)
298: "Move to column beneath next interesting char in previous line.
299: With ARG move to column occupied by next interesting character in this
300: line. The character must be preceded by whitespace.
301: \"interesting characters\" are defined by variable picture-tab-chars.
302: If no such character is found, move to beginning of line."
303: (interactive "P")
304: (let ((target (current-column)))
305: (save-excursion
306: (if (and (not arg)
307: (progn
308: (beginning-of-line)
309: (skip-chars-backward
310: (concat "^" (regexp-quote picture-tab-chars))
311: (point-min))
312: (not (bobp))))
313: (move-to-column target))
314: (if (re-search-forward
315: (concat "[ \t]+[" (regexp-quote picture-tab-chars) "]")
316: (save-excursion (end-of-line) (point))
317: 'move)
318: (setq target (1- (current-column)))
319: (setq target nil)))
320: (if target
321: (move-to-column-force target)
322: (beginning-of-line))))
323:
324: (defun picture-tab (&optional arg)
325: "Tab transparently (move) to next tab stop.
326: With ARG overwrite the traversed text with spaces. The tab stop
327: list can be changed by \\[picture-set-tab-stops] and \\[edit-tab-stops].
328: See also documentation for variable picture-tab-chars."
329: (interactive "P")
330: (let* ((opoint (point))
331: (target (prog2 (tab-to-tab-stop)
332: (current-column)
333: (delete-region opoint (point)))))
334: (move-to-column-force target)
335: (if arg
336: (let (indent-tabs-mode)
337: (delete-region opoint (point))
338: (indent-to target)))))
339:
340: ;; Picture Rectangles
341:
342: (defconst picture-killed-rectangle nil
343: "Rectangle killed or copied by \\[picture-clear-rectangle] in Picture mode.
344: The contents can be retrieved by \\[picture-yank-rectangle]")
345:
346: (defun picture-clear-rectangle (start end &optional killp)
347: "Clear and save rectangle delineated by point and mark.
348: The rectangle is saved for yanking by \\[picture-yank-rectangle] and replaced
349: with whitespace. The previously saved rectangle, if any, is lost.
350: With prefix argument, the rectangle is actually killed, shifting remaining
351: text."
352: (interactive "r\nP")
353: (setq picture-killed-rectangle (picture-snarf-rectangle start end killp)))
354:
355: (defun picture-clear-rectangle-to-register (start end register &optional killp)
356: "Clear rectangle delineated by point and mark into REGISTER.
357: The rectangle is saved in REGISTER and replaced with whitespace.
358: With prefix argument, the rectangle is actually killed, shifting remaining
359: text."
360: (interactive "r\ncRectangle to register: \nP")
361: (set-register register (picture-snarf-rectangle start end killp)))
362:
363: (defun picture-snarf-rectangle (start end &optional killp)
364: (let ((column (current-column))
365: (indent-tabs-mode nil)
366: markpos oldmark)
367: (prog1 (save-excursion
368: (save-excursion
369: (goto-char (setq oldmark (mark)))
370: (setq markpos (current-column)))
371: (if killp
372: (delete-extract-rectangle start end)
373: (prog1 (extract-rectangle start end)
374: (clear-rectangle start end t))))
375: (move-to-column-force column)
376: ;; Make the mark point at the same column
377: ;; as it did before.
378: (set-marker (mark-marker)
379: (save-excursion
380: (goto-char oldmark)
381: (move-to-column-force markpos)
382: (point))))))
383:
384: (defun picture-yank-rectangle (&optional insertp)
385: "Overlay rectangle saved by \\[picture-clear-rectangle]
386: The rectangle is positioned with upper left corner at point, overwriting
387: existing text. With prefix argument, the rectangle is inserted instead,
388: shifting existing text. Leaves mark at one corner of rectangle and
389: point at the other (diagonally opposed) corner."
390: (interactive "P")
391: (if (not (consp picture-killed-rectangle))
392: (error "No rectangle saved.")
393: (picture-insert-rectangle picture-killed-rectangle insertp)))
394:
395: (defun picture-yank-rectangle-from-register (register &optional insertp)
396: "Overlay rectangle saved in REGISTER.
397: The rectangle is positioned with upper left corner at point, overwriting
398: existing text. With prefix argument, the rectangle is
399: inserted instead, shifting existing text. Leaves mark at one corner
400: of rectangle and point at the other (diagonally opposed) corner."
401: (interactive "cRectangle from register: \nP")
402: (let ((rectangle (get-register register)))
403: (if (not (consp rectangle))
404: (error "Register %c does not contain a rectangle." register)
405: (picture-insert-rectangle rectangle insertp))))
406:
407: (defun picture-insert-rectangle (rectangle &optional insertp)
408: "Overlay RECTANGLE with upper left corner at point.
409: Optional argument INSERTP, if non-nil causes RECTANGLE to be inserted.
410: Leaves the region surrounding the rectangle."
411: (let ((indent-tabs-mode nil))
412: (if (not insertp)
413: (save-excursion
414: (delete-rectangle (point)
415: (progn
416: (picture-forward-column (length (car rectangle)))
417: (picture-move-down (1- (length rectangle)))
418: (point)))))
419: (push-mark)
420: (insert-rectangle rectangle)))
421:
422:
423: ;; Picture Keymap, entry and exit points.
424:
425: (defconst picture-mode-map nil)
426:
427: (if (not picture-mode-map)
428: (let ((i ?\ ))
429: (setq picture-mode-map (make-keymap))
430: (while (< i ?\177)
431: (aset picture-mode-map i 'picture-self-insert)
432: (setq i (1+ i)))
433: (define-key picture-mode-map "\C-f" 'picture-forward-column)
434: (define-key picture-mode-map "\C-b" 'picture-backward-column)
435: (define-key picture-mode-map "\C-d" 'picture-clear-column)
436: (define-key picture-mode-map "\C-c\C-d" 'delete-char)
437: (define-key picture-mode-map "\177" 'picture-backward-clear-column)
438: (define-key picture-mode-map "\C-k" 'picture-clear-line)
439: (define-key picture-mode-map "\C-o" 'picture-open-line)
440: (define-key picture-mode-map "\C-m" 'picture-newline)
441: (define-key picture-mode-map "\C-j" 'picture-duplicate-line)
442: (define-key picture-mode-map "\C-n" 'picture-move-down)
443: (define-key picture-mode-map "\C-p" 'picture-move-up)
444: (define-key picture-mode-map "\C-e" 'picture-end-of-line)
445: (define-key picture-mode-map "\e\t" 'picture-toggle-tab-state)
446: (define-key picture-mode-map "\t" 'picture-tab)
447: (define-key picture-mode-map "\e\t" 'picture-tab-search)
448: (define-key picture-mode-map "\C-c\t" 'picture-set-tab-stops)
449: (define-key picture-mode-map "\C-c\C-k" 'picture-clear-rectangle)
450: (define-key picture-mode-map "\C-c\C-w" 'picture-clear-rectangle-to-register)
451: (define-key picture-mode-map "\C-c\C-y" 'picture-yank-rectangle)
452: (define-key picture-mode-map "\C-c\C-x" 'picture-yank-rectangle-from-register)
453: (define-key picture-mode-map "\C-c\C-c" 'picture-mode-exit)
454: (define-key picture-mode-map "\C-c\C-f" 'picture-motion)
455: (define-key picture-mode-map "\C-c\C-b" 'picture-motion-reverse)
456: (define-key picture-mode-map "\C-c<" 'picture-movement-left)
457: (define-key picture-mode-map "\C-c>" 'picture-movement-right)
458: (define-key picture-mode-map "\C-c^" 'picture-movement-up)
459: (define-key picture-mode-map "\C-c." 'picture-movement-down)
460: (define-key picture-mode-map "\C-c`" 'picture-movement-nw)
461: (define-key picture-mode-map "\C-c'" 'picture-movement-ne)
462: (define-key picture-mode-map "\C-c/" 'picture-movement-sw)
463: (define-key picture-mode-map "\C-c\\" 'picture-movement-se)))
464:
465: (defvar edit-picture-hook nil
466: "If non-nil, it's value is called on entry to Picture mode.
467: Picture mode is invoked by the command \\[edit-picture].")
468:
469: (defun edit-picture ()
470: "Switch to Picture mode, in which a quarter-plane screen model is used.
471: Printing characters replace instead of inserting themselves with motion
472: afterwards settable by these commands:
473: C-c < Move left after insertion.
474: C-c > Move right after insertion.
475: C-c ^ Move up after insertion.
476: C-c . Move down after insertion.
477: C-c ` Move northwest (nw) after insertion.
478: C-c ' Move northeast (ne) after insertion.
479: C-c / Move southwest (sw) after insertion.
480: C-c \\ Move southeast (se) after insertion.
481: The current direction is displayed in the mode line. The initial
482: direction is right. Whitespace is inserted and tabs are changed to
483: spaces when required by movement. You can move around in the buffer
484: with these commands:
485: C-p Move vertically to SAME column in previous line.
486: C-n Move vertically to SAME column in next line.
487: C-e Move to column following last non-whitespace character.
488: C-f Move right inserting spaces if required.
489: C-b Move left changing tabs to spaces if required.
490: C-c C-f Move in direction of current picture motion.
491: C-c C-b Move in opposite direction of current picture motion.
492: Return Move to beginning of next line.
493: You can edit tabular text with these commands:
494: M-Tab Move to column beneath (or at) next interesting character.
495: `Indents' relative to a previous line.
496: Tab Move to next stop in tab stop list.
497: C-c Tab Set tab stops according to context of this line.
498: With ARG resets tab stops to default (global) value.
499: See also documentation of variable picture-tab-chars
500: which defines \"interesting character\". You can manually
501: change the tab stop list with command \\[edit-tab-stops].
502: You can manipulate text with these commands:
503: C-d Clear (replace) ARG columns after point without moving.
504: C-c C-d Delete char at point - the command normally assigned to C-d.
505: Delete Clear (replace) ARG columns before point, moving back over them.
506: C-k Clear ARG lines, advancing over them. The cleared
507: text is saved in the kill ring.
508: C-o Open blank line(s) beneath current line.
509: You can manipulate rectangles with these commands:
510: C-c C-k Clear (or kill) a rectangle and save it.
511: C-c C-w Like C-c C-k except rectangle is saved in named register.
512: C-c C-y Overlay (or insert) currently saved rectangle at point.
513: C-c C-x Like C-c C-y except rectangle is taken from named register.
514: \\[copy-rectangle-to-register] Copies a rectangle to a register.
515: \\[advertised-undo] Can undo effects of rectangle overlay commands
516: commands if invoked soon enough.
517: You can return to the previous mode with:
518: C-c C-c Which also strips trailing whitespace from every line.
519: Stripping is suppressed by supplying an argument.
520:
521: Entry to this mode calls the value of edit-picture-hook if non-nil.
522:
523: Note that Picture mode commands will work outside of Picture mode, but
524: they are not defaultly assigned to keys."
525: (interactive)
526: (if (eq major-mode 'edit-picture)
527: (error "You are already editing a Picture.")
528: (make-local-variable 'picture-mode-old-local-map)
529: (setq picture-mode-old-local-map (current-local-map))
530: (use-local-map picture-mode-map)
531: (make-local-variable 'picture-mode-old-mode-name)
532: (setq picture-mode-old-mode-name mode-name)
533: (make-local-variable 'picture-mode-old-major-mode)
534: (setq picture-mode-old-major-mode major-mode)
535: (setq major-mode 'edit-picture)
536: (make-local-variable 'picture-killed-rectangle)
537: (setq picture-killed-rectangle nil)
538: (make-local-variable 'tab-stop-list)
539: (setq tab-stop-list (default-value 'tab-stop-list))
540: (make-local-variable 'picture-tab-chars)
541: (setq picture-tab-chars (default-value 'picture-tab-chars))
542: (make-local-variable 'picture-vertical-step)
543: (make-local-variable 'picture-horizontal-step)
544: (picture-set-motion 0 1)
545: (run-hooks 'edit-picture-hook 'picture-mode-hook)
546: (message
547: (substitute-command-keys
548: "Type \\[picture-mode-exit] in this buffer to return it to %s mode.")
549: picture-mode-old-mode-name)))
550:
551: (fset 'picture-mode 'edit-picture) ; for the confused
552:
553: (defun picture-mode-exit (&optional nostrip)
554: "Undo edit-picture and return to previous major mode.
555: With no argument strips whitespace from end of every line in Picture buffer
556: otherwise just return to previous mode."
557: (interactive "P")
558: (if (not (eq major-mode 'edit-picture))
559: (error "You aren't editing a Picture.")
560: (if (not nostrip) (picture-clean))
561: (setq mode-name picture-mode-old-mode-name)
562: (use-local-map picture-mode-old-local-map)
563: (setq major-mode picture-mode-old-major-mode)
564: (kill-local-variable 'tab-stop-list)
565: ;; Kludge - force the mode line to be updated. Is there a better
566: ;; way to do this?
567: (set-buffer-modified-p (buffer-modified-p))))
568:
569: (defun picture-clean ()
570: "Eliminate whitespace at ends of lines."
571: (save-excursion
572: (goto-char (point-min))
573: (while (re-search-forward "[ \t][ \t]*$" nil t)
574: (delete-region (match-beginning 0) (point)))))
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.