Commit | Line | Data |
---|---|---|
ef6a2907 JD |
1 | ;;; shr-color.el --- Simple HTML Renderer color management |
2 | ||
acaf905b | 3 | ;; Copyright (C) 2010-2012 Free Software Foundation, Inc. |
ef6a2907 JD |
4 | |
5 | ;; Author: Julien Danjou <julien@danjou.info> | |
6 | ;; Keywords: html | |
7 | ||
8 | ;; This file is part of GNU Emacs. | |
9 | ||
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. | |
14 | ||
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. | |
19 | ||
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/>. | |
22 | ||
23 | ;;; Commentary: | |
24 | ||
25 | ;; This package handles colors display for shr. | |
26 | ||
27 | ;;; Code: | |
28 | ||
fd042993 | 29 | (require 'color) |
5be93fc8 | 30 | (eval-when-compile (require 'cl)) |
ef6a2907 JD |
31 | |
32 | (defgroup shr-color nil | |
33 | "Simple HTML Renderer colors" | |
34 | :group 'shr) | |
35 | ||
36 | (defcustom shr-color-visible-luminance-min 40 | |
37 | "Minimum luminance distance between two colors to be considered visible. | |
38 | Must be between 0 and 100." | |
39 | :group 'shr | |
40 | :type 'float) | |
41 | ||
42 | (defcustom shr-color-visible-distance-min 5 | |
43 | "Minimum color distance between two colors to be considered visible. | |
0d26e0b6 | 44 | This value is used to compare result for `ciede2000'. It's an |
ef6a2907 JD |
45 | absolute value without any unit." |
46 | :group 'shr | |
47 | :type 'integer) | |
48 | ||
094ae2ab G |
49 | (defconst shr-color-html-colors-alist |
50 | '(("AliceBlue" . "#F0F8FF") | |
51 | ("AntiqueWhite" . "#FAEBD7") | |
52 | ("Aqua" . "#00FFFF") | |
53 | ("Aquamarine" . "#7FFFD4") | |
54 | ("Azure" . "#F0FFFF") | |
55 | ("Beige" . "#F5F5DC") | |
56 | ("Bisque" . "#FFE4C4") | |
57 | ("Black" . "#000000") | |
58 | ("BlanchedAlmond" . "#FFEBCD") | |
59 | ("Blue" . "#0000FF") | |
60 | ("BlueViolet" . "#8A2BE2") | |
61 | ("Brown" . "#A52A2A") | |
62 | ("BurlyWood" . "#DEB887") | |
63 | ("CadetBlue" . "#5F9EA0") | |
64 | ("Chartreuse" . "#7FFF00") | |
65 | ("Chocolate" . "#D2691E") | |
66 | ("Coral" . "#FF7F50") | |
67 | ("CornflowerBlue" . "#6495ED") | |
68 | ("Cornsilk" . "#FFF8DC") | |
69 | ("Crimson" . "#DC143C") | |
70 | ("Cyan" . "#00FFFF") | |
71 | ("DarkBlue" . "#00008B") | |
72 | ("DarkCyan" . "#008B8B") | |
73 | ("DarkGoldenRod" . "#B8860B") | |
74 | ("DarkGray" . "#A9A9A9") | |
75 | ("DarkGrey" . "#A9A9A9") | |
76 | ("DarkGreen" . "#006400") | |
77 | ("DarkKhaki" . "#BDB76B") | |
78 | ("DarkMagenta" . "#8B008B") | |
79 | ("DarkOliveGreen" . "#556B2F") | |
80 | ("Darkorange" . "#FF8C00") | |
81 | ("DarkOrchid" . "#9932CC") | |
82 | ("DarkRed" . "#8B0000") | |
83 | ("DarkSalmon" . "#E9967A") | |
84 | ("DarkSeaGreen" . "#8FBC8F") | |
85 | ("DarkSlateBlue" . "#483D8B") | |
86 | ("DarkSlateGray" . "#2F4F4F") | |
87 | ("DarkSlateGrey" . "#2F4F4F") | |
88 | ("DarkTurquoise" . "#00CED1") | |
89 | ("DarkViolet" . "#9400D3") | |
90 | ("DeepPink" . "#FF1493") | |
91 | ("DeepSkyBlue" . "#00BFFF") | |
92 | ("DimGray" . "#696969") | |
93 | ("DimGrey" . "#696969") | |
94 | ("DodgerBlue" . "#1E90FF") | |
95 | ("FireBrick" . "#B22222") | |
96 | ("FloralWhite" . "#FFFAF0") | |
97 | ("ForestGreen" . "#228B22") | |
98 | ("Fuchsia" . "#FF00FF") | |
99 | ("Gainsboro" . "#DCDCDC") | |
100 | ("GhostWhite" . "#F8F8FF") | |
101 | ("Gold" . "#FFD700") | |
102 | ("GoldenRod" . "#DAA520") | |
103 | ("Gray" . "#808080") | |
104 | ("Grey" . "#808080") | |
105 | ("Green" . "#008000") | |
106 | ("GreenYellow" . "#ADFF2F") | |
107 | ("HoneyDew" . "#F0FFF0") | |
108 | ("HotPink" . "#FF69B4") | |
109 | ("IndianRed" . "#CD5C5C") | |
110 | ("Indigo" . "#4B0082") | |
111 | ("Ivory" . "#FFFFF0") | |
112 | ("Khaki" . "#F0E68C") | |
113 | ("Lavender" . "#E6E6FA") | |
114 | ("LavenderBlush" . "#FFF0F5") | |
115 | ("LawnGreen" . "#7CFC00") | |
116 | ("LemonChiffon" . "#FFFACD") | |
117 | ("LightBlue" . "#ADD8E6") | |
118 | ("LightCoral" . "#F08080") | |
119 | ("LightCyan" . "#E0FFFF") | |
120 | ("LightGoldenRodYellow" . "#FAFAD2") | |
121 | ("LightGray" . "#D3D3D3") | |
122 | ("LightGrey" . "#D3D3D3") | |
123 | ("LightGreen" . "#90EE90") | |
124 | ("LightPink" . "#FFB6C1") | |
125 | ("LightSalmon" . "#FFA07A") | |
126 | ("LightSeaGreen" . "#20B2AA") | |
127 | ("LightSkyBlue" . "#87CEFA") | |
128 | ("LightSlateGray" . "#778899") | |
129 | ("LightSlateGrey" . "#778899") | |
130 | ("LightSteelBlue" . "#B0C4DE") | |
131 | ("LightYellow" . "#FFFFE0") | |
132 | ("Lime" . "#00FF00") | |
133 | ("LimeGreen" . "#32CD32") | |
134 | ("Linen" . "#FAF0E6") | |
135 | ("Magenta" . "#FF00FF") | |
136 | ("Maroon" . "#800000") | |
137 | ("MediumAquaMarine" . "#66CDAA") | |
138 | ("MediumBlue" . "#0000CD") | |
139 | ("MediumOrchid" . "#BA55D3") | |
140 | ("MediumPurple" . "#9370D8") | |
141 | ("MediumSeaGreen" . "#3CB371") | |
142 | ("MediumSlateBlue" . "#7B68EE") | |
143 | ("MediumSpringGreen" . "#00FA9A") | |
144 | ("MediumTurquoise" . "#48D1CC") | |
145 | ("MediumVioletRed" . "#C71585") | |
146 | ("MidnightBlue" . "#191970") | |
147 | ("MintCream" . "#F5FFFA") | |
148 | ("MistyRose" . "#FFE4E1") | |
149 | ("Moccasin" . "#FFE4B5") | |
150 | ("NavajoWhite" . "#FFDEAD") | |
151 | ("Navy" . "#000080") | |
152 | ("OldLace" . "#FDF5E6") | |
153 | ("Olive" . "#808000") | |
154 | ("OliveDrab" . "#6B8E23") | |
155 | ("Orange" . "#FFA500") | |
156 | ("OrangeRed" . "#FF4500") | |
157 | ("Orchid" . "#DA70D6") | |
158 | ("PaleGoldenRod" . "#EEE8AA") | |
159 | ("PaleGreen" . "#98FB98") | |
160 | ("PaleTurquoise" . "#AFEEEE") | |
161 | ("PaleVioletRed" . "#D87093") | |
162 | ("PapayaWhip" . "#FFEFD5") | |
163 | ("PeachPuff" . "#FFDAB9") | |
164 | ("Peru" . "#CD853F") | |
165 | ("Pink" . "#FFC0CB") | |
166 | ("Plum" . "#DDA0DD") | |
167 | ("PowderBlue" . "#B0E0E6") | |
168 | ("Purple" . "#800080") | |
169 | ("Red" . "#FF0000") | |
170 | ("RosyBrown" . "#BC8F8F") | |
171 | ("RoyalBlue" . "#4169E1") | |
172 | ("SaddleBrown" . "#8B4513") | |
173 | ("Salmon" . "#FA8072") | |
174 | ("SandyBrown" . "#F4A460") | |
175 | ("SeaGreen" . "#2E8B57") | |
176 | ("SeaShell" . "#FFF5EE") | |
177 | ("Sienna" . "#A0522D") | |
178 | ("Silver" . "#C0C0C0") | |
179 | ("SkyBlue" . "#87CEEB") | |
180 | ("SlateBlue" . "#6A5ACD") | |
181 | ("SlateGray" . "#708090") | |
182 | ("SlateGrey" . "#708090") | |
183 | ("Snow" . "#FFFAFA") | |
184 | ("SpringGreen" . "#00FF7F") | |
185 | ("SteelBlue" . "#4682B4") | |
186 | ("Tan" . "#D2B48C") | |
187 | ("Teal" . "#008080") | |
188 | ("Thistle" . "#D8BFD8") | |
189 | ("Tomato" . "#FF6347") | |
190 | ("Turquoise" . "#40E0D0") | |
191 | ("Violet" . "#EE82EE") | |
192 | ("Wheat" . "#F5DEB3") | |
193 | ("White" . "#FFFFFF") | |
194 | ("WhiteSmoke" . "#F5F5F5") | |
195 | ("Yellow" . "#FFFF00") | |
196 | ("YellowGreen" . "#9ACD32")) | |
197 | "Alist of HTML colors. | |
198 | Each entry should have the form (COLOR-NAME . HEXADECIMAL-COLOR).") | |
199 | ||
ef6a2907 | 200 | (defun shr-color-relative-to-absolute (number) |
0d26e0b6 JB |
201 | "Convert a relative NUMBER to absolute. |
202 | If NUMBER is absolute, return NUMBER. | |
ef6a2907 JD |
203 | This will convert \"80 %\" to 204, \"100 %\" to 255 but \"123\" to \"123\"." |
204 | (let ((string-length (- (length number) 1))) | |
205 | ;; Is this a number with %? | |
206 | (if (eq (elt number string-length) ?%) | |
207 | (/ (* (string-to-number (substring number 0 string-length)) 255) 100) | |
208 | (string-to-number number)))) | |
209 | ||
a2994808 JD |
210 | (defun shr-color-hue-to-rgb (x y h) |
211 | "Convert X Y H to RGB value." | |
212 | (when (< h 0) (incf h)) | |
213 | (when (> h 1) (decf h)) | |
214 | (cond ((< h (/ 1 6.0)) (+ x (* (- y x) h 6))) | |
215 | ((< h 0.5) y) | |
216 | ((< h (/ 2.0 3.0)) (+ x (* (- y x) (- (/ 2.0 3.0) h) 6))) | |
217 | (t x))) | |
218 | ||
ef6a2907 JD |
219 | (defun shr-color-hsl-to-rgb-fractions (h s l) |
220 | "Convert H S L to fractional RGB values." | |
221 | (let (m1 m2) | |
222 | (if (<= l 0.5) | |
223 | (setq m2 (* l (+ s 1))) | |
224 | (setq m2 (- (+ l s) (* l s)))) | |
225 | (setq m1 (- (* l 2) m2)) | |
a2994808 JD |
226 | (list (shr-color-hue-to-rgb m1 m2 (+ h (/ 1 3.0))) |
227 | (shr-color-hue-to-rgb m1 m2 h) | |
228 | (shr-color-hue-to-rgb m1 m2 (- h (/ 1 3.0)))))) | |
ef6a2907 JD |
229 | |
230 | (defun shr-color->hexadecimal (color) | |
231 | "Convert any color format to hexadecimal representation. | |
232 | Like rgb() or hsl()." | |
233 | (when color | |
094ae2ab G |
234 | (cond |
235 | ;; Hexadecimal color: #abc or #aabbcc | |
67d43a1d G |
236 | ((string-match |
237 | "\\(#[0-9a-fA-F]\\{3\\}[0-9a-fA-F]\\{3\\}?\\)" | |
094ae2ab | 238 | color) |
67d43a1d | 239 | (match-string 1 color)) |
094ae2ab G |
240 | ;; rgb() or rgba() colors |
241 | ((or (string-match | |
242 | "rgb(\s*\\([0-9]\\{1,3\\}\\(?:\s*%\\)?\\)\s*,\s*\\([0-9]\\{1,3\\}\\(?:\s*%\\)?\\)\s*,\s*\\([0-9]\\{1,3\\}\\(?:\s*%\\)?\\)\s*)" | |
243 | color) | |
244 | (string-match | |
245 | "rgba(\s*\\([0-9]\\{1,3\\}\\(?:\s*%\\)?\\)\s*,\s*\\([0-9]\\{1,3\\}\\(?:\s*%\\)?\\)\s*,\s*\\([0-9]\\{1,3\\}\\(?:\s*%\\)?\\)\s*,\s*[0-9]*\.?[0-9]+\s*%?\s*)" | |
246 | color)) | |
247 | (format "#%02X%02X%02X" | |
248 | (shr-color-relative-to-absolute (match-string-no-properties 1 color)) | |
249 | (shr-color-relative-to-absolute (match-string-no-properties 2 color)) | |
250 | (shr-color-relative-to-absolute (match-string-no-properties 3 color)))) | |
251 | ;; hsl() or hsla() colors | |
252 | ((or (string-match | |
253 | "hsl(\s*\\([0-9]\\{1,3\\}\\)\s*,\s*\\([0-9]\\{1,3\\}\\)\s*%\s*,\s*\\([0-9]\\{1,3\\}\\)\s*%\s*)" | |
254 | color) | |
255 | (string-match | |
256 | "hsla(\s*\\([0-9]\\{1,3\\}\\)\s*,\s*\\([0-9]\\{1,3\\}\\)\s*%\s*,\s*\\([0-9]\\{1,3\\}\\)\s*%\s*,\s*[0-9]*\.?[0-9]+\s*%?\s*)" | |
257 | color)) | |
258 | (let ((h (/ (string-to-number (match-string-no-properties 1 color)) 360.0)) | |
259 | (s (/ (string-to-number (match-string-no-properties 2 color)) 100.0)) | |
260 | (l (/ (string-to-number (match-string-no-properties 3 color)) 100.0))) | |
261 | (destructuring-bind (r g b) | |
262 | (shr-color-hsl-to-rgb-fractions h s l) | |
6d713256 | 263 | (color-rgb-to-hex r g b)))) |
094ae2ab | 264 | ;; Color names |
4b8b6f60 | 265 | ((cdr (assoc-string color shr-color-html-colors-alist t))) |
094ae2ab G |
266 | ;; Unrecognized color :( |
267 | (t | |
268 | nil)))) | |
ef6a2907 JD |
269 | |
270 | (defun set-minimum-interval (val1 val2 min max interval &optional fixed) | |
271 | "Set minimum interval between VAL1 and VAL2 to INTERVAL. | |
272 | The values are bound by MIN and MAX. | |
0d26e0b6 | 273 | If FIXED is t, then VAL1 will not be touched." |
ef6a2907 JD |
274 | (let ((diff (abs (- val1 val2)))) |
275 | (unless (>= diff interval) | |
276 | (if fixed | |
277 | (let* ((missing (- interval diff)) | |
278 | ;; If val2 > val1, try to increase val2 | |
279 | ;; That's the "good direction" | |
280 | (val2-good-direction | |
281 | (if (> val2 val1) | |
282 | (min max (+ val2 missing)) | |
283 | (max min (- val2 missing)))) | |
284 | (diff-val2-good-direction-val1 (abs (- val2-good-direction val1)))) | |
285 | (if (>= diff-val2-good-direction-val1 interval) | |
286 | (setq val2 val2-good-direction) | |
287 | ;; Good-direction is not so good, compute bad-direction | |
288 | (let* ((val2-bad-direction | |
289 | (if (> val2 val1) | |
290 | (max min (- val1 interval)) | |
291 | (min max (+ val1 interval)))) | |
292 | (diff-val2-bad-direction-val1 (abs (- val2-bad-direction val1)))) | |
293 | (if (>= diff-val2-bad-direction-val1 interval) | |
294 | (setq val2 val2-bad-direction) | |
295 | ;; Still not good, pick the best and prefer good direction | |
296 | (setq val2 | |
297 | (if (>= diff-val2-good-direction-val1 diff-val2-bad-direction-val1) | |
298 | val2-good-direction | |
299 | val2-bad-direction)))))) | |
300 | ;; No fixed, move val1 and val2 | |
301 | (let ((missing (/ (- interval diff) 2.0))) | |
302 | (if (< val1 val2) | |
303 | (setq val1 (max min (- val1 missing)) | |
304 | val2 (min max (+ val2 missing))) | |
305 | (setq val2 (max min (- val2 missing)) | |
306 | val1 (min max (+ val1 missing)))) | |
307 | (setq diff (abs (- val1 val2))) ; Recompute diff | |
308 | (unless (>= diff interval) | |
309 | ;; Not ok, we hit a boundary | |
310 | (let ((missing (- interval diff))) | |
311 | (cond ((= val1 min) | |
312 | (setq val2 (+ val2 missing))) | |
313 | ((= val2 min) | |
314 | (setq val1 (+ val1 missing))) | |
315 | ((= val1 max) | |
316 | (setq val2 (- val2 missing))) | |
317 | ((= val2 max) | |
318 | (setq val1 (- val1 missing))))))))) | |
319 | (list val1 val2))) | |
320 | ||
321 | (defun shr-color-visible (bg fg &optional fixed-background) | |
322 | "Check that BG and FG colors are visible if they are drawn on each other. | |
0d26e0b6 | 323 | Return (bg fg) if they are. If they are too similar, two new |
144b7b5c | 324 | colors are returned instead. |
ef6a2907 | 325 | If FIXED-BACKGROUND is set, and if the color are not visible, a |
0d26e0b6 | 326 | new background color will not be computed. Only the foreground |
ef6a2907 JD |
327 | color will be adapted to be visible on BG." |
328 | ;; Convert fg and bg to CIE Lab | |
6d713256 CY |
329 | (let ((fg-norm (color-name-to-rgb fg)) |
330 | (bg-norm (color-name-to-rgb bg))) | |
fded65c7 LMI |
331 | (if (or (null fg-norm) |
332 | (null bg-norm)) | |
333 | (list bg fg) | |
6d713256 CY |
334 | (let* ((fg-lab (apply 'color-srgb-to-lab fg-norm)) |
335 | (bg-lab (apply 'color-srgb-to-lab bg-norm)) | |
fded65c7 | 336 | ;; Compute color distance using CIE DE 2000 |
fd042993 | 337 | (fg-bg-distance (color-cie-de2000 fg-lab bg-lab)) |
0d26e0b6 | 338 | ;; Compute luminance distance (subtract L component) |
fded65c7 LMI |
339 | (luminance-distance (abs (- (car fg-lab) (car bg-lab))))) |
340 | (if (and (>= fg-bg-distance shr-color-visible-distance-min) | |
341 | (>= luminance-distance shr-color-visible-luminance-min)) | |
342 | (list bg fg) | |
343 | ;; Not visible, try to change luminance to make them visible | |
344 | (let ((Ls (set-minimum-interval (car bg-lab) (car fg-lab) 0 100 | |
345 | shr-color-visible-luminance-min | |
346 | fixed-background))) | |
347 | (unless fixed-background | |
348 | (setcar bg-lab (car Ls))) | |
349 | (setcar fg-lab (cadr Ls)) | |
350 | (list | |
351 | (if fixed-background | |
352 | bg | |
353 | (apply 'format "#%02x%02x%02x" | |
354 | (mapcar (lambda (x) (* (max (min 1 x) 0) 255)) | |
6d713256 | 355 | (apply 'color-lab-to-srgb bg-lab)))) |
fded65c7 LMI |
356 | (apply 'format "#%02x%02x%02x" |
357 | (mapcar (lambda (x) (* (max (min 1 x) 0) 255)) | |
6d713256 | 358 | (apply 'color-lab-to-srgb fg-lab)))))))))) |
ef6a2907 JD |
359 | |
360 | (provide 'shr-color) | |
361 | ||
362 | ;;; shr-color.el ends here |