rect-mark.el

;;; rect-mark.el --- Mark a rectangle of text with highlighting.

;;; Copyright (C) 1994, 1995 Rick Sladkey <jrs@world.std.com>

;;; This file is not part of GNU Emacs but it is distributed under the
;;; same conditions as GNU Emacs.

;;; This is free software.
;;; 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 2, 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.

;; Author: Rick Sladkey <jrs@world.std.com>
;; Version: 1.4

;;; Commentary:

;; If you use both transient-mark-mode and picture-mode, you will
;; probably realize how convenient it would be to be able to highlight
;; the region between point and mark as a rectangle.  Have you ever
;; wished you could see where exactly those other two corners fell
;; before you operated on a rectangle?  If so, then this program is
;; for you.

;; For example, you can set the mark in preparation for a rectangle
;; command with `C-x r C-SPC', watch the highlighted rectangle grow as
;; you move the cursor to the other corner, and then issue the command
;; and the rectangle disappears.  Or if point and mark are already set
;; but you want to see what the region would look like as a rectangle,
;; try `C-x r C-x' which exchanges point and mark and makes the
;; highlighted region rectangular.

;; The default Emacs key-bindings put `point-to-register' on
;; `C-x r C-SPC' but since that command it is already on `C-x r SPC'
;; and since it is irresistably intuitive to put `rm-set-mark' on
;; `C-x r C-SPC', I have taken the liberty of recommending that you
;; override the default key-bindings.

;; You can also kill or copy rectangles onto the kill ring which is
;; convenient for yanking rectangles into ordinary buffers (i.e.  ones
;; not in picture mode) and for pasting rectangles into other window
;; system programs (e.g. xterm).  These keys are by default bound to
;; `C-x r C-w' and `C-x r M-w' by analogy to the normal kill and copy
;; counterparts.

;; Finally, there is mouse support for rectangle highlighting by
;; dragging the mouse while holding down the shift key.  The idea is
;; that this behaves exactly like normal mouse dragging except that
;; the region is treated as a rectangle.

;;; Usage:

;; Use this section in your "~/.emacs" when rect-mark isn't included
;; as an integral part of Emacs.  Don't forget to remove the first
;; three columns.

;; ;; Support for marking a rectangle of text with highlighting.
;; (define-key ctl-x-map "r\C-@" 'rm-set-mark)
;; (define-key ctl-x-map [?r ?\C-\ ] 'rm-set-mark)
;; (define-key ctl-x-map "r\C-x" 'rm-exchange-point-and-mark)
;; (define-key ctl-x-map "r\C-w" 'rm-kill-region)
;; (define-key ctl-x-map "r\M-w" 'rm-kill-ring-save)
;; (define-key global-map [S-down-mouse-1] 'rm-mouse-drag-region)
;; (autoload 'rm-set-mark "rect-mark"
;;   "Set mark for rectangle." t)
;; (autoload 'rm-exchange-point-and-mark "rect-mark"
;;   "Exchange point and mark for rectangle." t)
;; (autoload 'rm-kill-region "rect-mark"
;;   "Kill a rectangular region and save it in the kill ring." t)
;; (autoload 'rm-kill-ring-save "rect-mark"
;;   "Copy a rectangular region to the kill ring." t)
;; (autoload 'rm-mouse-drag-region "rect-mark"
;;   "Drag out a rectangular region with the mouse." t)

;; Use this section in your "~/.emacs" to modify picture mode so that
;; it automatically uses the rect-mark equivalents of many commands.

;; ;; One vision of a better picture mode.
;; (add-hook 'picture-mode-hook 'rm-example-picture-mode-bindings)
;; (autoload 'rm-example-picture-mode-bindings "rect-mark"
;;   "Example rect-mark key and mouse bindings for picture mode.")

;;; Code:


;;;###autoload (define-key ctl-x-map "r\C-@" 'rm-set-mark)
;;;###autoload (define-key ctl-x-map [?r ?\C-\ ] 'rm-set-mark)
;;;###autoload (define-key ctl-x-map "r\C-x" 'rm-exchange-point-and-mark)
;;;###autoload (define-key ctl-x-map "r\C-w" 'rm-kill-region)
;;;###autoload (define-key ctl-x-map "r\M-w" 'rm-kill-ring-save)
;;;###autoload (define-key global-map [S-down-mouse-1] 'rm-mouse-drag-region)

;; Our state variables, each internal and buffer local.
(defvar rm-mark-active nil)
(defvar rm-overlay-list)
(defvar rm-old-transient-mark-mode)
(defvar rm-force)
(defvar rm-old-global-variables)

;; A list of our buffer local variables.
(defconst rm-our-local-variables
  '(rm-mark-active
    rm-overlay-list
    rm-old-transient-mark-mode
    rm-force
    rm-old-global-variables))

;; System variables which must temorarily be buffer local.
(defconst rm-temporary-local-variables
  '(transient-mark-mode
    ;; Alas, we can no longer uninstall a post command hook from a post
    ;; command hook (as of 19.28 at least) so we must leave it installed
    ;; globally.
    ;post-command-hook
    deactivate-mark-hook))

;; Those commands which don't necessarily deactivate the mark but
;; should.  This is a partial list as of Emacs 19.22.  Most problems
;; are the result of the pathological case of a zero-width rectangle.
(defconst rm-deactivate-mark-commands
  '(clear-rectangle
    copy-rectangle
    copy-rectangle-to-register
    kill-rectangle
    open-rectangle
    string-rectangle
    yank-rectangle
    keyboard-quit))

;;; Quiet the byte-compiler.
(defvar killed-rectangle)
(defvar picture-mode-map)
(defvar deactivate-mark-hook)


;;;###autoload
(defun rm-example-picture-mode-bindings ()
  "Example rect-mark keyboard and mouse bindings for picture mode."
  (define-key picture-mode-map "\C-@" 'rm-set-mark)
  (define-key picture-mode-map [?\C-\ ] 'rm-set-mark)
  (define-key picture-mode-map [down-mouse-1] 'rm-mouse-drag-region)
  (define-key picture-mode-map "\C-x\C-x" 'rm-exchange-point-and-mark)
  (define-key picture-mode-map "\C-w" 'rm-kill-region)
  (define-key picture-mode-map "\M-w" 'rm-kill-ring-save)
  (define-key picture-mode-map "\C-y" 'yank-rectangle)
  ;; Prevent `move-to-column-force' from deactivating the mark.
  (defun move-to-column-force (column)
    (let ((deactivate-mark deactivate-mark))
      (move-to-column (max column 0) t)
      (hscroll-point-visible))))

;;;###autoload
(defun rm-set-mark (force)
  "Set mark like `set-mark-command' but anticipates a rectangle.
This arranges for the rectangular region between point and mark
to be highlighted using the same face that is used to highlight
the region in `transient-mark-mode'.  This special state lasts only
until the mark is deactivated, usually by executing a text-modifying
command like \\[kill-rectangle], by inserting text, or by typing \\[keyboard-quit].

With optional argument FORCE, arrange for tabs to be expanded and
for spaces to inserted as necessary to keep the region perfectly
rectangular.  This is the default in `picture-mode'."
  (interactive "P")
  (rm-activate-mark force)
  (push-mark nil nil t))

;;;###autoload
(defun rm-exchange-point-and-mark (force)
  "Like `exchange-point-and-mark' but treats region as a rectangle.
See `rm-set-mark' for more details.

With optional argument FORCE, tabs are expanded and spaces are
inserted as necessary to keep the region perfectly rectangular.
This is the default in `picture-mode'."
  (interactive "P")
  (rm-activate-mark force)
  (exchange-point-and-mark))

;;;###autoload
(defun rm-kill-region (start end)
  "Like kill-rectangle except the rectangle is also saved in the kill ring.
Since rectangles are not ordinary text, the killed rectangle is saved
in the kill ring as a series of lines, one for each row of the rectangle.
The rectangle is also saved as the killed rectangle so it is available for
insertion with yank-rectangle."
  (interactive "r")
  (rm-kill-ring-save start end)
  (delete-rectangle start end)
  (and (interactive-p)
       rm-mark-active
       (rm-deactivate-mark)))

;;;###autoload
(defun rm-kill-ring-save (start end)
  "Copies the region like rm-kill-region would but the rectangle isn't killed."
  (interactive "r")
  (setq killed-rectangle (extract-rectangle start end))
  (kill-new (mapconcat (function
			(lambda (row)
			  (concat row "\n")))
		       killed-rectangle ""))
  (and (interactive-p)
       rm-mark-active
       (rm-deactivate-mark)))

;;;###autoload
(defun rm-mouse-drag-region (start-event)
  "Highlight a rectangular region of text as the the mouse is dragged over it.
This must be bound to a button-down mouse event."
  (interactive "e")
  (let* ((start-posn (event-start start-event))
	 (start-point (posn-point start-posn))
	 (start-window (posn-window start-posn))
	 (start-frame (window-frame start-window))
	 (bounds (window-edges start-window))
	 (top (nth 1 bounds))
	 (bottom (if (window-minibuffer-p start-window)
		     (nth 3 bounds)
		   ;; Don't count the mode line.
		   (1- (nth 3 bounds))))
	 (click-count (1- (event-click-count start-event))))
    (setq mouse-selection-click-count click-count)
    (mouse-set-point start-event)
    (rm-activate-mark)
    (let (end-event
	  end-posn
	  end-point
	  end-window)
      (track-mouse
	(while (progn
		 (setq end-event (read-event)
		       end-posn (event-end end-event)
		       end-point (posn-point end-posn)
		       end-window (posn-window end-posn))
		 (or (mouse-movement-p end-event)
		     (eq (car-safe end-event) 'switch-frame)))
	  (cond
	   ;; Ignore switch-frame events.
	   ((eq (car-safe end-event) 'switch-frame)
	    nil)
	   ;; Are we moving within the original window?
	   ((and (eq end-window start-window)
		 (integer-or-marker-p end-point))
	    (goto-char end-point)
	    (rm-highlight-rectangle start-point end-point))
	   ;; Are we moving on a different window on the same frame?
	   ((and (windowp end-window)
		 (eq (window-frame end-window) start-frame))
	    (let ((mouse-row (+ (nth 1 (window-edges end-window))
				(cdr (posn-col-row end-posn)))))
	      (cond
	       ((< mouse-row top)
		(mouse-scroll-subr (- mouse-row top)
				   nil start-point))
	       ((and (not (eobp))
		     (>= mouse-row bottom))
		(mouse-scroll-subr (1+ (- mouse-row bottom))
				   nil start-point)))))
	   (t
	    (let ((mouse-y (cdr (cdr (mouse-position))))
		  (menu-bar-lines (or (cdr (assq 'menu-bar-lines
						 (frame-parameters)))
				      0)))
	      ;; Are we on the menu bar?
	      (and (integerp mouse-y) (< mouse-y menu-bar-lines)
		   (mouse-scroll-subr (- mouse-y menu-bar-lines)
				      nil start-point)))))))
      (and (eq (get (event-basic-type end-event) 'event-kind) 'mouse-click)
	   (eq end-window start-window)
	   (numberp end-point)
	   (if (= start-point end-point)
	       (setq deactivate-mark t)
	     (push-mark start-point t t)
	     (goto-char end-point)
	     (rm-kill-ring-save start-point end-point)))
      )))


(defun rm-activate-mark (&optional force)
  ;; Turn on rectangular marking mode by temporarily (and in a buffer
  ;; local way) disabling transient mark mode and manually handling
  ;; highlighting from a post command hook.
  (setq rm-force (and (not buffer-read-only)
		      (or force
			  (eq major-mode 'picture-mode))))
  ;; Be careful if we are already marking a rectangle.
  (if rm-mark-active
      nil
    ;; Make each of our state variables buffer local.
    (mapcar (function make-local-variable) rm-our-local-variables)
    (setq rm-mark-active t
	  rm-overlay-list nil
	  rm-old-transient-mark-mode transient-mark-mode)
    ;; Remember which system variables weren't buffer local.
    (setq rm-old-global-variables
	  (apply (function nconc)
		 (mapcar (function
			  (lambda (variable)
			    (and (not (assoc variable
					     (buffer-local-variables)))
				 (list variable))))
			 rm-temporary-local-variables)))
    ;; Then make them all buffer local too.
    (mapcar (function make-local-variable) rm-temporary-local-variables)
    ;; Making transient-mark-mode buffer local doesn't really work
    ;; correctly as of 19.22: the current buffer's value affects all
    ;; displayed buffers.
    (setq transient-mark-mode nil)
    (add-hook 'post-command-hook 'rm-post-command)
    (add-hook 'deactivate-mark-hook 'rm-deactivate-mark)))

(defun rm-post-command ()
  ;; An error in a post-command function can be fatal if it re-occurs
  ;; on each call, thus the condition-case safety nets.
  ;; We have to do things this way because deactivate-mark doesn't
  ;; (in general) get called if transient-mark-mode isn't turned on.
  (if rm-mark-active
      (if (or (not mark-active)
	      deactivate-mark
	      (memq this-command rm-deactivate-mark-commands))
	  (condition-case nil
	      (rm-deactivate-mark)
	    (error nil))
	(condition-case info
	    (rm-highlight-rectangle (mark) (point))
	  (error
	   (ding)
	   (message "rect-mark trouble: %s" info)
	   (condition-case nil
	       (rm-deactivate-mark)
	     (error nil)))))
    (and (boundp 'rm-overlay-list)
	 (condition-case nil
	     (rm-deactivate-mark)
	   (error nil)))))

(defun rm-highlight-rectangle (start end)
  ;; This function is used to highlight the rectangular region from
  ;; START to END.  We do this by putting an overlay on each line
  ;; within the rectangle.  Each overlay extends across all the
  ;; columns of the rectangle.  We try to reuse overlays where
  ;; possible because this is more efficient and results in less
  ;; flicker.  If rm-force is nil and the buffer contains tabs or
  ;; short lines, the higlighted region may not be perfectly
  ;; rectangular.
  (save-excursion
    ;; Calculate the rectangular region represented by point and mark,
    ;; putting start in the north-west corner and end in the
    ;; south-east corner.  We can't effectively use
    ;; operate-on-rectangle because it doesn't work for zero-width
    ;; rectangles as of 19.22.
    (and (> start end)
	 (setq start (prog1
			 end
		       (setq end start))))
    (let ((start-col (save-excursion
		       (goto-char start)
		       (current-column)))
	  (end-col (save-excursion
		     (goto-char end)
		     (current-column)))
	  (deactivate-mark deactivate-mark))
      (and (> start-col end-col)
	   (setq start-col (prog1
			       end-col
			     (setq end-col start-col))
		 start (save-excursion
			 (goto-char start)
			 (move-to-column start-col rm-force)
			 (point))
		 end (save-excursion
		       (goto-char end)
		       (move-to-column end-col rm-force)
		       (point))))
      ;; Force a redisplay so we can do reliable window start/end
      ;; calculations.
      (sit-for 0)
      (let ((old rm-overlay-list)
	    (new nil)
	    overlay
	    (window-start (max (window-start) start))
	    (window-end (min (window-end) end)))
	;; Iterate over those lines of the rectangle which are visible
	;; in the currently selected window.
	(goto-char window-start)
	(while (< (point) window-end)
	  (let ((row-start (progn
			     (move-to-column start-col rm-force)
			     (point)))
		(row-end (progn
			   (move-to-column end-col rm-force)
			   (point))))
	    ;; Trim old leading overlays.
	    (while (and old
			(setq overlay (car old))
			(< (overlay-start overlay) row-start)
			(/= (overlay-end overlay) row-end))
	      (delete-overlay overlay)
	      (setq old (cdr old)))
	    ;; Reuse an overlay if possible, otherwise create one.
	    (if (and old
		     (setq overlay (car old))
		     (or (= (overlay-start overlay) row-start)
			 (= (overlay-end overlay) row-end)))
		(progn
		  (move-overlay overlay row-start row-end)
		  (setq new (cons overlay new)
			old (cdr old)))
	      (setq overlay (make-overlay row-start row-end))
	      (overlay-put overlay 'face 'region)
              ;; APB: Added the priority so that we prefer
              ;; highlighting the rectangle to highlighting
              ;; parenthesis.
              (overlay-put overlay 'priority 2000)
	      (setq new (cons overlay new)))
	    (forward-line 1)))
	;; Trim old trailing overlays.
	(mapcar (function delete-overlay) old)
	(setq rm-overlay-list (nreverse new))))))

(defun rm-deactivate-mark ()
  ;; This is used to clean up after `rm-activate-mark'.
  ;; Alas, we can no longer uninstall a post command hook from a post
  ;; command hook (as of 19.28 at least) so we must leave it installed
  ;; globally.
  ;(setq post-command-hook (delq 'rm-post-command post-command-hook))
  (setq deactivate-mark-hook (delq 'rm-deactivate-mark deactivate-mark-hook))
  (setq transient-mark-mode rm-old-transient-mark-mode)
  (mapcar (function delete-overlay) rm-overlay-list)
  (mapcar (function kill-local-variable) rm-old-global-variables)
  (mapcar (function kill-local-variable) rm-our-local-variables)
  (and transient-mark-mode
       mark-active
       (deactivate-mark)))

(provide 'rect-mark)

;;; rect-mark.el ends here