comparison lisp/textmodes/picture.el @ 18412:3febbe908cc3

(picture-draw-rectangle): New command. (picture-mode-map): Add binding for picture-draw-rectangle. (picture-mode): Doc fix. (picture-rectangle-ctl): New variable. (picture-rectangle-ctr): New variable. (picture-rectangle-cbr): New variable. (picture-rectangle-cbl): New variable. (picture-rectangle-v): New variable. (picture-rectangle-h): New variable. (move-to-column-force): Function deleted; calls changed to use move-to-column. (picture-insert): New function. (picture-self-insert): Use picture-insert. (picture-current-line): New function.

18411:ed909ffc3c46

;; support for rectangle operations and `etch-a-sketch' character
;; insertion in any of eight directions.

;;; 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."
  (or (natnump column) (setq column 0))
  (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 horizontal autoscrolling
    (hscroll-point-visible)))


;; 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.

(defun picture-forward-column (arg)
  "Move cursor right, making whitespace if necessary.
With argument, move that many columns."
  (interactive "p")
  (let ((target-column (+ (current-column) arg)))
    (move-to-column-force target-column)
    ;; 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))))

  "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

  (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-command-event)		; Always a character in this case.
    (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)

	(setq list1 (primitive-undo 1 list1))))
    (goto-char pos)
    (if (> change 0)
	(delete-region (point)
		       (progn
			 (move-to-column-force (+ change (current-column)))
			 (point))))
    (replace-match newtext fixedcase literal)
    (if (< change 0)
	(insert-char ?\ (- change)))))


	   (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

    (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,

			      (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)

      (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)

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.

18412:3febbe908cc3

;; 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.")

;; 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.

(defun picture-forward-column (arg)
  "Move cursor right, making whitespace if necessary.
With argument, move that many columns."
  (interactive "p")
  (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))))

  "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 col t)))

(defconst picture-vertical-step 0
  "Amount to move vertically after text character in Picture mode.")

(defconst picture-horizontal-step 1

  (picture-motion (- arg)))


;; 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")
  (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."
  (interactive "p")
  (let* ((opoint (point))
	 (original-col (current-column))
	 (target-col (+ original-col arg)))
    (move-to-column target-col t)
    (delete-region opoint (point))
    (save-excursion
     (indent-to (max target-col original-col)))))

(defun picture-backward-clear-column (arg)

	(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)))))


	   (save-excursion (end-of-line) (point))
	   'move)
	  (setq target (1- (current-column)))
	(setq target nil)))
    (if target
	(move-to-column target t)
      (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

    (prog1 (save-excursion
             (if killp
                 (delete-extract-rectangle start end)
               (prog1 (extract-rectangle start end)
                      (clear-rectangle start end))))
	   (move-to-column column t))))

(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,

			      (picture-forward-column (length (car rectangle)))
			      (picture-move-down (1- (length rectangle)))
			      (point)))))
    (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)))


;; Picture Keymap, entry and exit points.

(defconst picture-mode-map nil)

      (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-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-left)
      (define-key picture-mode-map "\C-c>" 'picture-movement-right)

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.
You can return to the previous mode with:
  C-c C-c Which also strips trailing whitespace from every line.