1 ;;; color.el --- Color manipulation laboratory routines -*- coding: utf-8; -*-
3 ;; Copyright (C) 2010-2011 Free Software Foundation, Inc.
5 ;; Author: Julien Danjou <julien@danjou.info>
8 ;; This file is part of GNU Emacs.
10 ;; GNU Emacs is free software: you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation, either version 3 of the License, or
13 ;; (at your option) any later version.
15 ;; GNU Emacs is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
25 ;; This package provides color manipulation functions.
34 (unless (boundp 'float-pi
)
35 (defconst float-pi
(* 4 (atan 1)) "The value of Pi (3.1415926...).")))
37 (defun color-rgb->hex
(red green blue
)
38 "Return hexadecimal notation for RED GREEN BLUE color.
39 RED GREEN BLUE must be values between 0 and 1 inclusively."
40 (format "#%02x%02x%02x"
41 (* red
255) (* green
255) (* blue
255)))
43 (defun color-complement (color)
44 "Return the color that is the complement of COLOR."
45 (let ((color (color-rgb->normalize color
)))
46 (list (- 1.0 (car color
))
48 (- 1.0 (caddr color
)))))
50 (defun color-gradient (start stop step-number
)
51 "Return a list with STEP-NUMBER colors from START to STOP.
52 The color list builds a color gradient starting at color START to
53 color STOP. It does not include the START and STOP color in the
55 (loop for i from
1 to step-number
56 with red-step
= (/ (- (car stop
) (car start
)) (1+ step-number
))
57 with green-step
= (/ (- (cadr stop
) (cadr start
)) (1+ step-number
))
58 with blue-step
= (/ (- (caddr stop
) (caddr start
)) (1+ step-number
))
60 (+ (car start
) (* i red-step
))
61 (+ (cadr start
) (* i green-step
))
62 (+ (caddr start
) (* i blue-step
)))))
64 (defun color-complement-hex (color)
65 "Return the color that is the complement of COLOR, in hexadecimal format."
66 (apply 'color-rgb-
>hex
(color-complement color
)))
68 (defun color-rgb->hsv
(red green blue
)
69 "Convert RED GREEN BLUE values to HSV representation.
70 Hue is in radians. Saturation and values are between 0 and 1
72 (let* ((r (float red
))
79 (cond ((and (= r g
) (= g b
)) 0)
82 (* 60 (/ (- g b
) (- max min
))))
85 (+ 360 (* 60 (/ (- g b
) (- max min
)))))
87 (+ 120 (* 60 (/ (- b r
) (- max min
)))))
89 (+ 240 (* 60 (/ (- r g
) (- max min
)))))))
96 (defun color-rgb->hsl
(red green blue
)
97 "Convert RED GREEN BLUE colors to their HSL representation.
98 RED, GREEN and BLUE must be between 0 and 1 inclusively."
105 (l (/ (+ max min
) 2.0)))
111 (+ (/ (- g b
) delta
) (if (< g b
) 6 0)))
113 (+ (/ (- b r
) delta
) 2))
115 (+ (/ (- r g
) delta
) 4)))
120 (/ delta
(- 2 (+ max min
)))
121 (/ delta
(+ max min
))))
124 (defun color-srgb->xyz
(red green blue
)
125 "Converts RED GREEN BLUE colors from the sRGB color space to CIE XYZ.
126 RED, BLUE and GREEN must be between 0 and 1 inclusively."
127 (let ((r (if (<= red
0.04045)
129 (expt (/ (+ red
0.055) 1.055) 2.4)))
130 (g (if (<= green
0.04045)
132 (expt (/ (+ green
0.055) 1.055) 2.4)))
133 (b (if (<= blue
0.04045)
135 (expt (/ (+ blue
0.055) 1.055) 2.4))))
136 (list (+ (* 0.4124564 r
) (* 0.3575761 g
) (* 0.1804375 b
))
137 (+ (* 0.21266729 r
) (* 0.7151522 g
) (* 0.0721750 b
))
138 (+ (* 0.0193339 r
) (* 0.1191920 g
) (* 0.9503041 b
)))))
140 (defun color-xyz->srgb
(X Y Z
)
141 "Converts CIE X Y Z colors to sRGB color space."
142 (let ((r (+ (* 3.2404542 X
) (* -
1.5371385 Y
) (* -
0.4985314 Z
)))
143 (g (+ (* -
0.9692660 X
) (* 1.8760108 Y
) (* 0.0415560 Z
)))
144 (b (+ (* 0.0556434 X
) (* -
0.2040259 Y
) (* 1.0572252 Z
))))
145 (list (if (<= r
0.0031308)
147 (- (* 1.055 (expt r
(/ 1 2.4))) 0.055))
150 (- (* 1.055 (expt g
(/ 1 2.4))) 0.055))
153 (- (* 1.055 (expt b
(/ 1 2.4))) 0.055)))))
155 (defconst color-d65-xyz
'(0.950455
1.0 1.088753)
156 "D65 white point in CIE XYZ.")
158 (defconst color-cie-ε
(/ 216 24389.0))
159 (defconst color-cie-κ
(/ 24389 27.0))
161 (defun color-xyz->lab
(X Y Z
&optional white-point
)
162 "Converts CIE XYZ to CIE L*a*b*.
163 WHITE-POINT can be specified as (X Y Z) white point to use. If
164 none is set, `color-d65-xyz' is used."
165 (destructuring-bind (Xr Yr Zr
) (or white-point color-d65-xyz
)
169 (fx (if (> xr color-cie-ε
)
171 (/ (+ (* color-cie-κ xr
) 16) 116.0)))
172 (fy (if (> yr color-cie-ε
)
174 (/ (+ (* color-cie-κ yr
) 16) 116.0)))
175 (fz (if (> zr color-cie-ε
)
177 (/ (+ (* color-cie-κ zr
) 16) 116.0))))
179 (- (* 116 fy
) 16) ; L
180 (* 500 (- fx fy
)) ; a
181 (* 200 (- fy fz
)))))) ; b
183 (defun color-lab->xyz
(L a b
&optional white-point
)
184 "Converts CIE L*a*b* to CIE XYZ.
185 WHITE-POINT can be specified as (X Y Z) white point to use. If
186 none is set, `color-d65-xyz' is used."
187 (destructuring-bind (Xr Yr Zr
) (or white-point color-d65-xyz
)
188 (let* ((fy (/ (+ L
16) 116.0))
189 (fz (- fy
(/ b
200.0)))
190 (fx (+ (/ a
500.0) fy
))
191 (xr (if (> (expt fx
3.0) color-cie-ε
)
193 (/ (- (* fx
116) 16) color-cie-κ
)))
194 (yr (if (> L
(* color-cie-κ color-cie-ε
))
195 (expt (/ (+ L
16) 116.0) 3.0)
197 (zr (if (> (expt fz
3) color-cie-ε
)
199 (/ (- (* 116 fz
) 16) color-cie-κ
))))
204 (defun color-srgb->lab
(red green blue
)
205 "Converts RGB to CIE L*a*b*."
206 (apply 'color-xyz-
>lab
(color-srgb->xyz red green blue
)))
208 (defun color-rgb->normalize
(color)
209 "Normalize a RGB color to values between 0 and 1 inclusively."
210 (mapcar (lambda (x) (/ x
65535.0)) (x-color-values color
)))
212 (defun color-lab->srgb
(L a b
)
213 "Converts CIE L*a*b* to RGB."
214 (apply 'color-xyz-
>srgb
(color-lab->xyz L a b
)))
216 (defun color-cie-de2000 (color1 color2
&optional kL kC kH
)
217 "Computes the CIEDE2000 color distance between COLOR1 and COLOR2.
218 Colors must be in CIE L*a*b* format."
219 (destructuring-bind (L₁ a₁ b₁
) color1
220 (destructuring-bind (L₂ a₂ b₂
) color2
221 (let* ((kL (or kL
1))
224 (C₁
(sqrt (+ (expt a₁
2.0) (expt b₁
2.0))))
225 (C₂
(sqrt (+ (expt a₂
2.0) (expt b₂
2.0))))
226 (C̄
(/ (+ C₁ C₂
) 2.0))
227 (G (* 0.5 (- 1 (sqrt (/ (expt C̄
7.0) (+ (expt C̄
7.0) (expt 25 7.0)))))))
230 (C′₁
(sqrt (+ (expt a′₁
2.0) (expt b₁
2.0))))
231 (C′₂
(sqrt (+ (expt a′₂
2.0) (expt b₂
2.0))))
232 (h′₁
(if (and (= b₁
0) (= a′₁
0))
234 (let ((v (atan b₁ a′₁
)))
238 (h′₂
(if (and (= b₂
0) (= a′₂
0))
240 (let ((v (atan b₂ a′₂
)))
246 (Δh′
(cond ((= (* C′₁ C′₂
) 0)
248 ((<= (abs (- h′₂ h′₁
)) float-pi
)
250 ((> (- h′₂ h′₁
) float-pi
)
251 (- (- h′₂ h′₁
) (* 2 float-pi
)))
252 ((< (- h′₂ h′₁
) (- float-pi
))
253 (+ (- h′₂ h′₁
) (* 2 float-pi
)))))
254 (ΔH′
(* 2 (sqrt (* C′₁ C′₂
)) (sin (/ Δh′
2.0))))
255 (L̄′
(/ (+ L₁ L₂
) 2.0))
256 (C̄′
(/ (+ C′₁ C′₂
) 2.0))
257 (h̄′
(cond ((= (* C′₁ C′₂
) 0)
259 ((<= (abs (- h′₁ h′₂
)) float-pi
)
261 ((< (+ h′₁ h′₂
) (* 2 float-pi
))
262 (/ (+ h′₁ h′₂
(* 2 float-pi
)) 2.0))
263 ((>= (+ h′₁ h′₂
) (* 2 float-pi
))
264 (/ (+ h′₁ h′₂
(* -
2 float-pi
)) 2.0))))
266 (- (* 0.17 (cos (- h̄′
(degrees-to-radians 30)))))
267 (* 0.24 (cos (* h̄′
2)))
268 (* 0.32 (cos (+ (* h̄′
3) (degrees-to-radians 6))))
269 (- (* 0.20 (cos (- (* h̄′
4) (degrees-to-radians 63)))))))
270 (Δθ
(* (degrees-to-radians 30) (exp (- (expt (/ (- h̄′
(degrees-to-radians 275)) (degrees-to-radians 25)) 2.0)))))
271 (Rc (* 2 (sqrt (/ (expt C̄′
7.0) (+ (expt C̄′
7.0) (expt 25.0 7.0))))))
272 (Sl (+ 1 (/ (* 0.015 (expt (- L̄′
50) 2.0)) (sqrt (+ 20 (expt (- L̄′
50) 2.0))))))
273 (Sc (+ 1 (* C̄′
0.045)))
274 (Sh (+ 1 (* 0.015 C̄′ T
)))
275 (Rt (- (* (sin (* Δθ
2)) Rc
))))
276 (sqrt (+ (expt (/ ΔL′
(* Sl kL
)) 2.0)
277 (expt (/ ΔC′
(* Sc kC
)) 2.0)
278 (expt (/ ΔH′
(* Sh kH
)) 2.0)
279 (* Rt
(/ ΔC′
(* Sc kC
)) (/ ΔH′
(* Sh kH
)))))))))
283 ;;; color.el ends here