new file for kawabata's mail.

[elisp/munsell.git] / munsell.el

diff --git a/munsell.el b/munsell.el
index 8df9ab1..82e18b9 100644 (file)
--- a/munsell.el
+++ b/munsell.el
@@ -1,3 +1,4 @@
+(require 'advice)
 (require 'munsell-conv)
 (require 'munsell-names)
 
@@ -9,21 +10,60 @@
          (cdr p)
        color))))
 
-(defadvice modify-frame-parameters (before resolv-color activate)
+(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))
+               '(background-color
+                 foreground-color
+                 cursor-color
+                 mouse-color
+                 border-color))
           (cons
            (car p)
            (munsell-resolv-color (cdr p)))
         p))
-           (ad-get-arg 1))))
+    (ad-get-arg 1))))
 
-(provide 'munsell)
\ No newline at end of file
+(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)