New org capture template
[emacs.git] / .emacs.d / elisp / icicle / hexrgb.el
1 ;;; hexrgb.el --- Functions to manipulate colors, including RGB hex strings.
2 ;;
3 ;; Filename: hexrgb.el
4 ;; Description: Functions to manipulate colors, including RGB hex strings.
5 ;; Author: Drew Adams
6 ;; Maintainer: Drew Adams (concat "drew.adams" "@" "oracle" ".com")
7 ;; Copyright (C) 2004-2014, Drew Adams, all rights reserved.
8 ;; Created: Mon Sep 20 22:58:45 2004
9 ;; Version: 0
10 ;; Package-Requires: ()
11 ;; Last-Updated: Thu Dec 26 09:06:37 2013 (-0800)
12 ;; By: dradams
13 ;; Update #: 957
14 ;; URL: http://www.emacswiki.org/hexrgb.el
15 ;; Doc URL: http://www.emacswiki.org/SetColor
16 ;; Doc URL: http://emacswiki.org/ColorPalette
17 ;; Keywords: number, hex, rgb, color, background, frames, display
18 ;; Compatibility: GNU Emacs: 20.x, 21.x, 22.x, 23.x, 24.x
19 ;;
20 ;; Features that might be required by this library:
21 ;;
22 ;; None
23 ;;
24 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
25 ;;
26 ;;; Commentary:
27 ;;
28 ;; Functions to manipulate colors, including RGB hex strings.
29 ;;
30 ;; This library provides functions for converting between RGB (red,
31 ;; green, blue) color components and HSV (hue, saturation, value)
32 ;; color components. It helps you convert among Emacs color
33 ;; components (whole numbers from 0 through 65535), RGB and HSV
34 ;; floating-point components (0.0 through 1.0), Emacs color-name
35 ;; strings (such as "blue"), and hex RGB color strings (such as
36 ;; "#FC43A7912").
37 ;;
38 ;; An RGB hex string, such as used as a frame `background-color'
39 ;; property, is a string of 1 + (3 * n) characters, the first of
40 ;; which is "#". The other characters are hexadecimal digits, in
41 ;; three groups representing (from the left): red, green, and blue
42 ;; hex codes.
43 ;;
44 ;; Constants defined here:
45 ;;
46 ;; `hexrgb-defined-colors', `hexrgb-defined-colors-alist',
47 ;; `hexrgb-defined-colors-no-dups',
48 ;; `hexrgb-defined-colors-no-dups-alist'.
49 ;;
50 ;; Options defined here:
51 ;;
52 ;; `hexrgb-canonicalize-defined-colors-flag'.
53 ;;
54 ;; Commands defined here:
55 ;;
56 ;; `hexrgb-blue', `hexrgb-complement', `hexrgb-green',
57 ;; `hexrgb-hue', `hexrgb-read-color', `hexrgb-red',
58 ;; `hexrgb-saturation', `hexrgb-value'.
59 ;;
60 ;; Non-interactive functions defined here:
61 ;;
62 ;; `hexrgb-approx-equal', `hexrgb-canonicalize-defined-colors',
63 ;; `hexrgb-color-name-to-hex', `hexrgb-color-values-to-hex',
64 ;; `hexrgb-color-value-to-float', `hexrgb-defined-colors',
65 ;; `hexrgb-defined-colors-alist',
66 ;; `hexrgb-delete-whitespace-from-string',
67 ;; `hexrgb-float-to-color-value', `hexrgb-hex-char-to-integer',
68 ;; `hexrgb-hex-to-color-values', `hexrgb-hex-to-hex',
69 ;; `hexrgb-hex-to-hsv', `hexrgb-hex-to-rgb', `hexrgb-hsv-to-hex',
70 ;; `hexrgb-hex-to-int', `hexrgb-hsv-to-rgb',
71 ;; `hexrgb-increment-blue', `hexrgb-increment-equal-rgb',
72 ;; `hexrgb-increment-green', `hexrgb-increment-hex',
73 ;; `hexrgb-increment-hue', `hexrgb-increment-red',
74 ;; `hexrgb-increment-saturation', `hexrgb-increment-value',
75 ;; `hexrgb-int-to-hex', `hexrgb-blue-hex', `hexrgb-green-hex',
76 ;; `hexrgb-red-hex', `hexrgb-rgb-hex-string-p',
77 ;; `hexrgb-rgb-hex-to-rgb-hex', `hexrgb-rgb-to-hex',
78 ;; `hexrgb-rgb-to-hsv'.
79 ;;
80 ;;
81 ;; Add this to your initialization file (~/.emacs or ~/_emacs):
82 ;;
83 ;; (require 'hexrgb)
84 ;;
85 ;; Do not try to use this library without a window manager.
86 ;; That is, do not use this with `emacs -nw'.
87 ;;
88 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
89 ;;
90 ;;; Change Log:
91 ;;
92 ;;
93 ;; 2013/01/18 dadams
94 ;; Added: hexrgb-increment-(hue|saturation|value): Moved them here and renamed from
95 ;; icicle-increment-color-*. Changed range to 0-1 and added optional arg NB-DIGITS.
96 ;; 2012/12/16 dadams
97 ;; hexrgb-(hsv|rgb|color-name|color-values)-to-hex: Added optional arg NB-DIGITS.
98 ;; 2012/03/17 dadams
99 ;; Added: hexrgb-(red|green|blue-hex, hexrgb-rgb-hex-to-rgb-hex, hexrgb-hex-to-hex.
100 ;; 2012/01/05 dadams
101 ;; hexrgb-complement: Added optional arg MSG-P.
102 ;; Some doc-string cleanup.
103 ;; 2011/11/26 dadams
104 ;; hexrgb-read-color: Changed arg order to match vanilla Emacs read-color. Added MSGP.
105 ;; *** THIS IS AN INCOMPATIBLE CHANGE. IF YOU USE THIS FUNCTION THEN UPDATE YOUR CODE. ***
106 ;; 2011/02/16 dadams
107 ;; hexrgb-increment-hex: INCOMPATIBLE CHANGE:
108 ;; Swapped order of args NB-DIGITS, INCREMENT, to fit other functions.
109 ;; hexrgb-increment-*: Took the change to hexrgb-increment-hex into account.
110 ;; Improved various doc strings.
111 ;; 2011/01/08 dadams
112 ;; Restored autoload cookie for eval-and-compile hexrgb-canonicalize-defined-colors.
113 ;; 2011/01/03 dadams
114 ;; Removed autoload cookies from non-interactive functions.
115 ;; 2010/12/18 dadams
116 ;; hexrgb-canonicalize-defined-colors: Added autoload cookie. Thx to Richard Kim.
117 ;; 2010/12/06 dadams
118 ;; hexrgb-hex-to-color-values: Correct start offset for blue. Thx to "Linda" on Emacs Wiki.
119 ;; 2009/11/14 dadams
120 ;; hexrgb-rgb-to-hsv: Corrected hue when > 1.0. Use strict inequality for hue limit tests.
121 ;; hexrgb-approx-equal: Convert RFUZZ and AFUZZ to their absolute values.
122 ;; 2009/11/03 dadams
123 ;; Added: hexrgb-delete-whitespace-from-string, hexrgb-canonicalize-defined-colors,
124 ;; hexrgb-defined-colors(-no-dups)(-alist), hexrgb-canonicalize-defined-colors-flag.
125 ;; hexrgb-read-color: Use function hexrgb-defined-colors-alist, not the constant.
126 ;; 2008/12/25 dadams
127 ;; hexrgb-rgb-to-hsv:
128 ;; Replace (not (equal 0.0e+NaN saturation)) by standard test (= saturation saturation).
129 ;; Thx to Michael Heerdegen for the bug report.
130 ;; 2008-10-17 dadams
131 ;; hexrgb-defined-colors(-alist): Prevent load-time error if user tries to use emacs -nw.
132 ;; 2007/12/30 dadams
133 ;; Added: hexrgb-hex-to-color-values.
134 ;; 2007/10/20 dadams
135 ;; hexrgb-read-color: Treat pseudo colors too (e.g. *point foreground*).
136 ;; 2007/01/21 dadams
137 ;; hexrgb-read-color: Error if empty string (and not allow-empty-name-p).
138 ;; 2006/06/06 dadams
139 ;; Added: hexrgb-defined-colors(-alist). Use instead of (x-defined-colors).
140 ;; hexrgb-(red|green|blue): Added interactive specs.
141 ;; 2006/06/04 dadams
142 ;; hexrgb-read-color: Added optional arg allow-empty-name-p.
143 ;; 2006/06/02 dadams
144 ;; Added: hexrgb-rgb-hex-string-p. Used it.
145 ;; 2006/05/30 dadams
146 ;; Added: hexrgb-hex-to-(hsv|rgb), hexrgb-hsv-to-hex, hexrgb-color-name-to-hex,
147 ;; hexrgb-complement, hexrgb-read-color, hexrgb-hue, hexrgb-saturation,
148 ;; hexrgb-value, hexrgb-red, hexrgb-blue, hexrgb-green.
149 ;; approx-equal: Add optional fuzz factor arguments. Changed the algorithm.
150 ;; Renamed: approx-equal to hexrgb-approx-equal.
151 ;; hexrgb-rgb-to-hsv: Changed test from < to <=: (when (<= hue 0.0)...).
152 ;; hexrgb-hsv-to-rgb: Treat hue = 0.0 (int 0) the same as hue = 1.0 (int 6).
153 ;; hexrgb-rgb-to-hex, hexrgb-increment-hex: Corrected doc strings.
154 ;; 2006/05/22 dadams
155 ;; Added: hexrgb-hsv-to-hex, hexrgb-rgb-to-hex. Require cl.el when byte-compile.
156 ;; 2005/08/09 dadams
157 ;; hexrgb-rgb-to-hsv: Side-stepped Emacs-20 bug in comparing NaN.
158 ;; hexrgb-increment-*: Added optional arg wrap-p.
159 ;; hexrgb-increment-hex: Prevent wrap if not wrap-p.
160 ;; 2005/08/02 dadams
161 ;; hexrgb-rgb-to-hes: Bug fix: If delta is zero, then so are hue and saturation.
162 ;; 2005/06/24 dadams
163 ;; hexrgb-rgb-to-hsv: Bug fix: test for NaN (e.g. on divide by zero).
164 ;; 2005/02/08 dadams
165 ;; hexrgb-hsv-to-rgb: Bug fix (typo: p, q -> pp, qq; added ww).
166 ;; 2005/01/09 dadams
167 ;; hexrgb-int-to-hex: Fixed bug in hexrgb-int-to-hex: nb-digits not respected.
168 ;; Added: hexrgb-hsv-to-rgb, hexrgb-rgb-to-hsv, approx-equal.
169 ;; Renamed old hexrgb-increment-value to hexrgb-increment-equal-rgb.
170 ;; 2005/01/05 dadams
171 ;; hexrgb-int-to-hex: Used a suggestion from Juri Linkov.
172 ;;
173 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
174 ;;
175 ;; This program is free software; you can redistribute it and/or modify
176 ;; it under the terms of the GNU General Public License as published by
177 ;; the Free Software Foundation; either version 2, or (at your option)
178 ;; any later version.
179
180 ;; This program is distributed in the hope that it will be useful,
181 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
182 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
183 ;; GNU General Public License for more details.
184
185 ;; You should have received a copy of the GNU General Public License
186 ;; along with this program; see the file COPYING. If not, write to
187 ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth
188 ;; Floor, Boston, MA 02110-1301, USA.
189 ;;
190 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
191 ;;
192 ;;; Code:
193
194 (eval-when-compile (require 'cl)) ;; case
195
196 ;; Unless you first load `hexrgb.el', then either `palette.el' or `eyedropper.el', you will get
197 ;; warnings about variables and functions with prefix `eyedrop-' when you byte-compile
198 ;; `hexrgb.el'. You can ignore these warnings.
199
200 (defvar eyedrop-picked-foreground)
201 (defvar eyedrop-picked-background)
202
203 ;;;;;;;;;;;;;;;;;;;;;;;;;;;
204
205 ;;;###autoload
206 (eval-and-compile
207 (defun hexrgb-canonicalize-defined-colors (list)
208 "Copy of LIST with color names canonicalized.
209 LIST is a list of color names (strings).
210 Canonical names are lowercase, with no whitespace.
211 There are no duplicate names."
212 (let ((tail list)
213 this new)
214 (while tail
215 (setq this (car tail)
216 this (hexrgb-delete-whitespace-from-string (downcase this) 0 (length this)))
217 (unless (member this new) (push this new))
218 (pop tail))
219 (nreverse new)))
220
221 (defun hexrgb-delete-whitespace-from-string (string &optional from to)
222 "Remove whitespace from substring of STRING from FROM to TO.
223 If FROM is nil, then start at the beginning of STRING (FROM = 0).
224 If TO is nil, then end at the end of STRING (TO = length of STRING).
225 FROM and TO are zero-based indexes into STRING.
226 Character FROM is affected (possibly deleted). Character TO is not."
227 (setq from (or from 0)
228 to (or to (length string)))
229 (with-temp-buffer
230 (insert string)
231 (goto-char (+ from (point-min)))
232 (let ((count from)
233 char)
234 (while (and (not (eobp)) (< count to))
235 (setq char (char-after))
236 (if (memq char '(?\ ?\t ?\n)) (delete-char 1) (forward-char 1))
237 (setq count (1+ count)))
238 (buffer-string)))))
239
240 ;;;###autoload
241 (defconst hexrgb-defined-colors (eval-when-compile (and window-system (x-defined-colors)))
242 "List of all supported colors.")
243
244 ;;;###autoload
245 (defconst hexrgb-defined-colors-no-dups
246 (eval-when-compile
247 (and window-system (hexrgb-canonicalize-defined-colors (x-defined-colors))))
248 "List of all supported color names, with no duplicates.
249 Names are all lowercase, without any spaces.")
250
251 ;;;###autoload
252 (defconst hexrgb-defined-colors-alist
253 (eval-when-compile (and window-system (mapcar #'list (x-defined-colors))))
254 "Alist of all supported color names, for use in completion.
255 See also `hexrgb-defined-colors-no-dups-alist', which is the same
256 thing, but without any duplicates, such as \"light blue\" and
257 \"LightBlue\".")
258
259 ;;;###autoload
260 (defconst hexrgb-defined-colors-no-dups-alist
261 (eval-when-compile
262 (and window-system
263 (mapcar #'list (hexrgb-canonicalize-defined-colors (x-defined-colors)))))
264 "Alist of all supported color names, with no duplicates, for completion.
265 Names are all lowercase, without any spaces.")
266
267 ;;;###autoload
268 (defcustom hexrgb-canonicalize-defined-colors-flag t
269 "*Non-nil means remove duplicate color names.
270 Names are considered duplicates if they are the same when abstracting
271 from whitespace and letter case."
272 :type 'boolean
273 :group 'Icicles :group 'doremi-frame-commands :group 'faces :group 'convenience)
274
275 ;; You should use these two functions, not the constants, so users can change
276 ;; the behavior by customizing `hexrgb-canonicalize-defined-colors-flag'.
277
278 (defun hexrgb-defined-colors ()
279 "List of supported color names.
280 If `hexrgb-canonicalize-defined-colors-flag' is non-nil, then names
281 are lowercased, whitespace is removed, and there are no duplicates."
282 (if hexrgb-canonicalize-defined-colors-flag
283 hexrgb-defined-colors-no-dups
284 hexrgb-defined-colors))
285
286 (defun hexrgb-defined-colors-alist ()
287 "Alist of supported color names. Usable for completion.
288 If `hexrgb-canonicalize-defined-colors-flag' is non-nil, then names
289 are lowercased, whitespace is removed, and there are no duplicates."
290 (if hexrgb-canonicalize-defined-colors-flag
291 hexrgb-defined-colors-no-dups-alist
292 hexrgb-defined-colors-alist))
293
294 ;; RMS added this function to Emacs (23) as `read-color', with some feature loss.
295 ;;;###autoload
296 (defun hexrgb-read-color (&optional prompt convert-to-RGB-p allow-empty-name-p msgp)
297 "Read a color name or hex RGB hexadecimal color value #RRRRGGGGBBBB.
298 Completion is available for color names, but not for RGB hex strings.
299 If you input an RGB hex string, it must have the form #XXXXXXXXXXXX or
300 XXXXXXXXXXXX, where each X is a hex digit. The number of Xs must be a
301 multiple of 3, with the same number of Xs for each of red, green, and
302 blue. The order is red, green, blue.
303
304 Color names that are normally considered equivalent are canonicalized:
305 They are lowercased, whitespace is removed, and duplicates are
306 eliminated. E.g. \"LightBlue\" and \"light blue\" are both replaced
307 by \"lightblue\". If you do not want this behavior, but want to
308 choose names that might contain whitespace or uppercase letters, then
309 customize option `hexrgb-canonicalize-defined-colors-flag' to nil.
310
311 In addition to standard color names and RGB hex values, the following
312 are available as color candidates. In each case, the corresponding
313 color is used.
314
315 * `*copied foreground*' - last copied foreground, if available
316 * `*copied background*' - last copied background, if available
317 * `*mouse-2 foreground*' - foreground where you click `mouse-2'
318 * `*mouse-2 background*' - background where you click `mouse-2'
319 * `*point foreground*' - foreground under the cursor
320 * `*point background*' - background under the cursor
321
322 \(You can copy a color using eyedropper commands such as
323 `eyedrop-pick-foreground-at-mouse'.)
324
325 Optional arg PROMPT is the prompt - nil means use a default prompt.
326
327 Checks input to be sure it represents a valid color. If not, raises
328 an error (but see exception for empty input with non-nil
329 ALLOW-EMPTY-NAME-P).
330
331 Interactively, or with optional arg CONVERT-TO-RGB-P non-nil, converts
332 an input color name to an RGB hex string. Returns the RGB hex string.
333
334 Optional arg ALLOW-EMPTY-NAME-P controls what happens if you enter an
335 empty color name (that is, you just hit `RET'). If non-nil, then
336 `hexrgb-read-color' returns an empty color name, \"\". If nil, then
337 it raises an error. Calling programs must test for \"\" if
338 ALLOW-EMPTY-NAME-P is non-nil. They can then perform an appropriate
339 action in case of empty input.
340
341 Interactively, or with non-nil MSGP, show color name in the echo area."
342 (interactive "i\np\ni\np") ; Always convert to RGB interactively.
343 (let* ((completion-ignore-case t)
344 ;; Free variables here: `eyedrop-picked-foreground', `eyedrop-picked-background'.
345 ;; They are defined in library `palette.el' or library `eyedropper.el'.
346 (colors (if (fboundp 'eyedrop-foreground-at-point)
347 (append (and eyedrop-picked-foreground
348 '(("*copied foreground*")))
349 (and eyedrop-picked-background
350 '(("*copied background*")))
351 '(("*mouse-2 foreground*")
352 ("*mouse-2 background*")
353 ("*point foreground*") ("*point background*"))
354 (hexrgb-defined-colors-alist))
355 (hexrgb-defined-colors-alist)))
356 (color (completing-read (or prompt "Color (name or #R+G+B+): ")
357 colors))
358 hex-string)
359 (when (fboundp 'eyedrop-foreground-at-point)
360 (cond ((string= "*copied foreground*" color) (setq color eyedrop-picked-foreground))
361 ((string= "*copied background*" color) (setq color eyedrop-picked-background))
362 ((string= "*point foreground*" color) (setq color (eyedrop-foreground-at-point)))
363 ((string= "*point background*" color) (setq color (eyedrop-background-at-point)))
364 ((string= "*mouse-2 foreground*" color)
365 (setq color (prog1 (eyedrop-foreground-at-mouse
366 (read-event "Click `mouse-2' to choose foreground color - "))
367 (read-event)))) ; Discard mouse up event.
368 ((string= "*mouse-2 background*" color)
369 (setq color (prog1 (eyedrop-background-at-mouse
370 (read-event "Click `mouse-2' to choose background color - "))
371 (read-event)))))) ; Discard mouse up event.
372 (setq hex-string (or (string-match "^#\\([a-fA-F0-9][a-fA-F0-9][a-fA-F0-9]\\)+$" color)
373 (and (string-match "^\\([a-fA-F0-9][a-fA-F0-9][a-fA-F0-9]\\)+$" color)
374 t)))
375 (if (and allow-empty-name-p (string= "" color))
376 ""
377 (when (and hex-string (not (eq 0 hex-string)))
378 (setq color (concat "#" color))) ; No #; add it.
379 (unless hex-string
380 (when (or (string= "" color)
381 (not (if (fboundp 'test-completion) ; Not defined in Emacs 20.
382 (test-completion color colors)
383 (try-completion color colors))))
384 (error "No such color: %S" color))
385 (when convert-to-RGB-p (setq color (hexrgb-color-name-to-hex color))))
386 (when msgp (message "Color: `%s'" color))
387 color)))
388
389 (defun hexrgb-rgb-hex-string-p (color &optional laxp)
390 "Non-nil if COLOR is an RGB string #XXXXXXXXXXXX.
391 Each X is a hex digit. The number of Xs must be a multiple of 3, with
392 the same number of Xs for each of red, green, and blue.
393
394 Non-nil optional arg LAXP means that the initial `#' is optional. In
395 that case, for a valid string of hex digits: when # is present 0 is
396 returned; otherwise, t is returned."
397 (or (string-match "^#\\([a-fA-F0-9][a-fA-F0-9][a-fA-F0-9]\\)+$" color)
398 (and laxp (string-match "^\\([a-fA-F0-9][a-fA-F0-9][a-fA-F0-9]\\)+$" color) t)))
399
400 ;;;###autoload
401 (defun hexrgb-complement (color &optional msg-p)
402 "Return the color that is the complement of COLOR.
403 Non-interactively, non-nil optional arg MSG-P means show a message
404 with the complement."
405 (interactive (list (hexrgb-read-color) t))
406 (setq color (hexrgb-color-name-to-hex color))
407 (let ((red (hexrgb-red color))
408 (green (hexrgb-green color))
409 (blue (hexrgb-blue color)))
410 (setq color (hexrgb-rgb-to-hex (- 1.0 red) (- 1.0 green) (- 1.0 blue))))
411 (when msg-p (message "Complement: `%s'" color))
412 color)
413
414 ;;;###autoload
415 (defun hexrgb-hue (color)
416 "Return the hue component of COLOR, in range 0 to 1 inclusive.
417 COLOR is a color name or hex RGB string that starts with \"#\"."
418 (interactive (list (hexrgb-read-color)))
419 (setq color (hexrgb-color-name-to-hex color))
420 (car (hexrgb-rgb-to-hsv (hexrgb-red color) (hexrgb-green color) (hexrgb-blue color))))
421
422 ;;;###autoload
423 (defun hexrgb-saturation (color)
424 "Return the saturation component of COLOR, in range 0 to 1 inclusive.
425 COLOR is a color name or hex RGB string that starts with \"#\"."
426 (interactive (list (hexrgb-read-color)))
427 (setq color (hexrgb-color-name-to-hex color))
428 (cadr (hexrgb-rgb-to-hsv (hexrgb-red color) (hexrgb-green color) (hexrgb-blue color))))
429
430 ;;;###autoload
431 (defun hexrgb-value (color)
432 "Return the value component of COLOR, in range 0 to 1 inclusive.
433 COLOR is a color name or hex RGB string that starts with \"#\"."
434 (interactive (list (hexrgb-read-color)))
435 (setq color (hexrgb-color-name-to-hex color))
436 (caddr (hexrgb-rgb-to-hsv (hexrgb-red color) (hexrgb-green color) (hexrgb-blue color))))
437
438 ;;;###autoload
439 (defun hexrgb-red (color)
440 "Return the red component of COLOR, in range 0 to 1 inclusive.
441 COLOR is a color name or hex RGB string that starts with \"#\"."
442 (interactive (list (hexrgb-read-color)))
443 (setq color (hexrgb-color-name-to-hex color))
444 (/ (hexrgb-hex-to-int (substring color 1 (1+ (/ (1- (length color)) 3))))
445 (expt 16.0 (/ (1- (length color)) 3.0))))
446
447 ;;;###autoload
448 (defun hexrgb-green (color)
449 "Return the green component of COLOR, in range 0 to 1 inclusive.
450 COLOR is a color name or hex RGB string that starts with \"#\"."
451 (interactive (list (hexrgb-read-color)))
452 (setq color (hexrgb-color-name-to-hex color))
453 (let* ((len (/ (1- (length color)) 3))
454 (start (1+ len)))
455 (/ (hexrgb-hex-to-int (substring color start (+ start len)))
456 (expt 16.0 (/ (1- (length color)) 3.0)))))
457
458 ;;;###autoload
459 (defun hexrgb-blue (color)
460 "Return the blue component of COLOR, in range 0 to 1 inclusive.
461 COLOR is a color name or hex RGB string that starts with \"#\"."
462 (interactive (list (hexrgb-read-color)))
463 (setq color (hexrgb-color-name-to-hex color))
464 (let* ((len (/ (1- (length color)) 3))
465 (start (+ 1 len len)))
466 (/ (hexrgb-hex-to-int (substring color start (+ start len)))
467 (expt 16.0 (/ (1- (length color)) 3.0)))))
468
469 (defun hexrgb-rgb-to-hsv (red green blue)
470 "Convert RED, GREEN, BLUE components to HSV (hue, saturation, value).
471 Each input component is 0.0 to 1.0, inclusive.
472 Returns a list of HSV components of value 0.0 to 1.0, inclusive."
473 (let* ((min (min red green blue))
474 (max (max red green blue))
475 (value max)
476 (delta (- max min))
477 hue saturation)
478 (if (hexrgb-approx-equal 0.0 delta)
479 (setq hue 0.0
480 saturation 0.0) ; Gray scale - no color; only value.
481 (if (and (condition-case nil
482 (setq saturation (/ delta max))
483 (arith-error nil))
484 ;; Must be a number, not a NaN. The standard test for a NaN is (not (= N N)),
485 ;; but an Emacs 20 bug makes (= N N) return t for a NaN also.
486 (or (< emacs-major-version 21) (= saturation saturation)))
487 (if (hexrgb-approx-equal 0.0 saturation)
488 (setq hue 0.0
489 saturation 0.0) ; Again, no color; only value.
490 ;; Color
491 (setq hue (if (hexrgb-approx-equal red max)
492 (/ (- green blue) delta) ; Between yellow & magenta.
493 (if (hexrgb-approx-equal green max)
494 (+ 2.0 (/ (- blue red) delta)) ; Between cyan & yellow.
495 (+ 4.0 (/ (- red green) delta)))) ; Between magenta & cyan.
496 hue (/ hue 6.0))
497 ;; (when (<= hue 0.0) (setq hue (+ hue 1.0))) ; $$$$$$
498 ;; (when (>= hue 1.0) (setq hue (- hue 1.0)))) ; $$$$$$
499 (when (< hue 0.0) (setq hue (+ hue 1.0)))
500 (when (> hue 1.0) (setq hue (- hue 1.0))))
501 (setq hue 0.0 ; Div by zero (max=0): H:=0, S:=0. (Hue undefined.)
502 saturation 0.0)))
503 (list hue saturation value)))
504
505 (defun hexrgb-hsv-to-rgb (hue saturation value)
506 "Convert HUE, SATURATION, VALUE components to RGB (red, green, blue).
507 Each input component is 0.0 to 1.0, inclusive.
508 Returns a list of RGB components of value 0.0 to 1.0, inclusive."
509 (let (red green blue int-hue fract pp qq tt ww)
510 (if (hexrgb-approx-equal 0.0 saturation)
511 (setq red value
512 green value
513 blue value) ; Gray
514 (setq hue (* hue 6.0) ; Sectors: 0 to 5
515 int-hue (floor hue)
516 fract (- hue int-hue)
517 pp (* value (- 1 saturation))
518 qq (* value (- 1 (* saturation fract)))
519 ww (* value (- 1 (* saturation (- 1 (- hue int-hue))))))
520 (case int-hue
521 ((0 6) (setq red value
522 green ww
523 blue pp))
524 (1 (setq red qq
525 green value
526 blue pp))
527 (2 (setq red pp
528 green value
529 blue ww))
530 (3 (setq red pp
531 green qq
532 blue value))
533 (4 (setq red ww
534 green pp
535 blue value))
536 (otherwise (setq red value
537 green pp
538 blue qq))))
539 (list red green blue)))
540
541 (defun hexrgb-hsv-to-hex (hue saturation value &optional nb-digits)
542 "Return the hex RBG color string for inputs HUE, SATURATION, VALUE.
543 These inputs are each in the range 0 to 1.
544 Optional arg NB-DIGITS is the number of hex digits per component,
545 default: 4.
546 The output string is `#' followed by `nb-digits' hex digits for each
547 color component. So for the default `nb-digits' value of 4, the form
548 is \"#RRRRGGGGBBBB\"."
549 (setq nb-digits (or nb-digits 4))
550 (hexrgb-color-values-to-hex
551 (mapcar (lambda (x) (floor (* x 65535.0))) (hexrgb-hsv-to-rgb hue saturation value))
552 nb-digits))
553
554 (defun hexrgb-rgb-to-hex (red green blue &optional nb-digits)
555 "Return the hex RBG color string for inputs RED, GREEN, BLUE.
556 These inputs are each in the range 0 to 1.
557 Optional arg NB-DIGITS is the number of hex digits per component,
558 default: 4.
559 The output string is `#' followed by `nb-digits' hex digits for each
560 color component. So for the default `nb-digits' value of 4, the form
561 is \"#RRRRGGGGBBBB\"."
562 (setq nb-digits (or nb-digits 4))
563 (hexrgb-color-values-to-hex
564 (mapcar (lambda (x) (floor (* x 65535.0))) (list red green blue))
565 nb-digits))
566
567 (defun hexrgb-hex-to-hsv (color)
568 "Return a list of HSV (hue, saturation, value) color components.
569 Each component is a value from 0.0 to 1.0, inclusive.
570 COLOR is a color name or a hex RGB string that starts with \"#\" and
571 is followed by an equal number of hex digits for red, green, and blue
572 components."
573 (let ((rgb-components (hexrgb-hex-to-rgb color)))
574 (apply #'hexrgb-rgb-to-hsv rgb-components)))
575
576 (defun hexrgb-hex-to-rgb (color)
577 "Return a list of RGB (red, green, blue) color components.
578 Each component is a value from 0.0 to 1.0, inclusive.
579 COLOR is a color name or a hex RGB string that starts with \"#\" and
580 is followed by an equal number of hex digits for red, green, and blue
581 components."
582 (unless (hexrgb-rgb-hex-string-p color) (setq color (hexrgb-color-name-to-hex color)))
583 (let ((len (/ (1- (length color)) 3)))
584 (list (/ (hexrgb-hex-to-int (substring color 1 (1+ len))) 65535.0)
585 (/ (hexrgb-hex-to-int (substring color (1+ len) (+ 1 len len))) 65535.0)
586 (/ (hexrgb-hex-to-int (substring color (+ 1 len len))) 65535.0))))
587
588 (defun hexrgb-color-name-to-hex (color &optional nb-digits)
589 "Return the RGB hex string, starting with \"#\", for the COLOR name.
590 If COLOR is already a string starting with \"#\", then just return it.
591 Optional arg NB-DIGITS is the number of hex digits per component,
592 default: 4.
593 \(This function relies on `x-color-values', which generally returns
594 integers corresponding to 4 hex digits, so you probably do not want to
595 pass an NB-DIGITS value greater than 4.)
596 The output string is `#' followed by `nb-digits' hex digits for each
597 color component. So for the default `nb-digits' value of 4, the form
598 is \"#RRRRGGGGBBBB\"."
599 (setq nb-digits (or nb-digits 4))
600 (let ((components (x-color-values color)))
601 (unless components (error "No such color: %S" color))
602 (unless (hexrgb-rgb-hex-string-p color)
603 (setq color (hexrgb-color-values-to-hex components nb-digits))))
604 color)
605
606 ;; Color "components" would be better in the name than color "value"
607 ;; but this name follows the Emacs tradition (e.g. `x-color-values',
608 ;; 'ps-color-values', `ps-e-x-color-values').
609 (defun hexrgb-color-values-to-hex (components &optional nb-digits)
610 "Convert list of rgb color COMPONENTS to a hex RBG color string.
611 Each X in the string is a hexadecimal digit.
612 Input COMPONENTS is as for the output of `x-color-values'.
613 Optional arg NB-DIGITS is the number of hex digits per component,
614 default: 4.
615 The output string is `#' followed by `nb-digits' hex digits for each
616 color component. So for the default `nb-digits' value of 4, the form
617 is \"#RRRRGGGGBBBB\"."
618 ;; 4 is the default because `x-color-values' produces appropriate integer values for 4.
619 (setq nb-digits (or nb-digits 4))
620 (concat "#"
621 (hexrgb-int-to-hex (nth 0 components) nb-digits) ; red
622 (hexrgb-int-to-hex (nth 1 components) nb-digits) ; green
623 (hexrgb-int-to-hex (nth 2 components) nb-digits))) ; blue
624
625 (defun hexrgb-hex-to-color-values (color)
626 "Convert hex COLOR to a list of RGB color components.
627 COLOR is a hex rgb color string, #XXXXXXXXXXXX
628 Each X in the string is a hexadecimal digit. There are 3N X's, N > 0.
629 The output list is as for `x-color-values'."
630 (let* ((hex-strgp (string-match
631 "^\\(#\\)?\\(\\([a-fA-F0-9][a-fA-F0-9][a-fA-F0-9]\\)+\\)$"
632 color))
633 (ndigits (/ (if (eq (match-beginning 1) (match-end 1))
634 (length color)
635 (1- (length color)))
636 3))
637 red green blue)
638 (unless hex-strgp (error "Invalid RGB color string: %s" color))
639 (setq color (substring color (match-beginning 2) (match-end 2))
640 red (hexrgb-hex-to-int (substring color 0 ndigits))
641 green (hexrgb-hex-to-int (substring color ndigits (* 2 ndigits)))
642 blue (hexrgb-hex-to-int (substring color (* 2 ndigits) (* 3 ndigits))))
643 (list red green blue)))
644
645 ;; Like `doremi-increment-color-component', but for hue only, and with 0-1 range and NB-DIGITS.
646 (defun hexrgb-increment-hue (color increment &optional nb-digits)
647 "Increase hue component of COLOR by INCREMENT.
648 INCREMENT ranges from -100 to 100."
649 (unless (string-match "#" color) ; Convert color name to #hhh...
650 (setq color (hexrgb-color-values-to-hex (x-color-values color))))
651 ;; Convert RGB to HSV
652 (let* ((rgb (x-color-values color))
653 (red (/ (float (nth 0 rgb)) 65535.0)) ; Convert from 0-65535 to 0.0-1.0
654 (green (/ (float (nth 1 rgb)) 65535.0))
655 (blue (/ (float (nth 2 rgb)) 65535.0))
656 (hsv (hexrgb-rgb-to-hsv red green blue))
657 (hue (nth 0 hsv))
658 (saturation (nth 1 hsv))
659 (value (nth 2 hsv)))
660 (setq hue (+ hue increment))
661 (when (> hue 1.0) (setq hue (1- hue)))
662 (hexrgb-color-values-to-hex (mapcar (lambda (x) (floor (* x 65535.0)))
663 (hexrgb-hsv-to-rgb hue saturation value))
664 nb-digits)))
665
666 ;; Like `doremi-increment-color-component', but for saturation only, 0-1 range, and NB-DIGITS.
667 (defun hexrgb-increment-saturation (color increment &optional nb-digits)
668 "Increase saturation component of COLOR by INCREMENT."
669 (unless (string-match "#" color) ; Convert color name to #hhh...
670 (setq color (hexrgb-color-values-to-hex (x-color-values color))))
671 ;; Convert RGB to HSV
672 (let* ((rgb (x-color-values color))
673 (red (/ (float (nth 0 rgb)) 65535.0)) ; Convert from 0-65535 to 0.0-1.0
674 (green (/ (float (nth 1 rgb)) 65535.0))
675 (blue (/ (float (nth 2 rgb)) 65535.0))
676 (hsv (hexrgb-rgb-to-hsv red green blue))
677 (hue (nth 0 hsv))
678 (saturation (nth 1 hsv))
679 (value (nth 2 hsv)))
680 (setq saturation (+ saturation increment))
681 (when (> saturation 1.0) (setq saturation (1- saturation)))
682 (hexrgb-color-values-to-hex (mapcar (lambda (x) (floor (* x 65535.0)))
683 (hexrgb-hsv-to-rgb hue saturation value))
684 nb-digits)))
685
686 ;; Like `doremi-increment-color-component', but for value only, 0-1 range, and NB-DIGITS.
687 (defun hexrgb-increment-value (color increment &optional nb-digits)
688 "Increase value component (brightness) of COLOR by INCREMENT."
689 (unless (string-match "#" color) ; Convert color name to #hhh...
690 (setq color (hexrgb-color-values-to-hex (x-color-values color))))
691 ;; Convert RGB to HSV
692 (let* ((rgb (x-color-values color))
693 (red (/ (float (nth 0 rgb)) 65535.0)) ; Convert from 0-65535 to 0.0-1.0
694 (green (/ (float (nth 1 rgb)) 65535.0))
695 (blue (/ (float (nth 2 rgb)) 65535.0))
696 (hsv (hexrgb-rgb-to-hsv red green blue))
697 (hue (nth 0 hsv))
698 (saturation (nth 1 hsv))
699 (value (nth 2 hsv)))
700 (setq value (+ value increment))
701 (when (> value 1.0) (setq value (1- value)))
702 (hexrgb-color-values-to-hex (mapcar (lambda (x) (floor (* x 65535.0)))
703 (hexrgb-hsv-to-rgb hue saturation value))
704 nb-digits)))
705
706 (defun hexrgb-increment-red (hex nb-digits increment &optional wrap-p)
707 "Increment red component of rgb string HEX by INCREMENT.
708 String HEX starts with \"#\". Each color is NB-DIGITS hex digits long.
709 If optional arg WRAP-P is non-nil then the result wraps around zero.
710 For example, with NB-DIGITS 3, incrementing \"#fffffffff\" by 1
711 causes it to wrap around to \"#000ffffff\"."
712 (concat "#"
713 (hexrgb-increment-hex (substring hex 1 (1+ nb-digits)) nb-digits increment wrap-p)
714 (substring hex (1+ nb-digits) (1+ (* nb-digits 2)))
715 (substring hex (1+ (* nb-digits 2)))))
716
717 (defun hexrgb-increment-green (hex nb-digits increment &optional wrap-p)
718 "Increment green component of rgb string HEX by INCREMENT.
719 String HEX starts with \"#\". Each color is NB-DIGITS hex digits long.
720 If optional arg WRAP-P is non-nil then the result wraps around zero.
721 For example, with NB-DIGITS 3, incrementing \"#fffffffff\" by 1
722 causes it to wrap around to \"#fff000fff\"."
723 (concat
724 "#" (substring hex 1 (1+ nb-digits))
725 (hexrgb-increment-hex (substring hex (1+ nb-digits) (1+ (* nb-digits 2)))
726 nb-digits
727 increment
728 wrap-p)
729 (substring hex (1+ (* nb-digits 2)))))
730
731 (defun hexrgb-increment-blue (hex nb-digits increment &optional wrap-p)
732 "Increment blue component of rgb string HEX by INCREMENT.
733 String HEX starts with \"#\". Each color is NB-DIGITS hex digits long.
734 If optional arg WRAP-P is non-nil then the result wraps around zero.
735 For example, with NB-DIGITS 3, incrementing \"#fffffffff\" by 1
736 causes it to wrap around to \"#ffffff000\"."
737 (concat "#" (substring hex 1 (1+ (* nb-digits 2)))
738 (hexrgb-increment-hex (substring hex (1+ (* nb-digits 2)))
739 nb-digits
740 increment
741 wrap-p)))
742
743 (defun hexrgb-increment-equal-rgb (hex nb-digits increment &optional wrap-p)
744 "Increment each color component (r,g,b) of rgb string HEX by INCREMENT.
745 String HEX starts with \"#\". Each color is NB-DIGITS hex digits long.
746 If optional arg WRAP-P is non-nil then the result wraps around zero.
747 For example, with NB-DIGITS 3, incrementing \"#fffffffff\" by 1
748 causes it to wrap around to \"#000000000\"."
749 (concat
750 "#"
751 (hexrgb-increment-hex (substring hex 1 (1+ nb-digits)) nb-digits increment wrap-p)
752 (hexrgb-increment-hex (substring hex (1+ nb-digits) (1+ (* nb-digits 2)))
753 nb-digits
754 increment
755 wrap-p)
756 (hexrgb-increment-hex (substring hex (1+ (* nb-digits 2))) nb-digits increment wrap-p)))
757
758 (defun hexrgb-increment-hex (hex nb-digits increment &optional wrap-p)
759 "Increment hexadecimal-digits string HEX by INCREMENT.
760 Only the first NB-DIGITS of HEX are used.
761 If optional arg WRAP-P is non-nil then the result wraps around zero.
762 For example, with NB-DIGITS 3, incrementing \"fff\" by 1 causes it
763 to wrap around to \"000\"."
764 (let* ((int (hexrgb-hex-to-int hex))
765 (new-int (+ increment int)))
766 (if (or wrap-p
767 (and (>= int 0) ; Not too large for the machine.
768 (>= new-int 0) ; For the case where increment < 0.
769 (<= (length (format (concat "%X") new-int)) nb-digits))) ; Not too long.
770 (hexrgb-int-to-hex new-int nb-digits) ; Use incremented number.
771 hex))) ; Don't increment.
772
773 (defun hexrgb-hex-to-int (hex)
774 "Convert HEX string argument to an integer.
775 The characters of HEX must be hex characters."
776 (let* ((factor 1)
777 (len (length hex))
778 (indx (1- len))
779 (int 0))
780 (while (>= indx 0)
781 (setq int (+ int (* factor (hexrgb-hex-char-to-integer (aref hex indx))))
782 indx (1- indx)
783 factor (* 16 factor)))
784 int))
785
786 ;; From `hexl.el'. This is the same as `hexl-hex-char-to-integer' defined there.
787 (defun hexrgb-hex-char-to-integer (character)
788 "Take a CHARACTER and return its value as if it were a hex digit."
789 (if (and (>= character ?0) (<= character ?9))
790 (- character ?0)
791 (let ((ch (logior character 32)))
792 (if (and (>= ch ?a) (<= ch ?f))
793 (- ch (- ?a 10))
794 (error "Invalid hex digit `%c'" ch)))))
795
796 ;; Originally, I used the code from `int-to-hex-string' in `float.el'.
797 ;; This version is thanks to Juri Linkov <juri@jurta.org>.
798 ;;
799 (defun hexrgb-int-to-hex (int &optional nb-digits)
800 "Convert integer arg INT to a string of NB-DIGITS hexadecimal digits.
801 If INT is too large to be represented with NB-DIGITS, then the result
802 is truncated from the left. So, for example, INT=256 and NB-DIGITS=2
803 returns \"00\", since the hex equivalent of 256 decimal is 100, which
804 is more than 2 digits."
805 (setq nb-digits (or nb-digits 4))
806 (substring (format (concat "%0" (int-to-string nb-digits) "X") int) (- nb-digits)))
807
808 ;; Inspired by Elisp Info manual, node "Comparison of Numbers".
809 (defun hexrgb-approx-equal (x y &optional rfuzz afuzz)
810 "Return non-nil if numbers X and Y are approximately equal.
811 RFUZZ is a relative fuzz factor. AFUZZ is an absolute fuzz factor.
812 RFUZZ defaults to 1.0e-8. AFUZZ defaults to (/ RFUZZ 10).
813 RFUZZ and AFUZZ are converted to their absolute values.
814 The algorithm is:
815 (< (abs (- X Y)) (+ AFUZZ (* RFUZZ (+ (abs X) (abs Y)))))."
816 (setq rfuzz (or rfuzz 1.0e-8)
817 rfuzz (abs rfuzz)
818 afuzz (or afuzz (/ rfuzz 10))
819 afuzz (abs afuzz))
820 (< (abs (- x y)) (+ afuzz (* rfuzz (+ (abs x) (abs y))))))
821
822 (defun hexrgb-color-value-to-float (n)
823 "Return the floating-point equivalent of color-component value N.
824 N must be an integer between 0 and 65535, or else an error is raised."
825 (unless (and (wholenump n) (<= n 65535))
826 (error "Not a whole number less than 65536"))
827 (/ (float n) 65535.0))
828
829 (defun hexrgb-hex-to-hex (hex nb-digits)
830 "Return a hex string of NB-DIGITS digits, rounded from hex string HEX.
831 Raise an error if HEX represents a number > `most-positive-fixnum'
832 HEX is a hex string, not an RGB string. It does not start with `#'."
833 (let* ((len (length hex))
834 (digdiff (- nb-digits len)))
835 (cond ((zerop digdiff)
836 hex)
837 ((natnump digdiff)
838 (let ((int (hexrgb-hex-to-int hex)))
839 (unless (natnump int) (error "HEX number is too large"))
840 (format (concat "%0" (int-to-string len) "X" (make-string digdiff ?0)) int)))
841 (t
842 (let ((over (substring hex digdiff)))
843 (setq hex (substring hex 0 nb-digits))
844 (if (> (string-to-number over 16)
845 (string-to-number (make-string (- digdiff) ?7) 16))
846 (hexrgb-increment-hex hex nb-digits 1) ; Round up.
847 hex))))))
848
849 (defun hexrgb-rgb-hex-to-rgb-hex (hex nb-digits)
850 "Trim or expand hex RGB string HEX to NB-DIGITS digits.
851 HEX can optionally start with `#'.
852 In that case, so does the return value."
853 (let* ((nb-sign-p (eq ?# (aref hex 0)))
854 (hex+ (or (and nb-sign-p hex) (concat "#" hex)))
855 (red (hexrgb-red-hex hex+))
856 (green (hexrgb-green-hex hex+))
857 (blue (hexrgb-blue-hex hex+)))
858 (format "%s%s%s%s"
859 (if nb-sign-p "#" "")
860 (hexrgb-hex-to-hex red nb-digits)
861 (hexrgb-hex-to-hex green nb-digits)
862 (hexrgb-hex-to-hex blue nb-digits))))
863
864 (defun hexrgb-red-hex (hex)
865 "Return the red hex component for RGB string HEX.
866 HEX can optionally start with `#'. The return value does not."
867 (let* ((nb-sign-p (eq ?# (aref hex 0)))
868 (hex- (or (and nb-sign-p (substring hex 1)) hex)))
869 (substring hex- 0 (/ (length hex-) 3))))
870
871 (defun hexrgb-green-hex (hex)
872 "Return the green hex component for RGB string HEX.
873 HEX can optionally start with `#'. The return value does not."
874 (let* ((nb-sign-p (eq ?# (aref hex 0)))
875 (hex- (or (and nb-sign-p (substring hex 1)) hex))
876 (len (/ (length hex-) 3)))
877 (substring hex- len (* 2 len))))
878
879 (defun hexrgb-blue-hex (hex)
880 "Return the blue hex component for RGB string HEX.
881 HEX can optionally start with `#'. The return value does not."
882 (let* ((nb-sign-p (eq ?# (aref hex 0)))
883 (hex- (or (and nb-sign-p (substring hex 1)) hex))
884 (len (/ (length hex-) 3)))
885 (substring hex- (* 2 len))))
886
887 (defun hexrgb-float-to-color-value (x)
888 "Return the color-component value equivalent of floating-point number X.
889 X must be between 0.0 and 1.0, or else an error is raised."
890 (unless (and (numberp x) (<= 0.0 x) (<= x 1.0))
891 (error "Not a floating-point number between 0.0 and 1.0"))
892 (floor (* x 65535.0)))
893
894 ;;;;;;;;;;;;;;;;;;;;;;;;;;;
895
896 (provide 'hexrgb)
897
898 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
899 ;;; hexrgb.el ends here