(require 'advice)
(require 'munsell-conv)
(require 'munsell-names)

(defun munsell-resolv-color (color)
  (munsell-split color (h v c)
    (munsell-lookup (munsell-round h v c 'round 'round 'round))
    (let ((p (assoc color munsell-named-color-alist)))
      (if p
	  (cdr p)
	color))))

(defadvice modify-frame-parameters (before munsell-resolv-color activate)
  (ad-set-arg
   1
   (mapcar
    (lambda (p)
      (if (memq (car p)
		'(background-color
		  foreground-color
		  cursor-color
		  mouse-color
		  border-color))
          (cons
           (car p)
           (munsell-resolv-color (cdr p)))
        p))
    (ad-get-arg 1))))

(defadvice set-face-attribute-internal (before munsell-resolv-color activate)
  (when (memq (ad-get-arg 1) '(foreground background))
    (ad-set-arg 2 (munsell-resolv-color (ad-get-arg 2)))))

(defun munsel-resolv-property-face (prop)
  (if (and (consp prop) (not (stringp (cdr prop))))
      (mapcar
       (lambda (p)
	 (if (memq (car p) '(foreground-color background-color))
	     (cons (car p) (munsell-resolv-color (cdr p)))
	   p))
       prop)
    (if (memq (car prop) '(foreground-color background-color))
	(cons (car prop) (munsell-resolv-color (cdr prop)))
      prop)))

(defadvice put-text-property (before munsell-resolv-color activate)
  (when (eq (ad-get-arg 2) 'face)
    (ad-set-arg 3 (munsel-resolv-property-face (ad-get-arg 3)))))

(defun munsell-resolv-properties (props)
  (setq props (copy-sequence props))
  (let ((p props))
    (while p
      (when (eq (car p) 'face)
	(setcar (cdr p) (munsel-resolv-property-face (cadr p))))
      (setq p (cddr p))))
  props)

(defadvice add-text-properties (before munsell-resolv-color activate)
  (ad-set-arg 2 (munsell-resolv-properties (ad-get-arg 2))))

(defadvice set-text-properties (before munsell-resolv-color activate)
  (ad-set-arg 2 (munsell-resolv-properties (ad-get-arg 2))))

(defadvice overlay-put (before munsell-resolv-color activate)
  (when (eq (ad-get-arg 1) 'face)
    (ad-set-arg 2 (munsel-resolv-property-face (ad-get-arg 2)))))

(provide 'munsell)