1 ;;; x-color.el --- X11 color definition support for SXEmacs
3 ;; Copyright (C) 2007 Nelson Ferreira
5 ;; Author: Nelson Ferreira
7 ;; Maintainer: SXEmacs Development Team
8 ;; Keywords: internal, dumped
10 ;; This file is part of SXEmacs.
12 ;; SXEmacs is free software: you can redistribute it and/or modify
13 ;; it under the terms of the GNU General Public License as published by
14 ;; the Free Software Foundation, either version 3 of the License, or
15 ;; (at your option) any later version.
17 ;; SXEmacs is distributed in the hope that it will be useful,
18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 ;; GNU General Public License for more details.
22 ;; You should have received a copy of the GNU General Public License
23 ;; along with this program. If not, see <http://www.gnu.org/licenses/>.
25 ;;; Synched up with: all the minibuffer history stuff is synched with
26 ;;; 19.30. Not sure about the rest.
30 ;; This file is dumped with SXEmacs.
34 (defvar x-library-search-path '("/usr/X11R7/lib/X11/"
40 "/usr/local/X11R7/lib/X11/"
41 "/usr/local/X11R6/lib/X11/"
42 "/usr/local/X11R5/lib/X11/"
43 "/usr/local/lib/X11R7/X11/"
44 "/usr/local/lib/X11R6/X11/"
45 "/usr/local/lib/X11R5/X11/")
46 "Search path used by `read-color' to find rgb.txt.")
48 (defvar x-color-slist nil "Map of color names and their RGB values")
50 (defun x-read-color-completion-table ()
51 "Color table for interactive completion"
52 (unless (and (skiplistp x-color-slist)
53 (> (skiplist-size x-color-slist) 0))
54 (x-color-read-system-colors))
56 (map-skiplist #'(lambda (key val)
57 (setq res (nconc res (list (list (format "%s" key))))))
61 (defun x-color-list ()
63 (unless (and (skiplistp x-color-slist)
64 (> (skiplist-size x-color-slist) 0))
65 (x-color-read-system-colors))
67 (map-skiplist #'(lambda (key val)
68 (setq res (nconc res (list (format "%s" key)))))
73 (defun find-color-rgb (name &optional nearest)
74 "Retrieve the color by NAME"
76 (x-color-rgb-components name))
78 (defun x-find-color-rgb (name &optional nearest)
79 "Retrieve the color by NAME"
80 (unless (or (symbolp name)
83 (error 'wrong-type-argument name))
84 (unless (and (skiplistp x-color-slist)
85 (> (skiplist-size x-color-slist) 0))
86 (x-color-read-system-colors))
87 (if (x-rgb-color-p name)
88 (list (x-rgb-color-red name)
89 (x-rgb-color-green name)
90 (x-rgb-color-blue name))
91 (let* ((color-name (if (symbolp name)
94 (color-sym (intern color-name))
95 (color-lc-sym (intern (downcase color-name)))
96 (color-ns-sym (intern (replace-in-string color-name " " "")))
97 (color-lcns-sym (intern (replace-in-string
100 (or (get-skiplist x-color-slist color-sym)
101 (get-skiplist x-color-slist color-lc-sym)
102 (get-skiplist x-color-slist color-ns-sym)
103 (get-skiplist x-color-slist color-lcns-sym)))))
107 (defun x-color-parse-rgb-components (color)
108 "Parse RGB color specification and return a list of integers (R G B).
109 #FEFEFE and rgb:fe/fe/fe style specifications are parsed.
110 Returns NIL if RGB color specification is invalid."
111 (let ((case-fold-search t)
113 (if (string-match #r"\([0-9.]+\)\s-+\([0-9.]+\)\s-+\([0-9.]+\)"
115 ;; recurse and parse hexadecimal color
116 (x-color-parse-rgb-components
117 (apply 'format "#%02X%02X%02X"
118 (mapcar #'(lambda (c) (if (floatp c) c (* 255 c)))
119 (mapcar #'(lambda (i)
122 (match-string i color))))
127 (when (cond ((string-match "^#[0-9a-f]+$" color)
128 (let* ((size (/ (1- (length color)) 3))
129 (dig-regex (format #r"\([0-9a-f]\{%s,%s\}\)"
131 ;; Check the intege division had no remainder
132 ;; which means no "odd" component sizes
133 (when (= (1+ (* 3 size)) (length color))
135 (concat "^#" dig-regex dig-regex dig-regex "$")
137 ((string-match #r"rgb:\([0-9a-f]+\)/\([0-9a-f]+\)/\([0-9a-f]+\)"
139 (setq matches (mapcar #'(lambda (i) (match-string i color))
141 ;; Make sure all components have at most 4 hex digits
144 (mapcar #'(lambda (component)
145 (> 5 (length component) 0))
147 (mapcar #'(lambda (component)
148 (* (expt 16 (- 4 (length component)))
149 (string-to-number component 16)))
152 (defsubst x-rgb-color-p (obj)
153 (or (and (vectorp obj)
155 (eq (aref obj 0) 'rgb))
162 (eq (nth 0 obj) 'rgb))))
164 (defsubst x-rgb-color-nth (n obj)
165 (or (and (vectorp obj)
167 (eq (aref obj 0) 'rgb)
177 (eq (nth 0 obj) 'rgb)
181 (defsubst x-rgb-color-red (obj) (x-rgb-color-nth 1 obj))
182 (defsubst x-rgb-color-green (obj) (x-rgb-color-nth 2 obj))
183 (defsubst x-rgb-color-blue (obj) (x-rgb-color-nth 3 obj))
185 (defun x-color-rgb-components (color)
186 "Return the RGB components of COLOR as a list of integers (R G B).
187 16-bit values are always returned.
188 #FEFEFE and rgb:fe/fe/fe style color specifications are parsed directly
189 into their components.
190 RGB values for color names are looked up using 'x-find-color-rgb'."
191 (let ((case-fold-search t)
193 (cond ((x-rgb-color-p color)
194 (mapcar #'(lambda (f)
196 (list 'x-rgb-color-red
199 ((and (vectorp color)
200 (= 3 (length color)))
201 (mapcar #'(lambda (p)
205 (= 3 (length color)))
207 (cond ((and color-rgb
209 (mapcar #'(lambda (c)
210 (and (numberp c) (<= 0 c 1)))
212 (mapcar #'(lambda (c) (* 65535 c)) color))
215 (mapcar #'(lambda (c)
216 (and (numberp c) (<= 0 c 255)))
218 (mapcar #'(lambda (c) (lsh c 8)) color))
221 (mapcar #'(lambda (c)
222 (and (numberp c) (<= 0 c 65535)))
225 ((and (stringp color)
226 (or (string-match #r"^\(#\|rgb:\)" color)
227 (string-match #r"[0-9.]+\s-+[0-9.]+\s-+[0-9.]+"
229 (x-color-parse-rgb-components color))
231 (x-find-color-rgb color)))))
233 (defun x-read-rgb-file (filename)
234 "Read the colors from FILENAME. The file is expected to have the same
235 format as X11 rgb.txt"
237 #r"^\s-*\([0-9]+\)\s-+\([0-9]+\)\s-+\([0-9]+\)\s-+\([a-zA-Z0-9 ]+\)\s-*$"))
238 (unless (skiplistp x-color-slist)
239 (setq x-color-slist (make-skiplist)))
240 (when (file-readable-p filename)
242 (set-buffer (or (get-file-buffer filename)
243 (create-file-buffer filename)))
245 (insert-file-contents-literally filename)
246 (if (not (= (aref (buffer-name) 0) ? ))
247 (rename-buffer (generate-new-buffer-name " *rgb-tmp-buffer*")))
251 (goto-char (point-min))
252 (while (re-search-forward rgb-regex nil t)
254 (mapcar #'(lambda (i)
255 (lsh (read (match-string i)) 8))
257 (color-name (match-string 4)))
258 (mapc #'(lambda (name)
259 (put-skiplist x-color-slist
263 (downcase color-name)
264 (replace-in-string color-name " " "")
265 (replace-in-string (downcase color-name)
268 (defun x-color-read-system-colors ()
269 "Read the system colors"
270 (when (locate-data-file "rgb.txt")
271 (x-read-rgb-file (locate-data-file "rgb.txt")))
272 (mapc 'x-read-rgb-file
273 (mapcar #'(lambda (dir)
274 (expand-file-name "rgb.txt" dir))
275 x-library-search-path))
279 (defun x-color-off-gray-diag (r g b)
280 "Compute the angle between the color given by R,G,B and the gray diagonal.
281 The gray diagonal is the diagonal of the 3D cube in RGB space which
282 connects the points corresponding to the black and white colors. All the
283 colors whose RGB coordinates belong to this diagonal are various shades
284 of gray, thus the name."
285 (let ((mag (sqrt (* 3 (+ (* r r) (* g g) (* b b))))))
286 (if (< mag 1) 0 (acos (/ (+ r g b) mag)))))
289 (defsubst x-rgb-to-8bits (rgb)
290 "Convert a 16-bit components rgb to an 8-bit components one."
291 (mapcar #'(lambda (c) (lsh c -8)) rgb))
293 (defsubst x-color-distance-2 (color1 color2)
294 "Return the color cube distance between the two colors as 8 bit rgb tupples."
295 (when (and color1 color2)
296 (unless (and (listp color1)
297 (= (length color1) 3))
298 (error 'wrong-type-argument color1))
299 (unless (and (listp color2)
300 (= (length color2) 3))
301 (error 'wrong-type-argument color2))
302 (let ((dR (- (car color1) (car color2)))
303 (dG (- (cadr color1) (cadr color2)))
304 (dB (- (caddr color1) (caddr color2))))
305 (+ (* dR dR) (* dG dG) (* dB dB)))))
308 (defsubst x-color-distance-1 (color1 color2)
309 "Return the color cube distance between the two colors.
310 Assumes COLOR1 is an 8 bit rgb tupple. "
311 ;; Verification is done in x-color-distance-2
312 (x-color-distance-2 color1
313 (x-rgb-to-8bits (x-color-rgb-components color2))))
316 (defun x-color-distance (color1 color2)
317 "Return the color cube distance between the two colors."
318 (x-color-distance-1 (x-rgb-to-8bits (x-color-rgb-components color1))
322 (defvar x-nearest-color-favor-non-gray-threshold 0.065
323 "If the approximated color is not close enough to the
324 gray diagonal of the RGB cube, favor non-gray colors.
325 The default number 0.065 is an empirical ad-hoc'ery")
327 (defun x-nearest-color (color &optional colorlist) "
328 Return the nearest COLOR in COLORLIST.
329 COLOR can be a color name, an '(r g b) tuple or a color specification.
330 #FEFEFE and rgb:fe/fe/fe style specifications are parsed.
331 COLORLIST is a list of colors in the same acceptable formats as COLOR.
332 Returns NIL if color specification is invalid, or no colors
333 close enough are found."
335 (when (or (stringp color) (symbolp color))
336 (setq color-rgb (x-rgb-to-8bits (find-color-rgb color))))
337 (when (not color-rgb)
338 (error 'invalid-argument color))
339 (let ((favor-non-gray (>= (apply 'x-color-off-gray-diag color-rgb)
340 x-nearest-color-favor-non-gray-threshold))
341 (best-distance 195076) ;; Max possible distance: 3 * 255^2 + 15
344 #'(lambda (candidate)
346 (let* ((cand-rgb (find-color-rgb candidate))
347 (distance (x-color-distance color-rgb cand-rgb)))
348 (if (and distance cand-rgb
349 (< distance best-distance)
350 ;; The candidate color is on the gray diagonal
351 ;; if its RGB components are all equal.
352 (or (/= (x-rgb-color-red cand-rgb)
353 (x-rgb-color-green cand-rgb))
354 (/= (x-rgb-color-green cand-rgb)
355 (x-rgb-color-blue cand-rgb))
356 (not favor-non-gray)))
357 (setq best-distance distance
358 best-color candidate)))))
359 (or colorlist (x-color-list)))
364 ;;; x-color.el ends here