munsell.el

   1 (require 'advice)
   2 (require 'munsell-conv)
   3 (require 'munsell-names)
   4
   5 (defun munsell-resolv-color (color)
   6   (munsell-split color (h v c)
   7     (munsell-lookup (munsell-round h v c 'round 'round 'round))
   8     (let ((p (assoc color munsell-named-color-alist)))
   9       (if p
  10           (cdr p)
  11         color))))
  12
  13 (defadvice modify-frame-parameters (before munsell-resolv-color activate)
  14   (ad-set-arg
  15    1
  16    (mapcar
  17     (lambda (p)
  18       (if (memq (car p)
  19                 '(background-color
  20                   foreground-color
  21                   cursor-color
  22                   mouse-color
  23                   border-color))
  24           (cons
  25            (car p)
  26            (munsell-resolv-color (cdr p)))
  27         p))
  28     (ad-get-arg 1))))
  29
  30 (defadvice set-face-attribute-internal (before munsell-resolv-color activate)
  31   (when (memq (ad-get-arg 1) '(foreground background))
  32     (ad-set-arg 2 (munsell-resolv-color (ad-get-arg 2)))))
  33
  34 (defun munsel-resolv-property-face (prop)
  35   (if (and (consp prop) (not (stringp (cdr prop))))
  36       (mapcar
  37        (lambda (p)
  38          (if (memq (car p) '(foreground-color background-color))
  39              (cons (car p) (munsell-resolv-color (cdr p)))
  40            p))
  41        prop)
  42     (if (memq (car prop) '(foreground-color background-color))
  43         (cons (car prop) (munsell-resolv-color (cdr prop)))
  44       prop)))
  45
  46 (defadvice put-text-property (before munsell-resolv-color activate)
  47   (when (eq (ad-get-arg 2) 'face)
  48     (ad-set-arg 3 (munsel-resolv-property-face (ad-get-arg 3)))))
  49
  50 (defun munsell-resolv-properties (props)
  51   (setq props (copy-sequence props))
  52   (let ((p props))
  53     (while p
  54       (when (eq (car p) 'face)
  55         (setcar (cdr p) (munsel-resolv-property-face (cadr p))))
  56       (setq p (cddr p))))
  57   props)
  58
  59 (defadvice add-text-properties (before munsell-resolv-color activate)
  60   (ad-set-arg 2 (munsell-resolv-properties (ad-get-arg 2))))
  61
  62 (defadvice set-text-properties (before munsell-resolv-color activate)
  63   (ad-set-arg 2 (munsell-resolv-properties (ad-get-arg 2))))
  64
  65 (defadvice overlay-put (before munsell-resolv-color activate)
  66   (when (eq (ad-get-arg 1) 'face)
  67     (ad-set-arg 2 (munsel-resolv-property-face (ad-get-arg 2)))))
  68
  69 (provide 'munsell)