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