[bpt/emacs.git] / lisp / color.el

;;; color.el --- Color manipulation library -*- coding: utf-8; -*-

;; Copyright (C) 2010-2012 Free Software Foundation, Inc.

;; Authors: Julien Danjou <julien@danjou.info>
;;          Drew Adams <drew.adams@oracle.com>
;; Keywords: lisp, faces, color, hex, rgb, hsv, hsl, cie-lab, background

;; This file is part of GNU Emacs.

;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;; This package provides functions for manipulating colors, including
;; converting between color representations, computing color
;; complements, and computing CIEDE2000 color distances.
;;
;; Supported color representations include RGB (red, green, blue), HSV
;; (hue, saturation, value), HSL (hue, saturation, luminance), sRGB,
;; CIE XYZ, and CIE L*a*b* color components.

;;; Code:

(eval-when-compile
  (require 'cl))

;; Emacs < 23.3
(eval-and-compile
  (unless (boundp 'float-pi)
    (defconst float-pi (* 4 (atan 1)) "The value of Pi (3.1415926...).")))

;;;###autoload
(defun color-name-to-rgb (color &optional frame)
  "Convert COLOR string to a list of normalized RGB components.
COLOR should be a color name (e.g. \"white\") or an RGB triplet
string (e.g. \"#ff12ec\").

Normally the return value is a list of three floating-point
numbers, (RED GREEN BLUE), each between 0.0 and 1.0 inclusive.

Optional arg FRAME specifies the frame where the color is to be
displayed.  If FRAME is omitted or nil, use the selected frame.
If FRAME cannot display COLOR, return nil."
  (mapcar (lambda (x) (/ x 65535.0)) (color-values color frame)))

(defun color-rgb-to-hex  (red green blue)
  "Return hexadecimal notation for the color RED GREEN BLUE.
RED GREEN BLUE must be numbers between 0.0 and 1.0 inclusive."
  (format "#%02x%02x%02x"
          (* red 255) (* green 255) (* blue 255)))

(defun color-complement (color-name)
  "Return the color that is the complement of COLOR-NAME.
COLOR-NAME should be a string naming a color (e.g. \"white\"), or
a string specifying a color's RGB components (e.g. \"#ff12ec\")."
  (let ((color (color-name-to-rgb color-name)))
    (list (- 1.0 (car color))
          (- 1.0 (cadr color))
          (- 1.0 (caddr color)))))

(defun color-gradient (start stop step-number)
  "Return a list with STEP-NUMBER colors from START to STOP.
The color list builds a color gradient starting at color START to
color STOP. It does not include the START and STOP color in the
resulting list."
  (let* ((r (nth 0 start))
	 (g (nth 1 start))
	 (b (nth 2 start))
	 (r-step (/ (- (nth 0 stop) r) (1+ step-number)))
	 (g-step (/ (- (nth 1 stop) g) (1+ step-number)))
	 (b-step (/ (- (nth 2 stop) b) (1+ step-number)))
	 result)
    (dotimes (n step-number)
      (push (list (setq r (+ r r-step))
		  (setq g (+ g g-step))
		  (setq b (+ b b-step)))
	    result))
    (nreverse result)))

(defun color-complement-hex (color)
  "Return the color that is the complement of COLOR, in hexadecimal format."
  (apply 'color-rgb-to-hex (color-complement color)))

(defun color-rgb-to-hsv (red green blue)
  "Convert RED, GREEN, and BLUE color components to HSV.
RED, GREEN, and BLUE should each be numbers between 0.0 and 1.0,
inclusive.  Return a list (HUE, SATURATION, VALUE), where HUE is
in radians and both SATURATION and VALUE are between 0.0 and 1.0,
inclusive."
  (let* ((r (float red))
	 (g (float green))
	 (b (float blue))
	 (max (max r g b))
	 (min (min r g b)))
    (if (< (- max min) 1e-8)
	(list 0.0 0.0 0.0)
      (list
       (/ (* 2 float-pi
	     (cond ((and (= r g) (= g b)) 0)
		   ((and (= r max)
			 (>= g b))
		    (* 60 (/ (- g b) (- max min))))
		   ((and (= r max)
			 (< g b))
		    (+ 360 (* 60 (/ (- g b) (- max min)))))
		   ((= max g)
		    (+ 120 (* 60 (/ (- b r) (- max min)))))
		   ((= max b)
		    (+ 240 (* 60 (/ (- r g) (- max min)))))))
	  360)
       (if (= max 0) 0 (- 1 (/ min max)))
       (/ max 255.0)))))

(defun color-rgb-to-hsl (red green blue)
  "Convert RED GREEN BLUE colors to their HSL representation.
RED, GREEN, and BLUE should each be numbers between 0.0 and 1.0,
inclusive.

Return a list (HUE, SATURATION, LUMINANCE), where HUE is in radians
and both SATURATION and LUMINANCE are between 0.0 and 1.0,
inclusive."
  (let* ((r red)
         (g green)
         (b blue)
         (max (max r g b))
         (min (min r g b))
         (delta (- max min))
         (l (/ (+ max min) 2.0)))
    (list
     (if (< (- max min) 1e-8)
         0
       (* 2 float-pi
          (/ (cond ((= max r)
                    (+ (/ (- g b) delta) (if (< g b) 6 0)))
                   ((= max g)
		    (+ (/ (- b r) delta) 2))
                   (t
                    (+ (/ (- r g) delta) 4)))
             6)))
     (if (= max min)
         0
       (if (> l 0.5)
           (/ delta (- 2 (+ max min)))
         (/ delta (+ max min))))
     l)))

(defun color-srgb-to-xyz (red green blue)
  "Convert RED GREEN BLUE colors from the sRGB color space to CIE XYZ.
RED, BLUE and GREEN must be between 0 and 1, inclusive."
  (let ((r (if (<= red 0.04045)
               (/ red 12.95)
             (expt (/ (+ red 0.055) 1.055) 2.4)))
        (g (if (<= green 0.04045)
               (/ green 12.95)
             (expt (/ (+ green 0.055) 1.055) 2.4)))
        (b (if (<= blue 0.04045)
               (/ blue 12.95)
             (expt (/ (+ blue 0.055) 1.055) 2.4))))
    (list (+ (* 0.4124564 r) (* 0.3575761 g) (* 0.1804375 b))
          (+ (* 0.21266729 r) (* 0.7151522 g) (* 0.0721750 b))
          (+ (* 0.0193339 r) (* 0.1191920 g) (* 0.9503041 b)))))

(defun color-xyz-to-srgb (X Y Z)
  "Convert CIE X Y Z colors to sRGB color space."
  (let ((r (+ (* 3.2404542 X) (* -1.5371385 Y) (* -0.4985314 Z)))
        (g (+ (* -0.9692660 X) (* 1.8760108 Y) (* 0.0415560 Z)))
        (b (+ (* 0.0556434 X) (* -0.2040259 Y) (* 1.0572252 Z))))
    (list (if (<= r 0.0031308)
              (* 12.92 r)
            (- (* 1.055 (expt r (/ 1 2.4))) 0.055))
          (if (<= g 0.0031308)
              (* 12.92 g)
            (- (* 1.055 (expt g (/ 1 2.4))) 0.055))
          (if (<= b 0.0031308)
              (* 12.92 b)
            (- (* 1.055 (expt b (/ 1 2.4))) 0.055)))))

(defconst color-d65-xyz '(0.950455 1.0 1.088753)
  "D65 white point in CIE XYZ.")

(defconst color-cie-ε (/ 216 24389.0))
(defconst color-cie-κ (/ 24389 27.0))

(defun color-xyz-to-lab (X Y Z &optional white-point)
  "Convert CIE XYZ to CIE L*a*b*.
WHITE-POINT specifies the (X Y Z) white point for the
conversion. If omitted or nil, use `color-d65-xyz'."
  (destructuring-bind (Xr Yr Zr) (or white-point color-d65-xyz)
      (let* ((xr (/ X Xr))
             (yr (/ Y Yr))
             (zr (/ Z Zr))
             (fx (if (> xr color-cie-ε)
                     (expt xr (/ 1 3.0))
                   (/ (+ (* color-cie-κ xr) 16) 116.0)))
             (fy (if (> yr color-cie-ε)
                     (expt yr (/ 1 3.0))
                   (/ (+ (* color-cie-κ yr) 16) 116.0)))
             (fz (if (> zr color-cie-ε)
                     (expt zr (/ 1 3.0))
                   (/ (+ (* color-cie-κ zr) 16) 116.0))))
        (list
         (- (* 116 fy) 16)                  ; L
         (* 500 (- fx fy))                  ; a
         (* 200 (- fy fz))))))              ; b

(defun color-lab-to-xyz (L a b &optional white-point)
  "Convert CIE L*a*b* to CIE XYZ.
WHITE-POINT specifies the (X Y Z) white point for the
conversion. If omitted or nil, use `color-d65-xyz'."
  (destructuring-bind (Xr Yr Zr) (or white-point color-d65-xyz)
      (let* ((fy (/ (+ L 16) 116.0))
             (fz (- fy (/ b 200.0)))
             (fx (+ (/ a 500.0) fy))
             (xr (if (> (expt fx 3.0) color-cie-ε)
                     (expt fx 3.0)
               (/ (- (* fx 116) 16) color-cie-κ)))
             (yr (if (> L (* color-cie-κ color-cie-ε))
                     (expt (/ (+ L 16) 116.0) 3.0)
                   (/ L color-cie-κ)))
             (zr (if (> (expt fz 3) color-cie-ε)
                     (expt fz 3.0)
                   (/ (- (* 116 fz) 16) color-cie-κ))))
        (list (* xr Xr)                 ; X
              (* yr Yr)                 ; Y
              (* zr Zr)))))             ; Z

(defun color-srgb-to-lab (red green blue)
  "Convert RGB to CIE L*a*b*."
  (apply 'color-xyz-to-lab (color-srgb-to-xyz red green blue)))

(defun color-lab-to-srgb (L a b)
  "Convert CIE L*a*b* to RGB."
  (apply 'color-xyz-to-srgb (color-lab-to-xyz L a b)))

(defun color-cie-de2000 (color1 color2 &optional kL kC kH)
  "Return the CIEDE2000 color distance between COLOR1 and COLOR2.
Both COLOR1 and COLOR2 should be in CIE L*a*b* format, as
returned by `color-srgb-to-lab' or `color-xyz-to-lab'."
  (destructuring-bind (L₁ a₁ b₁) color1
    (destructuring-bind (L₂ a₂ b₂) color2
      (let* ((kL (or kL 1))
             (kC (or kC 1))
             (kH (or kH 1))
             (C₁ (sqrt (+ (expt a₁ 2.0) (expt b₁ 2.0))))
             (C₂ (sqrt (+ (expt a₂ 2.0) (expt b₂ 2.0))))
             (C̄ (/ (+ C₁ C₂) 2.0))
             (G (* 0.5 (- 1 (sqrt (/ (expt C̄ 7.0) (+ (expt C̄ 7.0) (expt 25 7.0)))))))
             (a′₁ (* (+ 1 G) a₁))
             (a′₂ (* (+ 1 G) a₂))
             (C′₁ (sqrt (+ (expt a′₁ 2.0) (expt b₁ 2.0))))
             (C′₂ (sqrt (+ (expt a′₂ 2.0) (expt b₂ 2.0))))
             (h′₁ (if (and (= b₁ 0) (= a′₁ 0))
                      0
                    (let ((v (atan b₁ a′₁)))
                      (if (< v 0)
                          (+ v (* 2 float-pi))
                        v))))
             (h′₂ (if (and (= b₂ 0) (= a′₂ 0))
                      0
                    (let ((v (atan b₂ a′₂)))
                      (if (< v 0)
                          (+ v (* 2 float-pi))
                        v))))
             (ΔL′ (- L₂ L₁))
             (ΔC′ (- C′₂ C′₁))
             (Δh′ (cond ((= (* C′₁ C′₂) 0)
                         0)
                        ((<= (abs (- h′₂ h′₁)) float-pi)
                         (- h′₂ h′₁))
                        ((> (- h′₂ h′₁) float-pi)
                         (- (- h′₂ h′₁) (* 2 float-pi)))
                        ((< (- h′₂ h′₁) (- float-pi))
                         (+ (- h′₂ h′₁) (* 2 float-pi)))))
             (ΔH′ (* 2 (sqrt (* C′₁ C′₂)) (sin (/ Δh′ 2.0))))
             (L̄′ (/ (+ L₁ L₂) 2.0))
             (C̄′ (/ (+ C′₁ C′₂) 2.0))
             (h̄′ (cond ((= (* C′₁ C′₂) 0)
                        (+ h′₁ h′₂))
                       ((<= (abs (- h′₁ h′₂)) float-pi)
                        (/ (+ h′₁ h′₂) 2.0))
                       ((< (+ h′₁ h′₂) (* 2 float-pi))
                        (/ (+ h′₁ h′₂ (* 2 float-pi)) 2.0))
                       ((>= (+ h′₁ h′₂) (* 2 float-pi))
                        (/ (+ h′₁ h′₂ (* -2 float-pi)) 2.0))))
             (T (+ 1
                   (- (* 0.17 (cos (- h̄′ (degrees-to-radians 30)))))
                   (* 0.24 (cos (* h̄′ 2)))
                   (* 0.32 (cos (+ (* h̄′ 3) (degrees-to-radians 6))))
                   (- (* 0.20 (cos (- (* h̄′ 4) (degrees-to-radians 63)))))))
             (Δθ (* (degrees-to-radians 30) (exp (- (expt (/ (- h̄′ (degrees-to-radians 275)) (degrees-to-radians 25)) 2.0)))))
             (Rc (* 2 (sqrt (/ (expt C̄′ 7.0) (+ (expt C̄′ 7.0) (expt 25.0 7.0))))))
             (Sl (+ 1 (/ (* 0.015 (expt (- L̄′ 50) 2.0)) (sqrt (+ 20 (expt (- L̄′ 50) 2.0))))))
             (Sc (+ 1 (* C̄′ 0.045)))
             (Sh (+ 1 (* 0.015 C̄′ T)))
             (Rt (- (* (sin (* Δθ 2)) Rc))))
        (sqrt (+ (expt (/ ΔL′ (* Sl kL)) 2.0)
                 (expt (/ ΔC′ (* Sc kC)) 2.0)
                 (expt (/ ΔH′ (* Sh kH)) 2.0)
                 (* Rt (/ ΔC′ (* Sc kC)) (/ ΔH′ (* Sh kH)))))))))

(provide 'color)

;;; color.el ends here
Commit	Line	Data
6d713256	1	;;; color.el --- Color manipulation library -- coding: utf-8; --
ef6a2907	2
acaf905b	3	;; Copyright (C) 2010-2012 Free Software Foundation, Inc.
ef6a2907	4
6d713256 CY	5	;; Authors: Julien Danjou <julien@danjou.info>
	6	;; Drew Adams <drew.adams@oracle.com>
	7	;; Keywords: lisp, faces, color, hex, rgb, hsv, hsl, cie-lab, background
ef6a2907 JD	8
	9	;; This file is part of GNU Emacs.
	10
	11	;; GNU Emacs is free software: you can redistribute it and/or modify
	12	;; it under the terms of the GNU General Public License as published by
	13	;; the Free Software Foundation, either version 3 of the License, or
	14	;; (at your option) any later version.
	15
	16	;; GNU Emacs is distributed in the hope that it will be useful,
	17	;; but WITHOUT ANY WARRANTY; without even the implied warranty of
	18	;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	19	;; GNU General Public License for more details.
	20
	21	;; You should have received a copy of the GNU General Public License
	22	;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
	23
	24	;;; Commentary:
	25
6d713256 CY	26	;; This package provides functions for manipulating colors, including
	27	;; converting between color representations, computing color
	28	;; complements, and computing CIEDE2000 color distances.
	29	;;
	30	;; Supported color representations include RGB (red, green, blue), HSV
53964682	31	;; (hue, saturation, value), HSL (hue, saturation, luminance), sRGB,
6d713256	32	;; CIE XYZ, and CIE Lab* color components.
ef6a2907 JD	33
	34	;;; Code:
	35
5b42dfdd JD	36	(eval-when-compile
	37	(require 'cl))
	38
094ae2ab	39	;; Emacs < 23.3
463bcf11 KY	40	(eval-and-compile
	41	(unless (boundp 'float-pi)
	42	(defconst float-pi (* 4 (atan 1)) "The value of Pi (3.1415926...).")))
094ae2ab	43
6d713256 CY	44	;;;###autoload
	45	(defun color-name-to-rgb (color &optional frame)
	46	"Convert COLOR string to a list of normalized RGB components.
	47	COLOR should be a color name (e.g. \"white\") or an RGB triplet
	48	string (e.g. \"#ff12ec\").
	49
	50	Normally the return value is a list of three floating-point
	51	numbers, (RED GREEN BLUE), each between 0.0 and 1.0 inclusive.
	52
	53	Optional arg FRAME specifies the frame where the color is to be
	54	displayed. If FRAME is omitted or nil, use the selected frame.
	55	If FRAME cannot display COLOR, return nil."
	56	(mapcar (lambda (x) (/ x 65535.0)) (color-values color frame)))
	57
	58	(defun color-rgb-to-hex (red green blue)
	59	"Return hexadecimal notation for the color RED GREEN BLUE.
	60	RED GREEN BLUE must be numbers between 0.0 and 1.0 inclusive."
fd042993 G	61	(format "#%02x%02x%02x"
	62	(* red 255) (* green 255) (* blue 255)))
	63
6d713256 CY	64	(defun color-complement (color-name)
	65	"Return the color that is the complement of COLOR-NAME.
	66	COLOR-NAME should be a string naming a color (e.g. \"white\"), or
	67	a string specifying a color's RGB components (e.g. \"#ff12ec\")."
	68	(let ((color (color-name-to-rgb color-name)))
fd042993 G	69	(list (- 1.0 (car color))
	70	(- 1.0 (cadr color))
	71	(- 1.0 (caddr color)))))
	72
39cde66c JD	73	(defun color-gradient (start stop step-number)
	74	"Return a list with STEP-NUMBER colors from START to STOP.
	75	The color list builds a color gradient starting at color START to
	76	color STOP. It does not include the START and STOP color in the
	77	resulting list."
6d713256 CY	78	(let* ((r (nth 0 start))
	79	(g (nth 1 start))
	80	(b (nth 2 start))
	81	(r-step (/ (- (nth 0 stop) r) (1+ step-number)))
	82	(g-step (/ (- (nth 1 stop) g) (1+ step-number)))
	83	(b-step (/ (- (nth 2 stop) b) (1+ step-number)))
	84	result)
	85	(dotimes (n step-number)
	86	(push (list (setq r (+ r r-step))
	87	(setq g (+ g g-step))
	88	(setq b (+ b b-step)))
	89	result))
	90	(nreverse result)))
39cde66c	91
fd042993 G	92	(defun color-complement-hex (color)
fd042993 G	93	"Return the color that is the complement of COLOR, in hexadecimal format."
6d713256	94	(apply 'color-rgb-to-hex (color-complement color)))
fd042993	95
6d713256 CY	96	(defun color-rgb-to-hsv (red green blue)
	97	"Convert RED, GREEN, and BLUE color components to HSV.
	98	RED, GREEN, and BLUE should each be numbers between 0.0 and 1.0,
	99	inclusive. Return a list (HUE, SATURATION, VALUE), where HUE is
	100	in radians and both SATURATION and VALUE are between 0.0 and 1.0,
	101	inclusive."
	102	(let* ((r (float red))
ef6a2907 JD	103	(g (float green))
	104	(b (float blue))
	105	(max (max r g b))
	106	(min (min r g b)))
6d713256 CY	107	(if (< (- max min) 1e-8)
	108	(list 0.0 0.0 0.0)
	109	(list
	110	(/ (* 2 float-pi
	111	(cond ((and (= r g) (= g b)) 0)
	112	((and (= r max)
	113	(>= g b))
	114	(* 60 (/ (- g b) (- max min))))
	115	((and (= r max)
	116	(< g b))
	117	(+ 360 (* 60 (/ (- g b) (- max min)))))
	118	((= max g)
	119	(+ 120 (* 60 (/ (- b r) (- max min)))))
	120	((= max b)
	121	(+ 240 (* 60 (/ (- r g) (- max min)))))))
	122	360)
	123	(if (= max 0) 0 (- 1 (/ min max)))
	124	(/ max 255.0)))))
	125
	126	(defun color-rgb-to-hsl (red green blue)
ef6a2907	127	"Convert RED GREEN BLUE colors to their HSL representation.
6d713256 CY	128	RED, GREEN, and BLUE should each be numbers between 0.0 and 1.0,
	129	inclusive.
	130
e4920bc9 PE	131	Return a list (HUE, SATURATION, LUMINANCE), where HUE is in radians
e4920bc9 PE	132	and both SATURATION and LUMINANCE are between 0.0 and 1.0,
6d713256	133	inclusive."
fd042993 G	134	(let* ((r red)
	135	(g green)
	136	(b blue)
ef6a2907 JD	137	(max (max r g b))
	138	(min (min r g b))
	139	(delta (- max min))
	140	(l (/ (+ max min) 2.0)))
	141	(list
6d713256	142	(if (< (- max min) 1e-8)
ef6a2907 JD	143	0
	144	(* 2 float-pi
	145	(/ (cond ((= max r)
	146	(+ (/ (- g b) delta) (if (< g b) 6 0)))
	147	((= max g)
6d713256	148	(+ (/ (- b r) delta) 2))
ef6a2907 JD	149	(t
	150	(+ (/ (- r g) delta) 4)))
	151	6)))
	152	(if (= max min)
	153	0
	154	(if (> l 0.5)
	155	(/ delta (- 2 (+ max min)))
	156	(/ delta (+ max min))))
	157	l)))
	158
6d713256 CY	159	(defun color-srgb-to-xyz (red green blue)
	160	"Convert RED GREEN BLUE colors from the sRGB color space to CIE XYZ.
	161	RED, BLUE and GREEN must be between 0 and 1, inclusive."
ef6a2907 JD	162	(let ((r (if (<= red 0.04045)
	163	(/ red 12.95)
	164	(expt (/ (+ red 0.055) 1.055) 2.4)))
	165	(g (if (<= green 0.04045)
	166	(/ green 12.95)
	167	(expt (/ (+ green 0.055) 1.055) 2.4)))
	168	(b (if (<= blue 0.04045)
	169	(/ blue 12.95)
	170	(expt (/ (+ blue 0.055) 1.055) 2.4))))
	171	(list (+ (* 0.4124564 r) (* 0.3575761 g) (* 0.1804375 b))
	172	(+ (* 0.21266729 r) (* 0.7151522 g) (* 0.0721750 b))
	173	(+ (* 0.0193339 r) (* 0.1191920 g) (* 0.9503041 b)))))
	174
6d713256 CY	175	(defun color-xyz-to-srgb (X Y Z)
6d713256 CY	176	"Convert CIE X Y Z colors to sRGB color space."
ef6a2907 JD	177	(let ((r (+ (* 3.2404542 X) (* -1.5371385 Y) (* -0.4985314 Z)))
	178	(g (+ (* -0.9692660 X) (* 1.8760108 Y) (* 0.0415560 Z)))
	179	(b (+ (* 0.0556434 X) (* -0.2040259 Y) (* 1.0572252 Z))))
	180	(list (if (<= r 0.0031308)
	181	(* 12.92 r)
	182	(- (* 1.055 (expt r (/ 1 2.4))) 0.055))
	183	(if (<= g 0.0031308)
	184	(* 12.92 g)
	185	(- (* 1.055 (expt g (/ 1 2.4))) 0.055))
	186	(if (<= b 0.0031308)
	187	(* 12.92 b)
	188	(- (* 1.055 (expt b (/ 1 2.4))) 0.055)))))
	189
fd042993	190	(defconst color-d65-xyz '(0.950455 1.0 1.088753)
ef6a2907 JD	191	"D65 white point in CIE XYZ.")
ef6a2907 JD	192
fd042993 G	193	(defconst color-cie-ε (/ 216 24389.0))
fd042993 G	194	(defconst color-cie-κ (/ 24389 27.0))
ef6a2907	195
6d713256 CY	196	(defun color-xyz-to-lab (X Y Z &optional white-point)
	197	"Convert CIE XYZ to CIE Lab*.
	198	WHITE-POINT specifies the (X Y Z) white point for the
	199	conversion. If omitted or nil, use `color-d65-xyz'."
fd042993	200	(destructuring-bind (Xr Yr Zr) (or white-point color-d65-xyz)
ef6a2907 JD	201	(let* ((xr (/ X Xr))
	202	(yr (/ Y Yr))
	203	(zr (/ Z Zr))
fd042993	204	(fx (if (> xr color-cie-ε)
ef6a2907	205	(expt xr (/ 1 3.0))
fd042993 G	206	(/ (+ (* color-cie-κ xr) 16) 116.0)))
fd042993 G	207	(fy (if (> yr color-cie-ε)
ef6a2907	208	(expt yr (/ 1 3.0))
fd042993 G	209	(/ (+ (* color-cie-κ yr) 16) 116.0)))
fd042993 G	210	(fz (if (> zr color-cie-ε)
ef6a2907	211	(expt zr (/ 1 3.0))
fd042993	212	(/ (+ (* color-cie-κ zr) 16) 116.0))))
ef6a2907 JD	213	(list
	214	(- (* 116 fy) 16) ; L
	215	(* 500 (- fx fy)) ; a
	216	(* 200 (- fy fz)))))) ; b
	217
6d713256 CY	218	(defun color-lab-to-xyz (L a b &optional white-point)
	219	"Convert CIE Lab* to CIE XYZ.
	220	WHITE-POINT specifies the (X Y Z) white point for the
	221	conversion. If omitted or nil, use `color-d65-xyz'."
fd042993	222	(destructuring-bind (Xr Yr Zr) (or white-point color-d65-xyz)
ef6a2907 JD	223	(let* ((fy (/ (+ L 16) 116.0))
	224	(fz (- fy (/ b 200.0)))
	225	(fx (+ (/ a 500.0) fy))
fd042993	226	(xr (if (> (expt fx 3.0) color-cie-ε)
67d43a1d	227	(expt fx 3.0)
fd042993 G	228	(/ (- (* fx 116) 16) color-cie-κ)))
fd042993 G	229	(yr (if (> L (* color-cie-κ color-cie-ε))
67d43a1d	230	(expt (/ (+ L 16) 116.0) 3.0)
fd042993 G	231	(/ L color-cie-κ)))
fd042993 G	232	(zr (if (> (expt fz 3) color-cie-ε)
67d43a1d	233	(expt fz 3.0)
fd042993	234	(/ (- (* 116 fz) 16) color-cie-κ))))
ef6a2907 JD	235	(list (* xr Xr) ; X
	236	(* yr Yr) ; Y
	237	(* zr Zr))))) ; Z
	238
6d713256 CY	239	(defun color-srgb-to-lab (red green blue)
	240	"Convert RGB to CIE Lab*."
	241	(apply 'color-xyz-to-lab (color-srgb-to-xyz red green blue)))
ef6a2907	242
6d713256 CY	243	(defun color-lab-to-srgb (L a b)
	244	"Convert CIE Lab* to RGB."
	245	(apply 'color-xyz-to-srgb (color-lab-to-xyz L a b)))
ef6a2907	246
fd042993	247	(defun color-cie-de2000 (color1 color2 &optional kL kC kH)
6d713256 CY	248	"Return the CIEDE2000 color distance between COLOR1 and COLOR2.
	249	Both COLOR1 and COLOR2 should be in CIE Lab* format, as
	250	returned by `color-srgb-to-lab' or `color-xyz-to-lab'."
ef6a2907 JD	251	(destructuring-bind (L₁ a₁ b₁) color1
	252	(destructuring-bind (L₂ a₂ b₂) color2
	253	(let* ((kL (or kL 1))
	254	(kC (or kC 1))
	255	(kH (or kH 1))
67d43a1d G	256	(C₁ (sqrt (+ (expt a₁ 2.0) (expt b₁ 2.0))))
67d43a1d G	257	(C₂ (sqrt (+ (expt a₂ 2.0) (expt b₂ 2.0))))
ef6a2907	258	(C̄ (/ (+ C₁ C₂) 2.0))
67d43a1d	259	(G (* 0.5 (- 1 (sqrt (/ (expt C̄ 7.0) (+ (expt C̄ 7.0) (expt 25 7.0)))))))
ef6a2907 JD	260	(a′₁ (* (+ 1 G) a₁))
ef6a2907 JD	261	(a′₂ (* (+ 1 G) a₂))
67d43a1d G	262	(C′₁ (sqrt (+ (expt a′₁ 2.0) (expt b₁ 2.0))))
67d43a1d G	263	(C′₂ (sqrt (+ (expt a′₂ 2.0) (expt b₂ 2.0))))
ef6a2907 JD	264	(h′₁ (if (and (= b₁ 0) (= a′₁ 0))
	265	0
	266	(let ((v (atan b₁ a′₁)))
	267	(if (< v 0)
	268	(+ v (* 2 float-pi))
	269	v))))
	270	(h′₂ (if (and (= b₂ 0) (= a′₂ 0))
	271	0
	272	(let ((v (atan b₂ a′₂)))
	273	(if (< v 0)
	274	(+ v (* 2 float-pi))
	275	v))))
	276	(ΔL′ (- L₂ L₁))
	277	(ΔC′ (- C′₂ C′₁))
	278	(Δh′ (cond ((= (* C′₁ C′₂) 0)
	279	0)
	280	((<= (abs (- h′₂ h′₁)) float-pi)
	281	(- h′₂ h′₁))
	282	((> (- h′₂ h′₁) float-pi)
	283	(- (- h′₂ h′₁) (* 2 float-pi)))
	284	((< (- h′₂ h′₁) (- float-pi))
	285	(+ (- h′₂ h′₁) (* 2 float-pi)))))
	286	(ΔH′ (* 2 (sqrt (* C′₁ C′₂)) (sin (/ Δh′ 2.0))))
	287	(L̄′ (/ (+ L₁ L₂) 2.0))
	288	(C̄′ (/ (+ C′₁ C′₂) 2.0))
	289	(h̄′ (cond ((= (* C′₁ C′₂) 0)
	290	(+ h′₁ h′₂))
	291	((<= (abs (- h′₁ h′₂)) float-pi)
	292	(/ (+ h′₁ h′₂) 2.0))
	293	((< (+ h′₁ h′₂) (* 2 float-pi))
	294	(/ (+ h′₁ h′₂ (* 2 float-pi)) 2.0))
	295	((>= (+ h′₁ h′₂) (* 2 float-pi))
	296	(/ (+ h′₁ h′₂ (* -2 float-pi)) 2.0))))
	297	(T (+ 1
	298	(- (* 0.17 (cos (- h̄′ (degrees-to-radians 30)))))
	299	(* 0.24 (cos (* h̄′ 2)))
	300	(* 0.32 (cos (+ (* h̄′ 3) (degrees-to-radians 6))))
	301	(- (* 0.20 (cos (- (* h̄′ 4) (degrees-to-radians 63)))))))
67d43a1d G	302	(Δθ (* (degrees-to-radians 30) (exp (- (expt (/ (- h̄′ (degrees-to-radians 275)) (degrees-to-radians 25)) 2.0)))))
	303	(Rc (* 2 (sqrt (/ (expt C̄′ 7.0) (+ (expt C̄′ 7.0) (expt 25.0 7.0))))))
	304	(Sl (+ 1 (/ (* 0.015 (expt (- L̄′ 50) 2.0)) (sqrt (+ 20 (expt (- L̄′ 50) 2.0))))))
ef6a2907 JD	305	(Sc (+ 1 (* C̄′ 0.045)))
	306	(Sh (+ 1 (* 0.015 C̄′ T)))
	307	(Rt (- (* (sin (* Δθ 2)) Rc))))
67d43a1d G	308	(sqrt (+ (expt (/ ΔL′ (* Sl kL)) 2.0)
	309	(expt (/ ΔC′ (* Sc kC)) 2.0)
	310	(expt (/ ΔH′ (* Sh kH)) 2.0)
ef6a2907 JD	311	(* Rt (/ ΔC′ (* Sc kC)) (/ ΔH′ (* Sh kH)))))))))
ef6a2907 JD	312
fd042993	313	(provide 'color)
463bcf11	314
fd042993	315	;;; color.el ends here