From: akr <akr>
Date: Sun, 29 Oct 2000 06:21:07 +0000 (+0000)
Subject: (munsell-split): reject beginning and trailing garbage.
X-Git-Url: http://git.chise.org/gitweb/?a=commitdiff_plain;h=07234c0cd0c7c5b96fe5af9cc4ada152e3543a26;p=elisp%2Fmunsell.git

(munsell-split): reject beginning and trailing garbage.
(munsell-hue-round): new function.
(munsell-value-round): new function.
(munsell-chroma-round): new function.
(munsell-round): use `munsell-hue-round', `munsell-value-round' and
`munsell-chroma-round'.
---

diff --git a/munsell-conv.el b/munsell-conv.el
index 2e3e76e..a402d1a 100644
--- a/munsell-conv.el
+++ b/munsell-conv.el
@@ -10,40 +10,57 @@
 	(value-var (nth 1 vars))
 	(chroma-var (nth 2 vars)))
     `(let ((,color-var ,color-expr))
-       (if (string-match "^N\\([0-9]+\\(\\.[0-9]*\\)?\\)\\|\\([0-9]+\\(\\.[0-9]*\\)?\\)\\(B\\|BG\\|G\\|GY\\|Y\\|YR\\|R\\|RP\\|P\\|PB\\)\\([0-9]+\\(\\.[0-9]*\\)?\\)/\\([0-9]+\\(\\.[0-9]*\\)?\\)$" ,color-var)
+       (if (string-match "^\\(N\\([0-9]+\\(\\.[0-9]*\\)?\\)\\|\\([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 1)
+		  (if (match-beginning 2)
 		      '(0 . "N")
-		    (cons (string-to-number (match-string 3 ,color-var))
-			  (match-string 5 ,color-var))))
+		    (cons (string-to-number (match-string 4 ,color-var))
+			  (match-string 6 ,color-var))))
 		 (,value-var
 		  (string-to-number
-		   (match-string (if (match-beginning 1) 1 6) ,color-var)))
+		   (match-string (if (match-beginning 2) 2 7) ,color-var)))
 		 (,chroma-var
-		  (if (match-beginning 1)
+		  (if (match-beginning 2)
 		      0
-		    (string-to-number (match-string 8 ,color-var)))))
+		    (string-to-number (match-string 9 ,color-var)))))
 	     ,body)
 	 ,(or
 	   invalid-action
 	   `(error "invalid munsell color: %s" ,color-var))))))
 
+(defun munsell-hue-round (h &optional round-function)
+  (unless round-function (setq round-function 'round))
+  (let ((h2 (* 5 (apply round-function (car h) '(2.5)))))
+    (if (= h2 0)
+	(concat
+	 "10" 
+	 (cadr
+	  (member
+	   (cdr h) '("R" "RP" "P" "PB" "B" "BG" "G" "GY" "Y" "YR" "R"))))
+      (concat
+       (int-to-string (ash h2 -1))
+       (unless (= (logand h2 1) 0) ".5")
+       (cdr h)))))
+
+(defun munsell-value-round (v &optional round-function)
+  (unless round-function (setq round-function 'round))
+  (if (<= v 0.9)
+      (let ((rounded (apply round-function v '(0.2))))
+	(if (= rounded 5)
+	    "1"
+	  (concat "0." (int-to-string (* 2 rounded)))))
+    (int-to-string (apply round-function v '(1)))))
+
+(defun munsell-chroma-round (c &optional round-function)
+  (unless round-function (setq round-function 'round))
+  (int-to-string (* 2 (apply chroma-round c '(2)))))
+
 (defun munsell-round (h v c hue-round value-round chroma-round)
-  (let ((c-rounded (* 2 (apply chroma-round c '(2)))))
-    (concat
-     (if (= c-rounded 0)
-	 "N"
-       (let ((h2 (* 5 (apply hue-round (car h) '(2.5)))))
-	 (concat
-	  (int-to-string (ash h2 -1))
-	  (unless (= (logand h2 1) 0) ".5")
-	  (cdr h))))
-     (if (< v 0.9)
-	 (concat "0." (int-to-string (* 2 (apply value-round v '(0.2)))))
-       (int-to-string (apply value-round v '(1))))
-     (if (= c-rounded 0)
-	 ""
-       (concat "/" (int-to-string c-rounded))))))
+  (let ((c-rounded (munsell-chroma-round c chroma-round))
+	(v-rounded (munsell-value-round v value-round)))
+    (if (string= c-rounded "0")
+	(concat "N" v-rounded)
+      (concat (munsell-hue-round h hue-round) v-rounded "/" c-rounded))))
 
 (defun munsell-convert (color)
   (munsell-split color (h v c)