changeset 238:d2e1685ba8f1

Initial revision

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lisp/textmodes/picture.el	Wed Apr 10 17:07:22 1991 +0000
@@ -0,0 +1,558 @@
+;; "Picture mode" -- editing using quarter-plane screen model.
+;; Copyright (C) 1985 Free Software Foundation, Inc.
+;; Principal author K. Shane Hartman
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 1, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to
+;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+
+(provide 'picture)
+
+(defun move-to-column-force (column)
+  "Move to column COLUMN in current line.
+Differs from `move-to-column' in that it creates or modifies whitespace
+if necessary to attain exactly the specified column."
+  (move-to-column column)
+  (let ((col (current-column)))
+    (if (< col column)
+	(indent-to column)
+      (if (and (/= col column)
+	       (= (preceding-char) ?\t))
+	  (let (indent-tabs-mode)
+	    (delete-char -1)
+            (indent-to col)
+            (move-to-column column))))))
+
+
+;; Picture Movement Commands
+
+(defun picture-end-of-line (&optional arg)
+  "Position point after last non-blank character on current line.
+With ARG not nil, move forward ARG - 1 lines first.
+If scan reaches end of buffer, stop there without error."
+  (interactive "P")
+  (if arg (forward-line (1- (prefix-numeric-value arg))))
+  (beginning-of-line)
+  (skip-chars-backward " \t" (prog1 (point) (end-of-line))))
+
+(defun picture-forward-column (arg)
+  "Move cursor right, making whitespace if necessary.
+With argument, move that many columns."
+  (interactive "p")
+  (move-to-column-force (+ (current-column) arg)))
+
+(defun picture-backward-column (arg)
+  "Move cursor left, making whitespace if necessary.
+With argument, move that many columns."
+  (interactive "p")
+  (move-to-column-force (- (current-column) arg)))
+
+(defun picture-move-down (arg)
+  "Move vertically down, making whitespace if necessary.
+With argument, move that many lines."
+  (interactive "p")
+  (let ((col (current-column)))
+    (picture-newline arg)
+    (move-to-column-force col)))
+
+(defconst picture-vertical-step 0
+  "Amount to move vertically after text character in Picture mode.")
+
+(defconst picture-horizontal-step 1
+  "Amount to move horizontally after text character in Picture mode.")
+
+(defun picture-move-up (arg)
+  "Move vertically up, making whitespace if necessary.
+With argument, move that many lines."
+  (interactive "p")
+  (picture-move-down (- arg)))
+
+(defun picture-movement-right ()
+  "Move right after self-inserting character in Picture mode."
+  (interactive)
+  (picture-set-motion 0 1))
+
+(defun picture-movement-left ()
+  "Move left after self-inserting character in Picture mode."
+  (interactive)
+  (picture-set-motion 0 -1))
+
+(defun picture-movement-up ()
+  "Move up after self-inserting character in Picture mode."
+  (interactive)
+  (picture-set-motion -1 0))
+
+(defun picture-movement-down ()
+  "Move down after self-inserting character in Picture mode."
+  (interactive)
+  (picture-set-motion 1 0))
+
+(defun picture-movement-nw ()
+  "Move up and left after self-inserting character in Picture mode."
+  (interactive)
+  (picture-set-motion -1 -1))
+
+(defun picture-movement-ne ()
+  "Move up and right after self-inserting character in Picture mode."
+  (interactive)
+  (picture-set-motion -1 1))
+
+(defun picture-movement-sw ()
+  "Move down and left after self-inserting character in Picture mode."
+  (interactive)
+  (picture-set-motion 1 -1))
+
+(defun picture-movement-se ()
+  "Move down and right after self-inserting character in Picture mode."
+  (interactive)
+  (picture-set-motion 1 1))
+
+(defun picture-set-motion (vert horiz)
+  "Set VERTICAL and HORIZONTAL increments for movement in Picture mode.
+The mode line is updated to reflect the current direction."
+  (setq picture-vertical-step vert
+	picture-horizontal-step horiz)
+  (setq mode-name
+	(format "Picture:%s"
+		(car (nthcdr (+ 1 (% horiz 2) (* 3 (1+ (% vert 2))))
+			     '(nw up ne left none right sw down se)))))
+  ;; Kludge - force the mode line to be updated.  Is there a better
+  ;; way to this?
+  (set-buffer-modified-p (buffer-modified-p))
+  (message ""))
+
+(defun picture-move ()
+  "Move in direction of `picture-vertical-step' and `picture-horizontal-step'."
+  (picture-move-down picture-vertical-step)
+  (picture-forward-column picture-horizontal-step))
+
+(defun picture-motion (arg)
+  "Move point in direction of current picture motion in Picture mode.
+With ARG do it that many times.  Useful for delineating rectangles in
+conjunction with diagonal picture motion.
+Do \\[command-apropos]  picture-movement  to see commands which control motion."
+  (interactive "p")
+  (picture-move-down (* arg picture-vertical-step))
+  (picture-forward-column (* arg picture-horizontal-step)))
+
+(defun picture-motion-reverse (arg)
+  "Move point in direction opposite of current picture motion in Picture mode.
+With ARG do it that many times.  Useful for delineating rectangles in
+conjunction with diagonal picture motion.
+Do \\[command-apropos] `picture-movement' to see commands which control motion."
+  (interactive "p")
+  (picture-motion (- arg)))
+
+
+;; Picture insertion and deletion.
+
+(defun picture-self-insert (arg)
+  "Insert this character in place of character previously at the cursor.
+The cursor then moves in the direction you previously specified
+with the commands `picture-movement-right', `picture-movement-up', etc.
+Do \\[command-apropos] `picture-movement' to see those commands."
+  (interactive "p")
+  (while (> arg 0)
+    (setq arg (1- arg))
+    (move-to-column-force (1+ (current-column)))
+    (delete-char -1)
+    (insert last-input-char)
+    (forward-char -1)
+    (picture-move)))
+
+(defun picture-clear-column (arg)
+  "Clear out ARG columns after point without moving."
+  (interactive "p")
+  (let* ((opoint (point))
+	 (original-col (current-column))
+	 (target-col (+ original-col arg)))
+    (move-to-column-force target-col)
+    (delete-region opoint (point))
+    (save-excursion
+     (indent-to (max target-col original-col)))))
+
+(defun picture-backward-clear-column (arg)
+  "Clear out ARG columns before point, moving back over them."
+  (interactive "p")
+  (picture-clear-column (- arg)))
+
+(defun picture-clear-line (arg)
+  "Clear out rest of line; if at end of line, advance to next line.
+Cleared-out line text goes into the kill ring, as do newlines that are
+advanced over.  With argument, clear out (and save in kill ring) that
+many lines."
+  (interactive "P")
+  (if arg
+      (progn
+       (setq arg (prefix-numeric-value arg))
+       (kill-line arg)
+       (newline (if (> arg 0) arg (- arg))))
+    (if (looking-at "[ \t]*$")
+	(kill-ring-save (point) (progn (forward-line 1) (point)))
+      (kill-region (point) (progn (end-of-line) (point))))))
+
+(defun picture-newline (arg)
+  "Move to the beginning of the following line.
+With argument, moves that many lines (up, if negative argument);
+always moves to the beginning of a line."
+  (interactive "p")
+  (if (< arg 0)
+      (forward-line arg)
+    (while (> arg 0)
+      (end-of-line)
+      (if (eobp) (newline) (forward-char 1))
+      (setq arg (1- arg)))))
+
+(defun picture-open-line (arg)
+  "Insert an empty line after the current line.
+With positive argument insert that many lines."
+  (interactive "p")
+  (save-excursion
+   (end-of-line)
+   (open-line arg)))
+
+(defun picture-duplicate-line ()
+  "Insert a duplicate of the current line, below it."
+  (interactive)
+  (save-excursion
+   (let ((contents
+	  (buffer-substring
+	   (progn (beginning-of-line) (point))
+	   (progn (picture-newline 1) (point)))))
+     (forward-line -1)
+     (insert contents))))
+
+
+;; Picture Tabs
+
+(defvar picture-tab-chars "!-~"
+  "*A character set which controls behavior of commands
+\\[picture-set-tab-stops] and \\[picture-tab-search].  It is NOT a
+regular expression, any regexp special characters will be quoted.
+It defines a set of \"interesting characters\" to look for when setting
+\(or searching for) tab stops, initially \"!-~\" (all printing characters).
+For example, suppose that you are editing a table which is formatted thus:
+| foo		| bar + baz | 23  *
+| bubbles	| and + etc | 97  *
+and that `picture-tab-chars' is \"|+*\".  Then invoking
+\\[picture-set-tab-stops] on either of the previous lines would result
+in the following tab stops
+		:     :     :     :
+Another example - \"A-Za-z0-9\" would produce the tab stops
+  :		  :	:     :
+
+Note that if you want the character `-' to be in the set, it must be
+included in a range or else appear in a context where it cannot be
+taken for indicating a range (e.g. \"-A-Z\" declares the set to be the
+letters `A' through `Z' and the character `-').  If you want the
+character `\\' in the set it must be preceded by itself: \"\\\\\".
+
+The command \\[picture-tab-search] is defined to move beneath (or to) a
+character belonging to this set independent of the tab stops list.")
+
+(defun picture-set-tab-stops (&optional arg)
+  "Set value of `tab-stop-list' according to context of this line.
+This controls the behavior of \\[picture-tab].  A tab stop is set at
+every column occupied by an \"interesting character\" that is preceded
+by whitespace.  Interesting characters are defined by the variable
+`picture-tab-chars', see its documentation for an example of usage.
+With ARG, just (re)set `tab-stop-list' to its default value.  The tab
+stops computed are displayed in the minibuffer with `:' at each stop."
+  (interactive "P")
+  (save-excursion
+    (let (tabs)
+      (if arg
+	  (setq tabs (default-value 'tab-stop-list))
+	(let ((regexp (concat "[ \t]+[" (regexp-quote picture-tab-chars) "]")))
+	  (beginning-of-line)
+	  (let ((bol (point)))
+	    (end-of-line)
+	    (while (re-search-backward regexp bol t)
+	      (skip-chars-forward " \t")
+	      (setq tabs (cons (current-column) tabs)))
+	    (if (null tabs)
+		(error "No characters in set %s on this line."
+		       (regexp-quote picture-tab-chars))))))
+      (setq tab-stop-list tabs)
+      (let ((blurb (make-string (1+ (nth (1- (length tabs)) tabs)) ?\ )))
+	(while tabs
+	  (aset blurb (car tabs) ?:)
+	  (setq tabs (cdr tabs)))
+	(message blurb)))))
+
+(defun picture-tab-search (&optional arg)
+  "Move to column beneath next interesting char in previous line.
+With ARG move to column occupied by next interesting character in this
+line.  The character must be preceded by whitespace.
+\"interesting characters\" are defined by variable `picture-tab-chars'.
+If no such character is found, move to beginning of line."
+  (interactive "P")
+  (let ((target (current-column)))
+    (save-excursion
+      (if (and (not arg)
+	       (progn
+		 (beginning-of-line)
+		 (skip-chars-backward
+		  (concat "^" (regexp-quote picture-tab-chars))
+		  (point-min))
+		 (not (bobp))))
+	  (move-to-column target))
+      (if (re-search-forward
+	   (concat "[ \t]+[" (regexp-quote picture-tab-chars) "]")
+	   (save-excursion (end-of-line) (point))
+	   'move)
+	  (setq target (1- (current-column)))
+	(setq target nil)))
+    (if target
+	(move-to-column-force target)
+      (beginning-of-line))))
+
+(defun picture-tab (&optional arg)
+  "Tab transparently (just move point) to next tab stop.
+With prefix arg, overwrite the traversed text with spaces.  The tab stop
+list can be changed by \\[picture-set-tab-stops] and \\[edit-tab-stops].
+See also documentation for variable `picture-tab-chars'."
+  (interactive "P")
+  (let* ((opoint (point)))
+    (move-to-tab-stop)
+    (if arg
+	(let (indent-tabs-mode
+	      (column (current-column)))
+	  (delete-region opoint (point))
+	  (indent-to column)))))
+
+;; Picture Rectangles
+
+(defconst picture-killed-rectangle nil
+  "Rectangle killed or copied by \\[picture-clear-rectangle] in Picture mode.
+The contents can be retrieved by \\[picture-yank-rectangle]")
+
+(defun picture-clear-rectangle (start end &optional killp)
+  "Clear and save rectangle delineated by point and mark.
+The rectangle is saved for yanking by \\[picture-yank-rectangle] and replaced
+with whitespace.  The previously saved rectangle, if any, is lost.  With
+prefix argument, the rectangle is actually killed, shifting remaining text."
+  (interactive "r\nP")
+  (setq picture-killed-rectangle (picture-snarf-rectangle start end killp)))
+
+(defun picture-clear-rectangle-to-register (start end register &optional killp)
+  "Clear rectangle delineated by point and mark into REGISTER.
+The rectangle is saved in REGISTER and replaced with whitespace.  With
+prefix argument, the rectangle is actually killed, shifting remaining text."
+  (interactive "r\ncRectangle to register: \nP")
+  (set-register register (picture-snarf-rectangle start end killp)))
+
+(defun picture-snarf-rectangle (start end &optional killp)
+  (let ((column (current-column))
+	(indent-tabs-mode nil))
+    (prog1 (save-excursion
+             (if killp
+                 (delete-extract-rectangle start end)
+               (prog1 (extract-rectangle start end)
+                      (clear-rectangle start end))))
+	   (move-to-column-force column))))
+
+(defun picture-yank-rectangle (&optional insertp)
+  "Overlay rectangle saved by \\[picture-clear-rectangle]
+The rectangle is positioned with upper left corner at point, overwriting
+existing text.  With prefix argument, the rectangle is inserted instead,
+shifting existing text.  Leaves mark at one corner of rectangle and
+point at the other (diagonally opposed) corner."
+  (interactive "P")
+  (if (not (consp picture-killed-rectangle))
+      (error "No rectangle saved.")
+    (picture-insert-rectangle picture-killed-rectangle insertp)))
+
+(defun picture-yank-rectangle-from-register (register &optional insertp)
+  "Overlay rectangle saved in REGISTER.
+The rectangle is positioned with upper left corner at point, overwriting
+existing text.  With prefix argument, the rectangle is
+inserted instead, shifting existing text.  Leaves mark at one corner
+of rectangle and point at the other (diagonally opposed) corner."
+  (interactive "cRectangle from register: \nP")
+  (let ((rectangle (get-register register)))
+    (if (not (consp rectangle))
+	(error "Register %c does not contain a rectangle." register)
+      (picture-insert-rectangle rectangle insertp))))
+
+(defun picture-insert-rectangle (rectangle &optional insertp)
+  "Overlay RECTANGLE with upper left corner at point.
+Optional argument INSERTP, if non-nil causes RECTANGLE to be inserted.
+Leaves the region surrounding the rectangle."
+  (let ((indent-tabs-mode nil))
+    (if (not insertp)
+	(save-excursion
+	  (delete-rectangle (point)
+			    (progn
+			      (picture-forward-column (length (car rectangle)))
+			      (picture-move-down (1- (length rectangle)))
+			      (point)))))
+    (push-mark)
+    (insert-rectangle rectangle)))
+
+
+;; Picture Keymap, entry and exit points.
+
+(defconst picture-mode-map nil)
+
+(if (not picture-mode-map)
+    (let ((i ?\ ))
+      (setq picture-mode-map (make-keymap))
+      (while (< i ?\177)
+        (aset picture-mode-map i 'picture-self-insert)
+	(setq i (1+ i)))
+      (define-key picture-mode-map "\C-f" 'picture-forward-column)
+      (define-key picture-mode-map "\C-b" 'picture-backward-column)
+      (define-key picture-mode-map "\C-d" 'picture-clear-column)
+      (define-key picture-mode-map "\C-c\C-d" 'delete-char)
+      (define-key picture-mode-map "\177" 'picture-backward-clear-column)
+      (define-key picture-mode-map "\C-k" 'picture-clear-line)
+      (define-key picture-mode-map "\C-o" 'picture-open-line)
+      (define-key picture-mode-map "\C-m" 'picture-newline)
+      (define-key picture-mode-map "\C-j" 'picture-duplicate-line)
+      (define-key picture-mode-map "\C-n" 'picture-move-down)
+      (define-key picture-mode-map "\C-p" 'picture-move-up)
+      (define-key picture-mode-map "\C-e" 'picture-end-of-line)
+      (define-key picture-mode-map "\e\t" 'picture-toggle-tab-state)
+      (define-key picture-mode-map "\t" 'picture-tab)
+      (define-key picture-mode-map "\e\t" 'picture-tab-search)
+      (define-key picture-mode-map "\C-c\t" 'picture-set-tab-stops)
+      (define-key picture-mode-map "\C-c\C-k" 'picture-clear-rectangle)
+      (define-key picture-mode-map "\C-c\C-w" 'picture-clear-rectangle-to-register)
+      (define-key picture-mode-map "\C-c\C-y" 'picture-yank-rectangle)
+      (define-key picture-mode-map "\C-c\C-x" 'picture-yank-rectangle-from-register)
+      (define-key picture-mode-map "\C-c\C-c" 'picture-mode-exit)
+      (define-key picture-mode-map "\C-c\C-f" 'picture-motion)
+      (define-key picture-mode-map "\C-c\C-b" 'picture-motion-reverse)
+      (define-key picture-mode-map "\C-c<" 'picture-movement-left)
+      (define-key picture-mode-map "\C-c>" 'picture-movement-right)
+      (define-key picture-mode-map "\C-c^" 'picture-movement-up)
+      (define-key picture-mode-map "\C-c." 'picture-movement-down)
+      (define-key picture-mode-map "\C-c`" 'picture-movement-nw)
+      (define-key picture-mode-map "\C-c'" 'picture-movement-ne)
+      (define-key picture-mode-map "\C-c/" 'picture-movement-sw)
+      (define-key picture-mode-map "\C-c\\" 'picture-movement-se)))
+
+(defvar edit-picture-hook nil
+  "If non-nil, it's value is called on entry to Picture mode.
+Picture mode is invoked by the command \\[edit-picture].")
+
+(defun edit-picture ()
+  "Switch to Picture mode, in which a quarter-plane screen model is used.
+Printing characters replace instead of inserting themselves with motion
+afterwards settable by these commands:
+  C-c <	  Move left after insertion.
+  C-c >	  Move right after insertion.
+  C-c ^	  Move up after insertion.
+  C-c .	  Move down after insertion.
+  C-c `	  Move northwest (nw) after insertion.
+  C-c '	  Move northeast (ne) after insertion.
+  C-c /	  Move southwest (sw) after insertion.
+  C-c \\   Move southeast (se) after insertion.
+The current direction is displayed in the mode line.  The initial
+direction is right.  Whitespace is inserted and tabs are changed to
+spaces when required by movement.  You can move around in the buffer
+with these commands:
+  C-p	  Move vertically to SAME column in previous line.
+  C-n	  Move vertically to SAME column in next line.
+  C-e	  Move to column following last non-whitespace character.
+  C-f	  Move right inserting spaces if required.
+  C-b	  Move left changing tabs to spaces if required.
+  C-c C-f Move in direction of current picture motion.
+  C-c C-b Move in opposite direction of current picture motion.
+  Return  Move to beginning of next line.
+You can edit tabular text with these commands:
+  M-Tab	  Move to column beneath (or at) next interesting character.
+	    `Indents' relative to a previous line.
+  Tab	  Move to next stop in tab stop list.
+  C-c Tab Set tab stops according to context of this line.
+	    With ARG resets tab stops to default (global) value.
+	    See also documentation of variable	picture-tab-chars
+	    which defines \"interesting character\".  You can manually
+	    change the tab stop list with command \\[edit-tab-stops].
+You can manipulate text with these commands:
+  C-d	  Clear (replace) ARG columns after point without moving.
+  C-c C-d Delete char at point - the command normally assigned to C-d.
+  Delete  Clear (replace) ARG columns before point, moving back over them.
+  C-k	  Clear ARG lines, advancing over them.	 The cleared
+	    text is saved in the kill ring.
+  C-o	  Open blank line(s) beneath current line.
+You can manipulate rectangles with these commands:
+  C-c C-k Clear (or kill) a rectangle and save it.
+  C-c C-w Like C-c C-k except rectangle is saved in named register.
+  C-c C-y Overlay (or insert) currently saved rectangle at point.
+  C-c C-x Like C-c C-y except rectangle is taken from named register.
+  \\[copy-rectangle-to-register]   Copies a rectangle to a register.
+  \\[advertised-undo]   Can undo effects of rectangle overlay commands
+	    commands if invoked soon enough.
+You can return to the previous mode with:
+  C-c C-c Which also strips trailing whitespace from every line.
+	    Stripping is suppressed by supplying an argument.
+
+Entry to this mode calls the value of  edit-picture-hook  if non-nil.
+
+Note that Picture mode commands will work outside of Picture mode, but
+they are not defaultly assigned to keys."
+  (interactive)
+  (if (eq major-mode 'edit-picture)
+      (error "You are already editing a Picture.")
+    (make-local-variable 'picture-mode-old-local-map)
+    (setq picture-mode-old-local-map (current-local-map))
+    (use-local-map picture-mode-map)
+    (make-local-variable 'picture-mode-old-mode-name)
+    (setq picture-mode-old-mode-name mode-name)
+    (make-local-variable 'picture-mode-old-major-mode)
+    (setq picture-mode-old-major-mode major-mode)
+    (setq major-mode 'edit-picture)
+    (make-local-variable 'picture-killed-rectangle)
+    (setq picture-killed-rectangle nil)
+    (make-local-variable 'tab-stop-list)
+    (setq tab-stop-list (default-value 'tab-stop-list))
+    (make-local-variable 'picture-tab-chars)
+    (setq picture-tab-chars (default-value 'picture-tab-chars))
+    (make-local-variable 'picture-vertical-step)
+    (make-local-variable 'picture-horizontal-step)
+    (picture-set-motion 0 1)
+    (run-hooks 'edit-picture-hook)
+    (message
+     (substitute-command-keys
+      "Type \\[picture-mode-exit] in this buffer to return it to %s mode.")
+     picture-mode-old-mode-name)))
+
+(fset 'picture-mode 'edit-picture)	; for the confused
+
+(defun picture-mode-exit (&optional nostrip)
+  "Undo edit-picture and return to previous major mode.
+With no argument strips whitespace from end of every line in Picture buffer
+  otherwise just return to previous mode."
+  (interactive "P")
+  (if (not (eq major-mode 'edit-picture))
+      (error "You aren't editing a Picture.")
+    (if (not nostrip) (picture-clean))
+    (setq mode-name picture-mode-old-mode-name)
+    (use-local-map picture-mode-old-local-map)
+    (setq major-mode picture-mode-old-major-mode)
+    (kill-local-variable 'tab-stop-list)
+    ;; Kludge - force the mode line to be updated.  Is there a better
+    ;; way to do this?
+    (set-buffer-modified-p (buffer-modified-p))))
+
+(defun picture-clean ()
+  "Eliminate whitespace at ends of lines."
+  (save-excursion
+   (goto-char (point-min))
+   (while (re-search-forward "[ \t][ \t]*$" nil t)
+     (delete-region (match-beginning 0) (point)))))