munsell-conv.el

   1 (require 'munsell-data)
   2
   3 (defun munsell-lookup (color)
   4   (cdr (assoc color munsell-color-alist)))
   5
   6 (put 'munsell-split 'lisp-indent-function 2)
   7 (defmacro munsell-split (color-expr vars body &optional invalid-action)
   8   (let ((color-var (make-symbol "_color"))
   9         (hue-var (nth 0 vars))
  10         (value-var (nth 1 vars))
  11         (chroma-var (nth 2 vars)))
  12     `(let ((,color-var ,color-expr))
  13        (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)
  14            (let ((,hue-var
  15                   (if (match-beginning 2)
  16                       '(0 . "N")
  17                     (cons (string-to-number (match-string 4 ,color-var))
  18                           (match-string 6 ,color-var))))
  19                  (,value-var
  20                   (string-to-number
  21                    (match-string (if (match-beginning 2) 2 7) ,color-var)))
  22                  (,chroma-var
  23                   (if (match-beginning 2)
  24                       0
  25                     (string-to-number (match-string 9 ,color-var)))))
  26              ,body)
  27          ,(or
  28            invalid-action
  29            `(error "invalid munsell color: %s" ,color-var))))))
  30
  31 (defun munsell-hue-round (h &optional round-function)
  32   (unless round-function (setq round-function 'round))
  33   (let ((h2 (* 5 (apply round-function (car h) '(2.5)))))
  34     (if (= h2 0)
  35         (concat
  36          "10"
  37          (cadr
  38           (member
  39            (cdr h) '("R" "RP" "P" "PB" "B" "BG" "G" "GY" "Y" "YR" "R"))))
  40       (concat
  41        (int-to-string (ash h2 -1))
  42        (unless (= (logand h2 1) 0) ".5")
  43        (cdr h)))))
  44
  45 (defun munsell-value-round (v &optional round-function)
  46   (unless round-function (setq round-function 'round))
  47   (if (<= v 0.9)
  48       (let ((rounded (apply round-function v '(0.2))))
  49         (if (= rounded 5)
  50             "1"
  51           (concat "0." (int-to-string (* 2 rounded)))))
  52     (int-to-string (apply round-function v '(1)))))
  53
  54 (defun munsell-chroma-round (c &optional round-function)
  55   (unless round-function (setq round-function 'round))
  56   (int-to-string (* 2 (apply chroma-round c '(2)))))
  57
  58 (defun munsell-round (h v c hue-round value-round chroma-round)
  59   (let ((c-rounded (munsell-chroma-round c chroma-round))
  60         (v-rounded (munsell-value-round v value-round)))
  61     (if (string= c-rounded "0")
  62         (concat "N" v-rounded)
  63       (concat (munsell-hue-round h hue-round) v-rounded "/" c-rounded))))
  64
  65 (defun munsell-convert (color)
  66   (munsell-split color (h v c)
  67     (munsell-lookup (munsell-round h v c 'round 'round 'round))))
  68
  69 (provide 'munsell-conv)