munsell-conv.el

   1 ;; -*- coding: iso-2022-7bit; -*-
   2
   3 (require 'munsell-data)
   4
   5 (defun munsell-lookup (color)
   6   (cdr (assoc color munsell-color-alist)))
   7
   8 (put 'munsell-split 'lisp-indent-function 2)
   9 (defmacro munsell-split (color-expr vars body &optional invalid-action)
  10   (let ((color-var (make-symbol "_color"))
  11         (hue-minor-var (nth 0 vars))
  12         (hue-major-var (nth 1 vars))
  13         (value-var (nth 2 vars))
  14         (chroma-var (nth 3 vars)))
  15     `(let ((,color-var ,color-expr))
  16        (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)
  17            (let ((,hue-minor-var (string-to-number (match-string 1 ,color-var)))
  18                  (,hue-major-var (match-string 3 ,color-var))
  19                  (,value-var (string-to-number (match-string 4 ,color-var)))
  20                  (,chroma-var (string-to-number (match-string 6 ,color-var))))
  21              ,body)
  22          ,(or
  23            invalid-action
  24            `(error "invalid munsell color: %s" ,color-var))))))
  25
  26 (defun munsell-round (h-minor h-major v c hue-round value-round chroma-round)
  27   (concat
  28    (let ((h2 (* 5 (apply hue-round h-minor '(2.5)))))
  29      (if (= (logand h2 1) 0)
  30          (int-to-string (ash h2 -1))
  31        (concat (int-to-string (ash h2 -1)) ".5")))
  32    h-major
  33    (if (< v 0.9)
  34        (concat "0." (int-to-string (* 2 (apply value-round v '(0.2)))))
  35      (int-to-string (apply value-round v '(1))))
  36    "/"
  37    (int-to-string (* 2 (apply chroma-round c '(2))))))
  38
  39 (defun munsell-convert (color)
  40   (munsell-split color (h-minor h-major v c)
  41     (munsell-lookup (munsell-round h-minor h-major v c 'round 'round 'round))))
  42
  43 (provide 'munsell-conv)