Commit | Line | Data |
---|---|---|
ef6a2907 JD |
1 | ;;; shr-color.el --- Simple HTML Renderer color management |
2 | ||
3 | ;; Copyright (C) 2010 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-lab) | |
30 | ||
31 | (defgroup shr-color nil | |
32 | "Simple HTML Renderer colors" | |
33 | :group 'shr) | |
34 | ||
35 | (defcustom shr-color-visible-luminance-min 40 | |
36 | "Minimum luminance distance between two colors to be considered visible. | |
37 | Must be between 0 and 100." | |
38 | :group 'shr | |
39 | :type 'float) | |
40 | ||
41 | (defcustom shr-color-visible-distance-min 5 | |
42 | "Minimum color distance between two colors to be considered visible. | |
43 | This value is used to compare result for `ciede2000'. Its an | |
44 | absolute value without any unit." | |
45 | :group 'shr | |
46 | :type 'integer) | |
47 | ||
48 | (defun shr-color-relative-to-absolute (number) | |
49 | "Convert a relative NUMBER to absolute. If NUMBER is absolute, return NUMBER. | |
50 | This will convert \"80 %\" to 204, \"100 %\" to 255 but \"123\" to \"123\"." | |
51 | (let ((string-length (- (length number) 1))) | |
52 | ;; Is this a number with %? | |
53 | (if (eq (elt number string-length) ?%) | |
54 | (/ (* (string-to-number (substring number 0 string-length)) 255) 100) | |
55 | (string-to-number number)))) | |
56 | ||
57 | (defun shr-color-hsl-to-rgb-fractions (h s l) | |
58 | "Convert H S L to fractional RGB values." | |
59 | (let (m1 m2) | |
60 | (if (<= l 0.5) | |
61 | (setq m2 (* l (+ s 1))) | |
62 | (setq m2 (- (+ l s) (* l s)))) | |
63 | (setq m1 (- (* l 2) m2)) | |
64 | (list (rainbow-hue-to-rgb m1 m2 (+ h (/ 1 3.0))) | |
65 | (rainbow-hue-to-rgb m1 m2 h) | |
66 | (rainbow-hue-to-rgb m1 m2 (- h (/ 1 3.0)))))) | |
67 | ||
68 | (defun shr-color->hexadecimal (color) | |
69 | "Convert any color format to hexadecimal representation. | |
70 | Like rgb() or hsl()." | |
71 | (when color | |
72 | (cond ((or (string-match | |
73 | "rgb(\s*\\([0-9]\\{1,3\\}\\(?:\s*%\\)?\\)\s*,\s*\\([0-9]\\{1,3\\}\\(?:\s*%\\)?\\)\s*,\s*\\([0-9]\\{1,3\\}\\(?:\s*%\\)?\\)\s*)" | |
74 | color) | |
75 | (string-match | |
76 | "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*)" | |
77 | color)) | |
78 | (format "#%02X%02X%02X" | |
79 | (shr-color-relative-to-absolute (match-string-no-properties 1 color)) | |
80 | (shr-color-relative-to-absolute (match-string-no-properties 2 color)) | |
81 | (shr-color-relative-to-absolute (match-string-no-properties 3 color)))) | |
82 | ((or (string-match | |
83 | "hsl(\s*\\([0-9]\\{1,3\\}\\)\s*,\s*\\([0-9]\\{1,3\\}\\)\s*%\s*,\s*\\([0-9]\\{1,3\\}\\)\s*%\s*)" | |
84 | color) | |
85 | (string-match | |
86 | "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*)" | |
87 | color)) | |
88 | (let ((h (/ (string-to-number (match-string-no-properties 1 color)) 360.0)) | |
89 | (s (/ (string-to-number (match-string-no-properties 2 color)) 100.0)) | |
90 | (l (/ (string-to-number (match-string-no-properties 3 color)) 100.0))) | |
91 | (destructuring-bind (r g b) | |
92 | (rainbow-hsl-to-rgb-fractions h s l) | |
93 | (format "#%02X%02X%02X" (* r 255) (* g 255) (* b 255))))) | |
94 | (t | |
95 | color)))) | |
96 | ||
97 | (defun set-minimum-interval (val1 val2 min max interval &optional fixed) | |
98 | "Set minimum interval between VAL1 and VAL2 to INTERVAL. | |
99 | The values are bound by MIN and MAX. | |
100 | If FIXED is t, then val1 will not be touched." | |
101 | (let ((diff (abs (- val1 val2)))) | |
102 | (unless (>= diff interval) | |
103 | (if fixed | |
104 | (let* ((missing (- interval diff)) | |
105 | ;; If val2 > val1, try to increase val2 | |
106 | ;; That's the "good direction" | |
107 | (val2-good-direction | |
108 | (if (> val2 val1) | |
109 | (min max (+ val2 missing)) | |
110 | (max min (- val2 missing)))) | |
111 | (diff-val2-good-direction-val1 (abs (- val2-good-direction val1)))) | |
112 | (if (>= diff-val2-good-direction-val1 interval) | |
113 | (setq val2 val2-good-direction) | |
114 | ;; Good-direction is not so good, compute bad-direction | |
115 | (let* ((val2-bad-direction | |
116 | (if (> val2 val1) | |
117 | (max min (- val1 interval)) | |
118 | (min max (+ val1 interval)))) | |
119 | (diff-val2-bad-direction-val1 (abs (- val2-bad-direction val1)))) | |
120 | (if (>= diff-val2-bad-direction-val1 interval) | |
121 | (setq val2 val2-bad-direction) | |
122 | ;; Still not good, pick the best and prefer good direction | |
123 | (setq val2 | |
124 | (if (>= diff-val2-good-direction-val1 diff-val2-bad-direction-val1) | |
125 | val2-good-direction | |
126 | val2-bad-direction)))))) | |
127 | ;; No fixed, move val1 and val2 | |
128 | (let ((missing (/ (- interval diff) 2.0))) | |
129 | (if (< val1 val2) | |
130 | (setq val1 (max min (- val1 missing)) | |
131 | val2 (min max (+ val2 missing))) | |
132 | (setq val2 (max min (- val2 missing)) | |
133 | val1 (min max (+ val1 missing)))) | |
134 | (setq diff (abs (- val1 val2))) ; Recompute diff | |
135 | (unless (>= diff interval) | |
136 | ;; Not ok, we hit a boundary | |
137 | (let ((missing (- interval diff))) | |
138 | (cond ((= val1 min) | |
139 | (setq val2 (+ val2 missing))) | |
140 | ((= val2 min) | |
141 | (setq val1 (+ val1 missing))) | |
142 | ((= val1 max) | |
143 | (setq val2 (- val2 missing))) | |
144 | ((= val2 max) | |
145 | (setq val1 (- val1 missing))))))))) | |
146 | (list val1 val2))) | |
147 | ||
148 | (defun shr-color-visible (bg fg &optional fixed-background) | |
149 | "Check that BG and FG colors are visible if they are drawn on each other. | |
150 | Return t if they are. If they are too similar, two new colors are | |
151 | returned instead. | |
152 | If FIXED-BACKGROUND is set, and if the color are not visible, a | |
153 | new background color will not be computed. Only the foreground | |
154 | color will be adapted to be visible on BG." | |
155 | ;; Convert fg and bg to CIE Lab | |
156 | (let* ((fg-lab (apply 'rgb->lab (rgb->normalize fg))) | |
157 | (bg-lab (apply 'rgb->lab (rgb->normalize bg))) | |
158 | ;; Compute color distance using CIE DE 2000 | |
159 | (fg-bg-distance (color-lab-ciede2000 fg-lab bg-lab)) | |
160 | ;; Compute luminance distance (substract L component) | |
161 | (luminance-distance (abs (- (car fg-lab) (car bg-lab))))) | |
162 | (if (and (>= fg-bg-distance shr-color-visible-distance-min) | |
163 | (>= luminance-distance shr-color-visible-luminance-min)) | |
164 | (list bg fg) | |
165 | ;; Not visible, try to change luminance to make them visible | |
166 | (let ((Ls (set-minimum-interval (car bg-lab) (car fg-lab) 0 100 | |
167 | shr-color-visible-luminance-min | |
168 | fixed-background))) | |
169 | (setcar bg-lab (car Ls)) | |
170 | (setcar fg-lab (cadr Ls)) | |
171 | (list | |
172 | (apply 'format "#%02x%02x%02x" | |
173 | (mapcar (lambda (x) (* (max (min 1 x) 0) 255)) (apply 'lab->rgb bg-lab))) | |
174 | (apply 'format "#%02x%02x%02x" | |
175 | (mapcar (lambda (x) (* (max (min 1 x) 0) 255)) (apply 'lab->rgb fg-lab)))))))) | |
176 | ||
177 | (provide 'shr-color) | |
178 | ||
179 | ;;; shr-color.el ends here |