;; $Id: mell-sign.el,v 1.1.1.1 2003/06/01 03:04:44 komatsu Exp $
;; Mell - Mell Emacs Lisp Library -
;;
;; AUTHOR:  Hiroyuki KOMATSU <komatsu@taiyaki.org>
;; LICENSE: GPL2
;;

(require 'mell)
(require 'overlay nil t)

;; ------------------------------------------------------------
;; mell-sign
;; ------------------------------------------------------------

(defvar mell-sign-marker-overlay-alist (list nil))
(defun mell-sign-marker (marker &optional face)
  (let ((overlay (cdr (assoc marker mell-sign-marker-overlay-alist)))
	(start (min marker (1- (point-max)))) ;; for EOB
	(end (min (1+ marker) (point-max))))
    (if overlay
	(move-overlay overlay start end (marker-buffer marker))
      (setq overlay (make-overlay start end (marker-buffer marker)))
      (mell-alist-add! mell-sign-marker-overlay-alist (cons marker overlay))
      )
    (overlay-put overlay 'face (or face 'highlight))
    (overlay-put overlay 'evaporate t)
    (add-local-hook 'post-command-hook 'mell-sign-marker-redisplay)
    ))

(defun mell-sign-marker-off (marker)
  (let ((overlay (cdr (assoc marker mell-sign-marker-overlay-alist))))
    (if overlay
	(delete-overlay overlay))
    (setq mell-sign-marker-overlay-alist
	  (mell-alist-delete mell-sign-marker-overlay-alist marker))
    (remove-local-hook 'post-command-hook 'mell-sign-marker-redisplay)
    ))

(defun mell-sign-marker-redisplay ()
  (mapcar 
   '(lambda (cons) (mell-sign-marker (car cons)))
   mell-sign-marker-overlay-alist))

(defvar mell-sign-region-overlay-alist (list nil))
(defun mell-sign-region (start end &optional buffer face)
  (or buffer (setq buffer (current-buffer)))
  (let* ((region (list start end buffer))
	 (overlay (cdr (assoc region mell-sign-region-overlay-alist))))
    (if overlay
	(move-overlay overlay start end buffer)
      (setq overlay (make-overlay start end buffer nil t))
      (mell-alist-add! mell-sign-region-overlay-alist (cons region overlay))
      )
    (overlay-put overlay 'face (or face 'highlight))
    (overlay-put overlay 'evaporate t)
    ))

(defun mell-sign-region-off (start end &optional buffer)
  (or buffer (setq buffer (current-buffer)))
  (let* ((region (list start end buffer))
	 (overlay (cdr (assoc region mell-sign-region-overlay-alist))))
    (if overlay
	(delete-overlay overlay))
    (setq mell-sign-region-overlay-alist
	  (mell-alist-delete mell-sign-region-overlay-alist region))
    ))

(defun mell-sign-region-highlight (start end &optional buffer face)
  (save-excursion
    (or buffer (setq buffer (current-buffer)))
    (prog1
	(setq overlay (make-overlay start end buffer nil t))
      (overlay-put overlay 'face (or face 'highlight))
      (overlay-put overlay 'evaporate t)
      )))

(defun mell-sign-region-highlight-off (overlay)
  (delete-overlay overlay)
  )



(defvar mell-sign-rectangle-overlay-alist (list nil))
(defun mell-sign-rectangle (start end &optional buffer face)
  (mell-sign-rectangle-off start end buffer)
  (mell-alist-add! 
   mell-sign-rectangle-overlay-alist
   (cons (list start end buffer)
	 (mell-sign-rectangle-highlight start end buffer face))
   )
  )
  
(defun mell-sign-rectangle-off (start end &optional buffer)
  (or buffer (setq buffer (current-buffer)))
  (let* ((rectangle (list start end buffer))
	 (overlay-list
	  (cdr (assoc rectangle mell-sign-rectangle-overlay-alist))))
    (and overlay-list
	 (mell-sign-rectangle-highlight-off overlay-list))
    (setq mell-sign-rectangle-overlay-alist
	  (mell-alist-delete mell-sign-rectangle-overlay-alist rectangle))
    ))


(defun mell-sign-rectangle-highlight (start end &optional buffer face)
  (save-excursion
    (or buffer (setq buffer (current-buffer)))
    (mapcar
     '(lambda (region)
	(prog1
	    (setq overlay
		  (make-overlay (car region) (cdr region) buffer nil t))
	  (overlay-put overlay 'face (or face 'highlight))
	  (overlay-put overlay 'evaporate t)
	  ))
     (mell-region-get-rectangle-list start end))
    ))

(defun mell-sign-rectangle-highlight-off (overlay-list)
  (mapcar
   '(lambda (overlay)
      (delete-overlay overlay))
   overlay-list)
  )
  
(defun mell-sign-rectangle-redisplay ()
  (mapcar 
   '(lambda (cons) (mell-sign-rectangle (car cons)))
   mell-sign-rectangle-overlay-alist))


(defun mell-sign-reset-face (face)
  (if running-xemacs
      (reset-face face)
    (set-face-font face nil)
    (set-face-foreground face nil)
    (set-face-background face nil)
    (set-face-background-pixmap face nil)
    (set-face-underline face nil)
    (set-face-stipple face nil)
    ))

(provide 'mell-sign)

