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