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

;;; Copyright (C) 1994 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.

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

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

;;; Usage:

;; ;; 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 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-mouse-drag-region "rect-mark"
;;   "Drag out a rectangular region with the mouse." t)

;; ;; One vision of a better picture mode.
;; (add-hook 'picture-mode-hook 'rm-picture-mode-bindings)
;; (defun rm-picture-mode-bindings ()
;;   (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-w" 'kill-rectangle)
;;   (define-key picture-mode-map "\M-w" 'copy-rectangle)
;;   (define-key picture-mode-map "\C-y" 'yank-rectangle)
;;   (define-key picture-mode-map "\C-x\C-x" 'rm-exchange-point-and-mark)
;;   (defun move-to-column-force (column)
;;     (let ((deactivate-mark deactivate-mark))
;;       (move-to-column (max column 0) t)
;;       (hscroll-point-visible)))
;;   (defun copy-rectangle (start end)
;;     "Copy rectangle for use as last killed rectangle."
;;     (interactive "r")
;;     (setq killed-rectangle (extract-rectangle start end))))

;; ;; You will need a version of remove-hook if it is missing from
;; ;; your version of Emacs.
;; (defun remove-hook (hook function)
;;   "Remove from the value of HOOK the function FUNCTION.
;; HOOK should be a symbol, and FUNCTION may be any valid function.  If
;; FUNCTION isn't the value of HOOK, or, if FUNCTION doesn't appear in the
;; list of hooks to run in HOOK, then nothing is done.  See `add-hook'."
;;   (if (or (not (boundp hook))		;unbound symbol, or
;; 	  (null (symbol-value hook))	;value is nil, or
;; 	  (null function))		;function is nil, then
;;       nil				;Do nothing.
;;     (let ((hook-value (symbol-value hook)))
;;       (if (consp hook-value)
;; 	  (setq hook-value (delete function hook-value))
;; 	(if (eq hook-value function)
;; 	    (setq hook-value nil)))
;;       (set hook hook-value))))

;;; 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 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
    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-buggy-deactivate-mark-commands
  '(clear-rectangle
    copy-rectangle-to-register
    kill-rectangle
    open-rectangle
    string-rectangle
    yank-rectangle))

;;;###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-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)
	     (setq killed-rectangle
		   (extract-rectangle start-point end-point))
	     (kill-new (mapconcat (function
				   (lambda (row)
				     (concat row "\n")))
				  killed-rectangle "")))))))

(defun rm-activate-mark (&optional force)
  (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)))

;; An error in a post-command function can be fatal if it re-occurs
;; on each call, thus the condition-case safety nets.
(defun rm-post-command ()
  ;; 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 (or (not mark-active)
	  deactivate-mark
	  (memq this-command rm-buggy-deactivate-mark-commands))
      (condition-case nil
	  (rm-deactivate-mark)
	(error
	 ;; Desperation time.
	 (setq post-command-hook nil)))
    (condition-case info
	(rm-highlight-rectangle (mark) (point))
      (error
       (ding)
       (message "rect-mark trouble: %s" info)
       (condition-case nil
	   (rm-deactivate-mark)
	 (error
	  ;; Desperation time.
	  (setq post-command-hook nil)))))))

;; 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.
(defun rm-highlight-rectangle (start end)
  (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))))
      (let ((old rm-overlay-list)
	    (new nil)
	    overlay)
	;; Iterate over each line within the rectangle.
	(goto-char start)
	(while (< (point) end)
	  (let ((start (point))
		(end (progn
		       (move-to-column end-col rm-force)
		       (point))))
	    ;; Trim old leading overlays.
	    (while (and old
			(setq overlay (car old))
			(< (overlay-start overlay) start)
			(/= (overlay-end overlay) 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) start)
			 (= (overlay-end overlay) end)))
		(progn
		  (move-overlay overlay start end)
		  (setq new (cons overlay new)
			old (cdr old)))
	      (setq overlay (make-overlay start end))
	      (overlay-put overlay 'face 'region)
	      (setq new (cons overlay new)))
	    (forward-line 1)
	    (or (eobp)
		(move-to-column start-col rm-force))))
	;; Trim old trailing overlays.
	(mapcar (function delete-overlay) old)
	(setq rm-overlay-list (nreverse new))))))

;; This is used to clean up after `rm-activate-mark'.
(defun rm-deactivate-mark ()
  (remove-hook 'post-command-hook 'rm-post-command)
  (remove-hook 'deactivate-mark-hook 'rm-deactivate-mark)
  (setq transient-mark-mode rm-old-transient-mark-mode)
  (mapcar (function delete-overlay) rm-overlay-list)
  (mapcar (function kill-local-variable) rm-our-local-variables)
  (mapcar (function kill-local-variable) rm-old-global-variables)
  (and transient-mark-mode
       mark-active
       (deactivate-mark)))

;;; rect-mark.el ends here


