;;; picture.el --- "Picture mode" -- editing using quarter-plane screen model.
-;; Copyright (C) 1985 Free Software Foundation, Inc.
+;; Copyright (C) 1985, 1994 Free Software Foundation, Inc.
;; Author: K. Shane Hartman
;; Maintainer: FSF
;; 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.
+;; 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:
;;; Code:
-(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))))
- ;; This call will go away when Emacs gets real horizonal autoscrolling
- (hscroll-point-visible)))
+(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.")
-\f
;; Picture Movement Commands
(defun picture-beginning-of-line (&optional arg)
(interactive "P")
(if arg (forward-line (1- (prefix-numeric-value arg))))
(beginning-of-line)
- ;; This call will go away when Emacs gets real horizonal autoscrolling
+ ;; This call will go away when Emacs gets real horizontal autoscrolling
(hscroll-point-visible))
(defun picture-end-of-line (&optional arg)
(if arg (forward-line (1- (prefix-numeric-value arg))))
(beginning-of-line)
(skip-chars-backward " \t" (prog1 (point) (end-of-line)))
- ;; This call will go away when Emacs gets real horizonal autoscrolling
+ ;; 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)))))
(end-of-line)
(if (eobp) (newline) (forward-char 1))
(setq arg (1- arg))))
- ;; This call will go away when Emacs gets real horizonal autoscrolling
+ ;; This call will go away when Emacs gets real horizontal autoscrolling
(hscroll-point-visible))
(defun picture-open-line (arg)
(save-excursion
(end-of-line)
(open-line arg))
- ;; This call will go away when Emacs gets real horizonal autoscrolling
+ ;; This call will go away when Emacs gets real horizontal autoscrolling
(hscroll-point-visible))
(defun picture-duplicate-line ()
(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.
(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)
- (define-key picture-mode-map (make-string 1 i) 'picture-self-insert)
- (setq i (1+ i)))
-
+ (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-andindent 'picture-duplicate-line)
+ (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)
(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)
(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 picture-mode ()
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.
(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)
;; edit-picture-hook is what we used to run, picture-mode-hook is in doc.
(run-hooks 'edit-picture-hook 'picture-mode-hook)
- (message
- (substitute-command-keys
- "Type \\[picture-mode-exit] in this buffer to return it to %s mode.")
- picture-mode-old-mode-name)))
+ (message "Type %s in this buffer to return it to %s mode."
+ (substitute-command-keys "\\[picture-mode-exit]")
+ picture-mode-old-mode-name)))
;;;###autoload
(defalias 'edit-picture 'picture-mode)
(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."