From: akr <akr>
Date: Fri, 27 Oct 2000 02:04:38 +0000 (+0000)
Subject: munsell-conv.el (munsell-split): recognize Nv/c format.
X-Git-Url: http://git.chise.org/gitweb/?a=commitdiff_plain;h=b2da2cf41d88185847e0972e378e083defea376f;p=elisp%2Fmunsell.git

munsell-conv.el (munsell-split): recognize Nv/c format.

munsell.el (munsel-resolv-property-face): new function.
(munsell-resolv-properties): ditto.
(put-text-property): adviced.
(add-text-properties): ditto.
(set-text-properties): ditto.
(overlay-put): ditto.
---

diff --git a/munsell-conv.el b/munsell-conv.el
index 29b3a08..9a051bc 100644
--- a/munsell-conv.el
+++ b/munsell-conv.el
@@ -1,5 +1,3 @@
-;; -*- coding: iso-2022-7bit; -*-
-
 (require 'munsell-data)
 
 (defun munsell-lookup (color)
@@ -12,10 +10,14 @@
 	(value-var (nth 1 vars))
 	(chroma-var (nth 2 vars)))
     `(let ((,color-var ,color-expr))
-       (if (string-match "^\\([0-9]+\\(\\.[0-9]*\\)?\\)\\(B\\|BG\\|G\\|GY\\|Y\\|YR\\|R\\|RP\\|P\\|PB\\)\\([0-9]+\\(\\.[0-9]*\\)?\\)/\\([0-9]+\\(\\.[0-9]*\\)?\\)$" ,color-var)
-	   (let ((,hue-var (cons (string-to-number (match-string 1 ,color-var)) (match-string 3 ,color-var)))
-		 (,value-var (string-to-number (match-string 4 ,color-var)))
-		 (,chroma-var (string-to-number (match-string 6 ,color-var))))
+       (if (string-match "^\\(N\\|\\([0-9]+\\(\\.[0-9]*\\)?\\)\\(B\\|BG\\|G\\|GY\\|Y\\|YR\\|R\\|RP\\|P\\|PB\\)\\)\\([0-9]+\\(\\.[0-9]*\\)?\\)/\\([0-9]+\\(\\.[0-9]*\\)?\\)$" ,color-var)
+	   (let ((,hue-var
+		  (if (match-beginning 2)
+		      (cons (string-to-number (match-string 2 ,color-var))
+			    (match-string 4 ,color-var))
+		    (cons 0 (match-string 1 ,color-var))))
+		 (,value-var (string-to-number (match-string 5 ,color-var)))
+		 (,chroma-var (string-to-number (match-string 7 ,color-var))))
 	     ,body)
 	 ,(or
 	   invalid-action
diff --git a/munsell.el b/munsell.el
index 8df9ab1..82e18b9 100644
--- 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)