-;; "Picture mode" -- editing using quarter-plane screen model.
-;; Copyright (C) 1985 Free Software Foundation, Inc.
-;; Principal author K. Shane Hartman
+;;; picture.el --- "Picture mode" -- editing using quarter-plane screen model.
+
+;; Copyright (C) 1985, 1994 Free Software Foundation, Inc.
+
+;; Author: K. Shane Hartman
+;; Maintainer: FSF
;; 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)
+;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; 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)
+;; along with GNU Emacs; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;; This code provides the picture-mode commands documented in the Emacs
+;; manual. The screen is treated as a semi-infinite quarter-plane with
+;; support for rectangle operations and `etch-a-sketch' character
+;; insertion in any of eight directions.
+
+;;; Code:
+
+(defvar picture-rectangle-ctl ?+
+ "*Character picture-draw-rectangle uses for top left corners.")
+(defvar picture-rectangle-ctr ?+
+ "*Character picture-draw-rectangle uses for top right corners.")
+(defvar picture-rectangle-cbr ?+
+ "*Character picture-draw-rectangle uses for bottom right corners.")
+(defvar picture-rectangle-cbl ?+
+ "*Character picture-draw-rectangle uses for bottom left corners.")
+(defvar picture-rectangle-v ?|
+ "*Character picture-draw-rectangle uses for vertical lines.")
+(defvar picture-rectangle-h ?-
+ "*Character picture-draw-rectangle uses for horizontal lines.")
-(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))))))
-
-\f
;; Picture Movement Commands
+(defun picture-beginning-of-line (&optional arg)
+ "Position point at the beginning of the 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)
+ ;; This call will go away when Emacs gets real horizontal autoscrolling
+ (hscroll-point-visible))
+
(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.
(interactive "P")
(if arg (forward-line (1- (prefix-numeric-value arg))))
(beginning-of-line)
- (skip-chars-backward " \t" (prog1 (point) (end-of-line))))
+ (skip-chars-backward " \t" (prog1 (point) (end-of-line)))
+ ;; This call will go away when Emacs gets real horizontal autoscrolling
+ (hscroll-point-visible))
(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)))
+ (let ((target-column (+ (current-column) arg)))
+ (move-to-column target-column t)
+ ;; Picture mode isn't really suited to multi-column characters,
+ ;; but we might as well let the user move across them.
+ (and (< arg 0)
+ (> (current-column) target-column)
+ (forward-char -1))))
(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)))
+ (picture-forward-column (- arg)))
(defun picture-move-down (arg)
"Move vertically down, making whitespace if necessary.
(interactive "p")
(let ((col (current-column)))
(picture-newline arg)
- (move-to-column-force col)))
+ (move-to-column col t)))
(defconst picture-vertical-step 0
"Amount to move vertically after text character in Picture mode.")
(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))
+ (force-mode-line-update)
(message ""))
(defun picture-move ()
\f
;; Picture insertion and deletion.
+(defun picture-insert (ch arg)
+ (while (> arg 0)
+ (setq arg (1- arg))
+ (move-to-column (1+ (current-column)) t)
+ (delete-char -1)
+ (insert ch)
+ (forward-char -1)
+ (picture-move)))
+
(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)))
+ (picture-insert last-command-event arg)) ; Always a character in this case.
(defun picture-clear-column (arg)
"Clear out ARG columns after point without moving."
(let* ((opoint (point))
(original-col (current-column))
(target-col (+ original-col arg)))
- (move-to-column-force target-col)
+ (move-to-column target-col t)
(delete-region opoint (point))
(save-excursion
(indent-to (max target-col original-col)))))
(while (> arg 0)
(end-of-line)
(if (eobp) (newline) (forward-char 1))
- (setq arg (1- arg)))))
+ (setq arg (1- arg))))
+ ;; This call will go away when Emacs gets real horizontal autoscrolling
+ (hscroll-point-visible))
(defun picture-open-line (arg)
"Insert an empty line after the current line.
(interactive "p")
(save-excursion
(end-of-line)
- (open-line arg)))
+ (open-line arg))
+ ;; This call will go away when Emacs gets real horizontal autoscrolling
+ (hscroll-point-visible))
(defun picture-duplicate-line ()
"Insert a duplicate of the current line, below it."
(forward-line -1)
(insert contents))))
+;; Like replace-match, but overwrites.
+(defun picture-replace-match (newtext fixedcase literal)
+ (let (ocolumn change pos)
+ (goto-char (setq pos (match-end 0)))
+ (setq ocolumn (current-column))
+ ;; Make the replacement and undo it, to see how it changes the length.
+ (let ((buffer-undo-list nil)
+ list1)
+ (replace-match newtext fixedcase literal)
+ (setq change (- (current-column) ocolumn))
+ (setq list1 buffer-undo-list)
+ (while list1
+ (setq list1 (primitive-undo 1 list1))))
+ (goto-char pos)
+ (if (> change 0)
+ (delete-region (point)
+ (progn
+ (move-to-column (+ change (current-column)) t)
+ (point))))
+ (replace-match newtext fixedcase literal)
+ (if (< change 0)
+ (insert-char ?\ (- change)))))
\f
;; Picture Tabs
(setq target (1- (current-column)))
(setq target nil)))
(if target
- (move-to-column-force target)
+ (move-to-column target t)
(beginning-of-line))))
(defun picture-tab (&optional arg)
(delete-extract-rectangle start end)
(prog1 (extract-rectangle start end)
(clear-rectangle start end))))
- (move-to-column-force column))))
+ (move-to-column column t))))
(defun picture-yank-rectangle (&optional insertp)
"Overlay rectangle saved by \\[picture-clear-rectangle]
(error "No rectangle saved.")
(picture-insert-rectangle picture-killed-rectangle insertp)))
+(defun picture-yank-at-click (click arg)
+ "Insert the last killed rectangle at the position clicked on.
+Also move point to one end of the text thus inserted (normally the end).
+Prefix arguments are interpreted as with \\[yank].
+If `mouse-yank-at-point' is non-nil, insert at point
+regardless of where you click."
+ (interactive "e\nP")
+ (or mouse-yank-at-point (mouse-set-point click))
+ (picture-yank-rectangle arg))
+
(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
(push-mark)
(insert-rectangle rectangle)))
+(defun picture-current-line ()
+ "Return the vertical position of point. Top line is 1."
+ (+ (count-lines (point-min) (point))
+ (if (= (current-column) 0) 1 0)))
+
+(defun picture-draw-rectangle (start end)
+ "Draw a rectangle around region."
+ (interactive "*r") ; start will be less than end
+ (let* ((sl (picture-current-line))
+ (sc (current-column))
+ (pvs picture-vertical-step)
+ (phs picture-horizontal-step)
+ (c1 (progn (goto-char start) (current-column)))
+ (r1 (picture-current-line))
+ (c2 (progn (goto-char end) (current-column)))
+ (r2 (picture-current-line))
+ (right (max c1 c2))
+ (left (min c1 c2))
+ (top (min r1 r2))
+ (bottom (max r1 r2)))
+ (goto-line top)
+ (move-to-column left)
+
+ (picture-movement-right)
+ (picture-insert picture-rectangle-ctl 1)
+ (picture-insert picture-rectangle-h (- right (current-column)))
+
+ (picture-movement-down)
+ (picture-insert picture-rectangle-ctr 1)
+ (picture-insert picture-rectangle-v (- bottom (picture-current-line)))
+
+ (picture-movement-left)
+ (picture-insert picture-rectangle-cbr 1)
+ (picture-insert picture-rectangle-h (- (current-column) left))
+
+ (picture-movement-up)
+ (picture-insert picture-rectangle-cbl 1)
+ (picture-insert picture-rectangle-v (- (picture-current-line) top))
+
+ (picture-set-motion pvs phs)
+ (goto-line sl)
+ (move-to-column sc t)))
+
\f
;; Picture Keymap, entry and exit points.
(defconst picture-mode-map nil)
+(defun picture-substitute (oldfun newfun)
+ (substitute-key-definition oldfun newfun picture-mode-map global-map))
+
(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)
+ (progn
+ (setq picture-mode-map (list 'keymap (make-vector 256 nil)))
+ (picture-substitute 'self-insert-command 'picture-self-insert)
+ (picture-substitute 'completion-separator-self-insert-command
+ 'picture-self-insert)
+ (picture-substitute 'completion-separator-self-insert-autofilling
+ 'picture-self-insert)
+ (picture-substitute 'forward-char 'picture-forward-column)
+ (picture-substitute 'backward-char 'picture-backward-column)
+ (picture-substitute 'delete-char 'picture-clear-column)
+ ;; There are two possibilities for what is normally on DEL.
+ (picture-substitute 'backward-delete-char-untabify 'picture-backward-clear-column)
+ (picture-substitute 'delete-backward-char 'picture-backward-clear-column)
+ (picture-substitute 'kill-line 'picture-clear-line)
+ (picture-substitute 'open-line 'picture-open-line)
+ (picture-substitute 'newline 'picture-newline)
+ (picture-substitute 'newline-and-indent 'picture-duplicate-line)
+ (picture-substitute 'next-line 'picture-move-down)
+ (picture-substitute 'previous-line 'picture-move-up)
+ (picture-substitute 'beginning-of-line 'picture-beginning-of-line)
+ (picture-substitute 'end-of-line 'picture-end-of-line)
+
(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\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-r" 'picture-draw-rectangle)
(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-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].")
+(defvar picture-mode-hook nil
+ "If non-nil, its value is called on entry to Picture mode.
+Picture mode is invoked by the command \\[picture-mode].")
+
+(defvar picture-mode-old-local-map)
+(defvar picture-mode-old-mode-name)
+(defvar picture-mode-old-major-mode)
+(defvar picture-mode-old-truncate-lines)
;;;###autoload
-(defun edit-picture ()
+(defun picture-mode ()
"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:
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.
+ \\[picture-move-down] Move vertically to SAME column in previous line.
+ \\[picture-move-up] Move vertically to SAME column in next line.
+ \\[picture-end-of-line] Move to column following last non-whitespace character.
+ \\[picture-forward-column] Move right inserting spaces if required.
+ \\[picture-backward-column] 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 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
+ \\[picture-backward-clear-column] Clear (replace) ARG columns before point, moving back over them.
+ \\[picture-clear-line] Clear ARG lines, advancing over them. The cleared
text is saved in the kill ring.
- C-o Open blank line(s) beneath current line.
+ \\[picture-open-line] 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.
+ C-c C-r Draw a rectangular box around mark and point.
\\[copy-rectangle-to-register] Copies a rectangle to a register.
\\[advertised-undo] Can undo effects of rectangle overlay commands
commands if invoked soon enough.
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.
+Entry to this mode calls the value of picture-mode-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.")
+ (if (eq major-mode 'picture-mode)
+ (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)
(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)
+ (setq major-mode 'picture-mode)
(make-local-variable 'picture-killed-rectangle)
(setq picture-killed-rectangle nil)
(make-local-variable 'tab-stop-list)
(setq picture-tab-chars (default-value 'picture-tab-chars))
(make-local-variable 'picture-vertical-step)
(make-local-variable 'picture-horizontal-step)
+ (make-local-variable 'picture-mode-old-truncate-lines)
+ (setq picture-mode-old-truncate-lines truncate-lines)
+ (setq truncate-lines t)
(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)))
+
+ ;; edit-picture-hook is what we used to run, picture-mode-hook is in doc.
+ (run-hooks 'edit-picture-hook 'picture-mode-hook)
+ (message "Type %s in this buffer to return it to %s mode."
+ (substitute-command-keys "\\[picture-mode-exit]")
+ picture-mode-old-mode-name)))
;;;###autoload
-(fset 'picture-mode 'edit-picture)
+(defalias 'edit-picture 'picture-mode)
(defun picture-mode-exit (&optional nostrip)
- "Undo edit-picture and return to previous major mode.
+ "Undo picture-mode 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))
+ (if (not (eq major-mode 'picture-mode))
(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))))
+ (setq truncate-lines picture-mode-old-truncate-lines)
+ (force-mode-line-update)))
(defun picture-clean ()
"Eliminate whitespace at ends of lines."
(goto-char (point-min))
(while (re-search-forward "[ \t][ \t]*$" nil t)
(delete-region (match-beginning 0) (point)))))
+
+(provide 'picture)
+
+;;; picture.el ends here