Re: no good way to highlight rectangle while region is highlighted

[Ehud Karni]

On Sat, 21 Jul 2007 22:59:30, Joe Wells wrote:
>
> Summary of this message: This is a feature request for (1) the
> possibility that some overlays can have priority over the use of the
> region face, and/or (2) a variant of the -box- face feature where the
> vertical lines of the box take no extra space.
       [snip]
> Any suggestions?  I'd like to use either background colors, or the box
> face feature, but either of these would require changes to Emacs to
> work acceptably.


Below is my code to mark rectangles (blocks):

> Any suggestions?  I'd like to use either background colors, or the box
> face feature, but either of these would require changes to Emacs to
> work acceptably.

I think a strong background color (I use red) is much better because
it can not be missed. A frame only (box) can be overlooked, especially
when the rectangle is greater than the screen size.

Ehud.


 -------------------------- mark block code --------------------------

(defvar mark-1st nil "1st mark (ek) position,
a cons cell: (marker column-number) for all marks,
nil if not set")

(defvar mark-2nd nil "2nd mark (ek) position,
a cons cell: (marker column-number) for all marks,
nil if not set")

(defvar mark-overlay-list nil "list of mark overlays (unmark deletes them).")

(defvar mark-block-max-lines 500 "Maximum lines in block mark to face (color).
If the number of lines in the block mark is greater than this value don't make 
it visible.")

(defun visible-unmark () "Make marked area normal"
       (mapc 'delete-overlay mark-overlay-list)
       (setq mark-overlay-list nil))

(defun mark-set-face (FACE) "Set face of marked area to FACE (to mark only)"
       (visible-unmark)                    ;; clear overlay if exist
       (mark-block-check-swap)             ;; ensure upper-left, bottom-right
       (let* ((buf (set-buffer (marker-buffer (car mark-1st))))
                   (pos (point-marker))         ;; current position in buf
                   (m1 (marker-position (car mark-1st)))
                   (m2 (marker-position (car mark-2nd)))
             )
           (if (> (count-lines m1 m2) mark-block-max-lines)
                   (message "Block mark to large - not shown")
               (let ((c1 (cdr mark-1st))
                     (c2 (1+ (cdr mark-2nd))))
                   (goto-char m1)
                   (setq m2 (min m2 (1- (point-max))))
                   (while (not (< m2 (point)))
                   (setq m1 (+ (point) c1))
                   (end-of-line)
                   (setq m1 (min m1 (point)))
                   (goto-col c2 t)
                   (mark-set-face-overlay m1 (point) buf FACE)
                   (forward-line)))))
       (goto-char pos))                ;; restore position

(defun mark-set-face-overlay (BEG END BUF FACE)
  "make-overlay BEG END in BUF, set its `face' to FACE and its priority to 99.
really FACE is always `MARK'. Add to mark-overlay-list (for unmarking)."
       (let ((ov (make-overlay BEG END BUF nil t)))
           (overlay-put ov 'face FACE)
           (overlay-put ov 'priority 99)
           (setq mark-overlay-list (append (list ov) mark-overlay-list))))

(defun mark-block-check-swap ()
  "Block mark check (& swap) so mark-1st is set to upper left corner,
        mark-2nd to right bottom corner."
       (let ((tmp 0)
             (p1 (car mark-1st))
             (p2 (car mark-2nd))
             (c1 (cdr mark-1st))
             (c2 (cdr mark-2nd)))
           (if (> (marker-position p1) (marker-position p2))
               (progn
                   (setq tmp p1)
                   (setq p1 p2)
                   (setq p2 tmp)))
           (if (> c1 c2)
               (progn
                   (setq tmp c1)
                   (setq c1 c2)
                   (setq c2 tmp)))
           (setq mark-1st (cons p1 c1))
           (setq mark-2nd (cons p2 c2))))

(defun goto-col (arg &optional nospc)
  "goto ARG (column number) on current line, add spaces if needed
optional NOSPC means don't add spaces at end of line"
  (interactive "NGoto Column: ")
       (end-of-line)
       (let ((col-goto (- arg (column-no))))
           (if nospc ()
               (while (> col-goto 0)
                   (insert-char ?\040 1)
                   (setq col-goto (- col-goto 1))))
           (if (< col-goto 0)
               (goto-char (+ (point) col-goto)))))

(defun column-no (&optional arg)
 "returns column number of point or arg (char number if given)"
 (interactive "p")
       (save-excursion
           (if arg
               (goto-char arg))
           (let ((inhibit-field-text-motion))
               (1+  (- (point) (line-beginning-position))))))


--
 Ehud Karni           Tel: +972-3-7966-561  /"\
 Mivtach - Simon      Fax: +972-3-7966-667  \ /  ASCII Ribbon Campaign
 Insurance agencies   (USA) voice mail and   X   Against   HTML   Mail
 http://www.mvs.co.il  FAX:  1-815-5509341  / \
 GnuPG: 98EA398D <http://www.keyserver.net/>    Better Safe Than Sorry