| 1 | ;;; shr-color.el --- Simple HTML Renderer color management |
| 2 | |
| 3 | ;; Copyright (C) 2010-2013 Free Software Foundation, Inc. |
| 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 | |
| 29 | (require 'color) |
| 30 | (eval-when-compile (require 'cl)) |
| 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 'number) |
| 41 | |
| 42 | (defcustom shr-color-visible-distance-min 5 |
| 43 | "Minimum color distance between two colors to be considered visible. |
| 44 | This value is used to compare result for `ciede2000'. It's an |
| 45 | absolute value without any unit." |
| 46 | :group 'shr |
| 47 | :type 'integer) |
| 48 | |
| 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 | |
| 200 | (defun shr-color-relative-to-absolute (number) |
| 201 | "Convert a relative NUMBER to absolute. |
| 202 | If NUMBER is absolute, return NUMBER. |
| 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 | |
| 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 | |
| 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)) |
| 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)))))) |
| 229 | |
| 230 | (defun shr-color->hexadecimal (color) |
| 231 | "Convert any color format to hexadecimal representation. |
| 232 | Like rgb() or hsl()." |
| 233 | (when color |
| 234 | (cond |
| 235 | ;; Hexadecimal color: #abc or #aabbcc |
| 236 | ((string-match |
| 237 | "\\(#[0-9a-fA-F]\\{3\\}[0-9a-fA-F]\\{3\\}?\\)" |
| 238 | color) |
| 239 | (match-string 1 color)) |
| 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) |
| 263 | (color-rgb-to-hex r g b)))) |
| 264 | ;; Color names |
| 265 | ((cdr (assoc-string color shr-color-html-colors-alist t))) |
| 266 | ;; Unrecognized color :( |
| 267 | (t |
| 268 | nil)))) |
| 269 | |
| 270 | (defun shr-color-set-minimum-interval (val1 val2 min max interval |
| 271 | &optional fixed) |
| 272 | "Set minimum interval between VAL1 and VAL2 to INTERVAL. |
| 273 | The values are bound by MIN and MAX. |
| 274 | If FIXED is t, then VAL1 will not be touched." |
| 275 | (let ((diff (abs (- val1 val2)))) |
| 276 | (unless (>= diff interval) |
| 277 | (if fixed |
| 278 | (let* ((missing (- interval diff)) |
| 279 | ;; If val2 > val1, try to increase val2 |
| 280 | ;; That's the "good direction" |
| 281 | (val2-good-direction |
| 282 | (if (> val2 val1) |
| 283 | (min max (+ val2 missing)) |
| 284 | (max min (- val2 missing)))) |
| 285 | (diff-val2-good-direction-val1 (abs (- val2-good-direction val1)))) |
| 286 | (if (>= diff-val2-good-direction-val1 interval) |
| 287 | (setq val2 val2-good-direction) |
| 288 | ;; Good-direction is not so good, compute bad-direction |
| 289 | (let* ((val2-bad-direction |
| 290 | (if (> val2 val1) |
| 291 | (max min (- val1 interval)) |
| 292 | (min max (+ val1 interval)))) |
| 293 | (diff-val2-bad-direction-val1 (abs (- val2-bad-direction val1)))) |
| 294 | (if (>= diff-val2-bad-direction-val1 interval) |
| 295 | (setq val2 val2-bad-direction) |
| 296 | ;; Still not good, pick the best and prefer good direction |
| 297 | (setq val2 |
| 298 | (if (>= diff-val2-good-direction-val1 diff-val2-bad-direction-val1) |
| 299 | val2-good-direction |
| 300 | val2-bad-direction)))))) |
| 301 | ;; No fixed, move val1 and val2 |
| 302 | (let ((missing (/ (- interval diff) 2.0))) |
| 303 | (if (< val1 val2) |
| 304 | (setq val1 (max min (- val1 missing)) |
| 305 | val2 (min max (+ val2 missing))) |
| 306 | (setq val2 (max min (- val2 missing)) |
| 307 | val1 (min max (+ val1 missing)))) |
| 308 | (setq diff (abs (- val1 val2))) ; Recompute diff |
| 309 | (unless (>= diff interval) |
| 310 | ;; Not ok, we hit a boundary |
| 311 | (let ((missing (- interval diff))) |
| 312 | (cond ((= val1 min) |
| 313 | (setq val2 (+ val2 missing))) |
| 314 | ((= val2 min) |
| 315 | (setq val1 (+ val1 missing))) |
| 316 | ((= val1 max) |
| 317 | (setq val2 (- val2 missing))) |
| 318 | ((= val2 max) |
| 319 | (setq val1 (- val1 missing))))))))) |
| 320 | (list val1 val2))) |
| 321 | |
| 322 | (defun shr-color-visible (bg fg &optional fixed-background) |
| 323 | "Check that BG and FG colors are visible if they are drawn on each other. |
| 324 | Return (bg fg) if they are. If they are too similar, two new |
| 325 | colors are returned instead. |
| 326 | If FIXED-BACKGROUND is set, and if the color are not visible, a |
| 327 | new background color will not be computed. Only the foreground |
| 328 | color will be adapted to be visible on BG." |
| 329 | ;; Convert fg and bg to CIE Lab |
| 330 | (let ((fg-norm (color-name-to-rgb fg)) |
| 331 | (bg-norm (color-name-to-rgb bg))) |
| 332 | (if (or (null fg-norm) |
| 333 | (null bg-norm)) |
| 334 | (list bg fg) |
| 335 | (let* ((fg-lab (apply 'color-srgb-to-lab fg-norm)) |
| 336 | (bg-lab (apply 'color-srgb-to-lab bg-norm)) |
| 337 | ;; Compute color distance using CIE DE 2000 |
| 338 | (fg-bg-distance (color-cie-de2000 fg-lab bg-lab)) |
| 339 | ;; Compute luminance distance (subtract L component) |
| 340 | (luminance-distance (abs (- (car fg-lab) (car bg-lab))))) |
| 341 | (if (and (>= fg-bg-distance shr-color-visible-distance-min) |
| 342 | (>= luminance-distance shr-color-visible-luminance-min)) |
| 343 | (list bg fg) |
| 344 | ;; Not visible, try to change luminance to make them visible |
| 345 | (let ((Ls (shr-color-set-minimum-interval |
| 346 | (car bg-lab) (car fg-lab) 0 100 |
| 347 | shr-color-visible-luminance-min fixed-background))) |
| 348 | (unless fixed-background |
| 349 | (setcar bg-lab (car Ls))) |
| 350 | (setcar fg-lab (cadr Ls)) |
| 351 | (list |
| 352 | (if fixed-background |
| 353 | bg |
| 354 | (apply 'format "#%02x%02x%02x" |
| 355 | (mapcar (lambda (x) (* (max (min 1 x) 0) 255)) |
| 356 | (apply 'color-lab-to-srgb bg-lab)))) |
| 357 | (apply 'format "#%02x%02x%02x" |
| 358 | (mapcar (lambda (x) (* (max (min 1 x) 0) 255)) |
| 359 | (apply 'color-lab-to-srgb fg-lab)))))))))) |
| 360 | |
| 361 | (provide 'shr-color) |
| 362 | |
| 363 | ;;; shr-color.el ends here |