Mercurial > emacs
comparison lisp/gnus/shr-color.el @ 111678:3b6c0c4ef2bb
shr.el (shr-tag-color-check): Convert colors to hexadecimal with shr-color->hexadecimal.
shr-color.el (shr-color->hexadecimal): Add converting functions for RGB() or HSL() color representation.
shr.el (shr-tag-font): Add.
(shr-tag-color-check): New function to get better colors.
(shr-tag-insert-color-overlay): Factorize code between tag-font and tag-span.
shr-color.el: New file.
color-lab.el: New file.
author | Katsumi Yamaoka <yamaoka@jpl.org> |
---|---|
date | Tue, 23 Nov 2010 00:03:44 +0000 |
parents | |
children | 01aefe45207c |
comparison
equal
deleted
inserted
replaced
111677:fe9fcbca8f4e | 111678:3b6c0c4ef2bb |
---|---|
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 |