diff options
Diffstat (limited to 'jabber-fallback-lib/hexrgb.el')
| -rw-r--r-- | jabber-fallback-lib/hexrgb.el | 731 |
1 files changed, 731 insertions, 0 deletions
diff --git a/jabber-fallback-lib/hexrgb.el b/jabber-fallback-lib/hexrgb.el new file mode 100644 index 0000000..57f2c2c --- /dev/null +++ b/jabber-fallback-lib/hexrgb.el @@ -0,0 +1,731 @@ +;;; hexrgb.el --- Functions to manipulate colors, including RGB hex strings. +;; +;; Filename: hexrgb.el +;; Description: Functions to manipulate colors, including RGB hex strings. +;; Author: Drew Adams +;; Maintainer: Drew Adams +;; Copyright (C) 2004-2009, Drew Adams, all rights reserved. +;; Created: Mon Sep 20 22:58:45 2004 +;; Version: 21.0 +;; Last-Updated: Sat Nov 14 15:55:15 2009 (-0800) +;; By: dradams +;; Update #: 732 +;; URL: http://www.emacswiki.org/cgi-bin/wiki/hexrgb.el +;; Keywords: number, hex, rgb, color, background, frames, display +;; Compatibility: GNU Emacs: 20.x, 21.x, 22.x, 23.x +;; +;; Features that might be required by this library: +;; +;; None +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: +;; +;; Functions to manipulate colors, including RGB hex strings. +;; +;; This library provides functions for converting between RGB (red, +;; green, blue) color components and HSV (hue, saturation, value) +;; color components. It helps you convert among Emacs color values +;; (whole numbers from 0 through 65535), RGB and HSV floating-point +;; components (0.0 through 1.0), Emacs color-name strings (such as +;; "blue"), and hex RGB color strings (such as "#FC43A7912"). +;; +;; An RGB hex string, such as used as a frame `background-color' +;; property, is a string of 1 + (3 * n) characters, the first of +;; which is "#". The other characters are hexadecimal digits, in +;; three groups representing (from the left): red, green, and blue +;; hex codes. +;; +;; Constants defined here: +;; +;; `hexrgb-defined-colors', `hexrgb-defined-colors-alist', +;; `hexrgb-defined-colors-no-dups', +;; `hexrgb-defined-colors-no-dups-alist'. +;; +;; Options defined here: +;; +;; `hexrgb-canonicalize-defined-colors-flag'. +;; +;; Commands defined here: +;; +;; `hexrgb-blue', `hexrgb-complement', `hexrgb-green', +;; `hexrgb-hue', `hexrgb-read-color', `hexrgb-red', +;; `hexrgb-saturation', `hexrgb-value'. +;; +;; Non-interactive functions defined here: +;; +;; `hexrgb-approx-equal', `hexrgb-canonicalize-defined-colors', +;; `hexrgb-color-name-to-hex', `hexrgb-color-values-to-hex', +;; `hexrgb-color-value-to-float', `hexrgb-defined-colors', +;; `hexrgb-defined-colors-alist', +;; `hexrgb-delete-whitespace-from-string', +;; `hexrgb-float-to-color-value', `hexrgb-hex-char-to-integer', +;; `hexrgb-hex-to-color-values', `hexrgb-hex-to-hsv', +;; `hexrgb-hex-to-rgb', `hexrgb-hsv-to-hex', `hexrgb-hex-to-int', +;; `hexrgb-hsv-to-rgb', `hexrgb-increment-blue', +;; `hexrgb-increment-equal-rgb', `hexrgb-increment-green', +;; `hexrgb-increment-hex', `hexrgb-increment-red', +;; `hexrgb-int-to-hex', `hexrgb-rgb-hex-string-p', +;; `hexrgb-rgb-to-hex', `hexrgb-rgb-to-hsv'. +;; +;; +;; Add this to your initialization file (~/.emacs or ~/_emacs): +;; +;; (require 'hexrgb) +;; +;; Do not try to use this library without a window manager. +;; That is, do not use this with `emacs -nw'. +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Change log: +;; +;; 2009/11/14 dadams +;; hexrgb-rgb-to-hsv: Corrected hue when > 1.0. Use strict inequality for hue limit tests. +;; hexrgb-approx-equal: Convert RFUZZ and AFUZZ to their absolute values. +;; 2009/11/03 dadams +;; Added: hexrgb-delete-whitespace-from-string, hexrgb-canonicalize-defined-colors, +;; hexrgb-defined-colors(-no-dups)(-alist), hexrgb-canonicalize-defined-colors-flag. +;; hexrgb-read-color: Use function hexrgb-defined-colors-alist, not the constant. +;; 2008/12/25 dadams +;; hexrgb-rgb-to-hsv: +;; Replace (not (equal 0.0e+NaN saturation)) by standard test (= saturation saturation). +;; Thx to Michael Heerdegen for the bug report. +;; 2008-10-17 dadams +;; hexrgb-defined-colors(-alist): Prevent load-time error if user tries to use emacs -nw. +;; 2007/12/30 dadams +;; Added: hexrgb-hex-to-color-values. +;; 2007/10/20 dadams +;; hexrgb-read-color: Treat pseudo colors too (e.g. *point foreground*). +;; 2007/01/21 dadams +;; hexrgb-read-color: Error if empty string (and not allow-empty-name-p). +;; 2006/06/06 dadams +;; Added: hexrgb-defined-colors(-alist). Use instead of (x-defined-colors). +;; hexrgb-(red|green|blue): Added interactive specs. +;; 2006/06/04 dadams +;; hexrgb-read-color: Added optional arg allow-empty-name-p. +;; 2006/06/02 dadams +;; Added: hexrgb-rgb-hex-string-p. Used it. +;; 2006/05/30 dadams +;; Added: hexrgb-hex-to-(hsv|rgb), hexrgb-hsv-to-hex, hexrgb-color-name-to-hex, +;; hexrgb-complement, hexrgb-read-color, hexrgb-hue, hexrgb-saturation, +;; hexrgb-value, hexrgb-red, hexrgb-blue, hexrgb-green. +;; approx-equal: Add optional fuzz factor arguments. Changed the algorithm. +;; Renamed: approx-equal to hexrgb-approx-equal. +;; hexrgb-rgb-to-hsv: Changed test from < to <=: (when (<= hue 0.0)...). +;; hexrgb-hsv-to-rgb: Treat hue = 0.0 (int 0) the same as hue = 1.0 (int 6). +;; hexrgb-rgb-to-hex, hexrgb-increment-hex: Corrected doc strings. +;; 2006/05/22 dadams +;; Added: hexrgb-hsv-to-hex, hexrgb-rgb-to-hex. Require cl.el when byte-compile. +;; 2005/08/09 dadams +;; hexrgb-rgb-to-hsv: Side-stepped Emacs-20 bug in comparing NaN. +;; hexrgb-increment-*: Added optional arg wrap-p. +;; hexrgb-increment-hex: Prevent wrap if not wrap-p. +;; 2005/08/02 dadams +;; hexrgb-rgb-to-hes: Bug fix: If delta is zero, then so are hue and saturation. +;; 2005/06/24 dadams +;; hexrgb-rgb-to-hsv: Bug fix: test for NaN (e.g. on divide by zero). +;; 2005/02/08 dadams +;; hexrgb-hsv-to-rgb: Bug fix (typo: p, q -> pp, qq; added ww). +;; 2005/01/09 dadams +;; hexrgb-int-to-hex: Fixed bug in hexrgb-int-to-hex: nb-digits not respected. +;; Added: hexrgb-hsv-to-rgb, hexrgb-rgb-to-hsv, approx-equal. +;; Renamed old hexrgb-increment-value to hexrgb-increment-equal-rgb. +;; 2005/01/05 dadams +;; hexrgb-int-to-hex: Used a suggestion from Juri Linkov. +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth +;; Floor, Boston, MA 02110-1301, USA. +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Code: + +(eval-when-compile (require 'cl)) ;; case; plus, for Emacs < 20: when, unless + +;; Unless you first load `hexrgb.el', then either `palette.el' or `eyedropper.el', you will get +;; warnings about variables and functions with prefix `eyedrop-' when you byte-compile +;; `hexrgb.el'. You can ignore these warnings. + +(defvar eyedrop-picked-foreground) +(defvar eyedrop-picked-background) + +;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;;###autoload +(eval-and-compile + (defun hexrgb-canonicalize-defined-colors (list) + "Copy of LIST with color names canonicalized. +LIST is a list of color names (strings). +Canonical names are lowercase, with no whitespace. +There are no duplicate names." + (let ((tail list) + this new) + (while tail + (setq this (car tail) + this (hexrgb-delete-whitespace-from-string (downcase this) 0 (length this))) + (unless (member this new) (push this new)) + (pop tail)) + (nreverse new))) + + (defun hexrgb-delete-whitespace-from-string (string &optional from to) + "Remove whitespace from substring of STRING from FROM to TO. +If FROM is nil, then start at the beginning of STRING (FROM = 0). +If TO is nil, then end at the end of STRING (TO = length of STRING). +FROM and TO are zero-based indexes into STRING. +Character FROM is affected (possibly deleted). Character TO is not." + (setq from (or from 0) + to (or to (length string))) + (with-temp-buffer + (insert string) + (goto-char (+ from (point-min))) + (let ((count from) + char) + (while (and (not (eobp)) (< count to)) + (setq char (char-after)) + (if (memq char '(?\ ?\t ?\n)) (delete-char 1) (forward-char 1)) + (setq count (1+ count))) + (buffer-string))))) + +;;;###autoload +(defconst hexrgb-defined-colors (eval-when-compile (and window-system (x-defined-colors))) + "List of all supported colors.") + +;;;###autoload +(defconst hexrgb-defined-colors-no-dups + (eval-when-compile + (and window-system (hexrgb-canonicalize-defined-colors (x-defined-colors)))) + "List of all supported color names, with no duplicates. +Names are all lowercase, without any spaces.") + +;;;###autoload +(defconst hexrgb-defined-colors-alist + (eval-when-compile (and window-system (mapcar #'list (x-defined-colors)))) + "Alist of all supported color names, for use in completion. +See also `hexrgb-defined-colors-no-dups-alist', which is the same +thing, but without any duplicates, such as \"light blue\" and +\"LightBlue\".") + +;;;###autoload +(defconst hexrgb-defined-colors-no-dups-alist + (eval-when-compile + (and window-system + (mapcar #'list (hexrgb-canonicalize-defined-colors (x-defined-colors))))) + "Alist of all supported color names, with no duplicates, for completion. +Names are all lowercase, without any spaces.") + +;;;###autoload +(defcustom hexrgb-canonicalize-defined-colors-flag t + "*Non-nil means remove duplicate color names. +Names are considered duplicates if they are the same when abstracting +from whitespace and letter case." + :type 'boolean + :group 'Icicles :group 'doremi-frame-commands :group 'faces :group 'convenience) + +;; You should use these two functions, not the constants, so users can change +;; the behavior by customizing `hexrgb-canonicalize-defined-colors-flag'. + +(defun hexrgb-defined-colors () + "List of supported color names. +If `hexrgb-canonicalize-defined-colors-flag' is non-nil, then names +are lowercased, whitespace is removed, and there are no duplicates." + (if hexrgb-canonicalize-defined-colors-flag + hexrgb-defined-colors-no-dups + hexrgb-defined-colors)) + +(defun hexrgb-defined-colors-alist () + "Alist of supported color names. Usable for completion. +If `hexrgb-canonicalize-defined-colors-flag' is non-nil, then names +are lowercased, whitespace is removed, and there are no duplicates." + (if hexrgb-canonicalize-defined-colors-flag + hexrgb-defined-colors-no-dups-alist + hexrgb-defined-colors-alist)) + +;; RMS added this function to Emacs (23) as `read-color', with some feature loss. +;;;###autoload +(defun hexrgb-read-color (&optional convert-to-RGB-p allow-empty-name-p prompt) + "Read a color name or RGB hex value: #RRRRGGGGBBBB. +Completion is available for color names, but not for RGB hex strings. +If you input an RGB hex string, it must have the form #XXXXXXXXXXXX or +XXXXXXXXXXXX, where each X is a hex digit. The number of Xs must be a +multiple of 3, with the same number of Xs for each of red, green, and +blue. The order is red, green, blue. + +Color names that are normally considered equivalent are canonicalized: +They are lowercased, whitespace is removed, and duplicates are +eliminated. E.g. \"LightBlue\" and \"light blue\" are both replaced +by \"lightblue\". If you do not want this behavior, but want to +choose names that might contain whitespace or uppercase letters, then +customize option `hexrgb-canonicalize-defined-colors-flag' to nil. + +In addition to standard color names and RGB hex values, the following +are available as color candidates. In each case, the corresponding +color is used. + +* `*copied foreground*' - last copied foreground, if available +* `*copied background*' - last copied background, if available +* `*mouse-2 foreground*' - foreground where you click `mouse-2' +* `*mouse-2 background*' - background where you click `mouse-2' +* `*point foreground*' - foreground under the cursor +* `*point background*' - background under the cursor + +\(You can copy a color using eyedropper commands such as +`eyedrop-pick-foreground-at-mouse'.) + +Checks input to be sure it represents a valid color. If not, raises +an error (but see exception for empty input with non-nil +ALLOW-EMPTY-NAME-P). + +Interactively, or with optional arg CONVERT-TO-RGB-P non-nil, converts +an input color name to an RGB hex string. Returns the RGB hex string. + +Optional arg ALLOW-EMPTY-NAME-P controls what happens if you enter an +empty color name (that is, you just hit `RET'). If non-nil, then +`hexrgb-read-color' returns an empty color name, \"\". If nil, then +it raises an error. Programs must test for \"\" if ALLOW-EMPTY-NAME-P +is non-nil. They can then perform an appropriate action in case of +empty input. + +Optional arg PROMPT is the prompt. Nil means use a default prompt." + (interactive "p") ; Always convert to RGB interactively. + (let* ((completion-ignore-case t) + ;; Free variables here: `eyedrop-picked-foreground', `eyedrop-picked-background'. + ;; They are defined in library `palette.el' or library `eyedropper.el'. + (colors (if (fboundp 'eyedrop-foreground-at-point) + (append (and eyedrop-picked-foreground + '(("*copied foreground*"))) + (and eyedrop-picked-background + '(("*copied background*"))) + '(("*mouse-2 foreground*") + ("*mouse-2 background*") + ("*point foreground*") ("*point background*")) + (hexrgb-defined-colors-alist)) + (hexrgb-defined-colors-alist))) + (color (completing-read (or prompt "Color (name or #R+G+B+): ") + colors)) + hex-string) + (when (fboundp 'eyedrop-foreground-at-point) + (cond ((string= "*copied foreground*" color) (setq color eyedrop-picked-foreground)) + ((string= "*copied background*" color) (setq color eyedrop-picked-background)) + ((string= "*point foreground*" color) (setq color (eyedrop-foreground-at-point))) + ((string= "*point background*" color) (setq color (eyedrop-background-at-point))) + ((string= "*mouse-2 foreground*" color) + (setq color (prog1 (eyedrop-foreground-at-mouse + (read-event "Click `mouse-2' to choose foreground color - ")) + (read-event)))) ; Discard mouse up event. + ((string= "*mouse-2 background*" color) + (setq color (prog1 (eyedrop-background-at-mouse + (read-event "Click `mouse-2' to choose background color - ")) + (read-event)))))) ; Discard mouse up event. + (setq hex-string (or (string-match "^#\\([a-fA-F0-9][a-fA-F0-9][a-fA-F0-9]\\)+$" color) + (and (string-match "^\\([a-fA-F0-9][a-fA-F0-9][a-fA-F0-9]\\)+$" color) + t))) + (if (and allow-empty-name-p (string= "" color)) + "" + (when (and hex-string (not (eq 0 hex-string))) + (setq color (concat "#" color))) ; No #; add it. + (unless hex-string + (when (or (string= "" color) + (not (if (fboundp 'test-completion) ; Not defined in Emacs 20. + (test-completion color colors) + (try-completion color colors)))) + (error "No such color: %S" color)) + (when convert-to-RGB-p (setq color (hexrgb-color-name-to-hex color)))) + (when (interactive-p) (message "Color: `%s'" color)) + color))) + +;;;###autoload +(defun hexrgb-rgb-hex-string-p (color &optional laxp) + "Non-nil if COLOR is an RGB string #XXXXXXXXXXXX. +Each X is a hex digit. The number of Xs must be a multiple of 3, with +the same number of Xs for each of red, green, and blue. + +Non-nil optional arg LAXP means that the initial `#' is optional. In +that case, for a valid string of hex digits: when # is present 0 is +returned; otherwise, t is returned." + (or (string-match "^#\\([a-fA-F0-9][a-fA-F0-9][a-fA-F0-9]\\)+$" color) + (and laxp (string-match "^\\([a-fA-F0-9][a-fA-F0-9][a-fA-F0-9]\\)+$" color) t))) + +;;;###autoload +(defun hexrgb-complement (color) + "Return the color that is the complement of COLOR." + (interactive (list (hexrgb-read-color))) + (setq color (hexrgb-color-name-to-hex color)) + (let ((red (hexrgb-red color)) + (green (hexrgb-green color)) + (blue (hexrgb-blue color))) + (setq color (hexrgb-rgb-to-hex (- 1.0 red) (- 1.0 green) (- 1.0 blue)))) + (when (interactive-p) (message "Complement: `%s'" color)) + color) + +;;;###autoload +(defun hexrgb-hue (color) + "Return the hue component of COLOR, in range 0 to 1 inclusive. +COLOR is a color name or hex RGB string that starts with \"#\"." + (interactive (list (hexrgb-read-color))) + (setq color (hexrgb-color-name-to-hex color)) + (car (hexrgb-rgb-to-hsv (hexrgb-red color) (hexrgb-green color) (hexrgb-blue color)))) + +;;;###autoload +(defun hexrgb-saturation (color) + "Return the saturation component of COLOR, in range 0 to 1 inclusive. +COLOR is a color name or hex RGB string that starts with \"#\"." + (interactive (list (hexrgb-read-color))) + (setq color (hexrgb-color-name-to-hex color)) + (cadr (hexrgb-rgb-to-hsv (hexrgb-red color) (hexrgb-green color) (hexrgb-blue color)))) + +;;;###autoload +(defun hexrgb-value (color) + "Return the value component of COLOR, in range 0 to 1 inclusive. +COLOR is a color name or hex RGB string that starts with \"#\"." + (interactive (list (hexrgb-read-color))) + (setq color (hexrgb-color-name-to-hex color)) + (caddr (hexrgb-rgb-to-hsv (hexrgb-red color) (hexrgb-green color) (hexrgb-blue color)))) + +;;;###autoload +(defun hexrgb-red (color) + "Return the red component of COLOR, in range 0 to 1 inclusive. +COLOR is a color name or hex RGB string that starts with \"#\"." + (interactive (list (hexrgb-read-color))) + (setq color (hexrgb-color-name-to-hex color)) + (/ (hexrgb-hex-to-int (substring color 1 (1+ (/ (1- (length color)) 3)))) + (expt 16.0 (/ (1- (length color)) 3.0)))) + +;;;###autoload +(defun hexrgb-green (color) + "Return the green component of COLOR, in range 0 to 1 inclusive. +COLOR is a color name or hex RGB string that starts with \"#\"." + (interactive (list (hexrgb-read-color))) + (setq color (hexrgb-color-name-to-hex color)) + (let* ((len (/ (1- (length color)) 3)) + (start (1+ len))) + (/ (hexrgb-hex-to-int (substring color start (+ start len))) + (expt 16.0 (/ (1- (length color)) 3.0))))) + +;;;###autoload +(defun hexrgb-blue (color) + "Return the blue component of COLOR, in range 0 to 1 inclusive. +COLOR is a color name or hex RGB string that starts with \"#\"." + (interactive (list (hexrgb-read-color))) + (setq color (hexrgb-color-name-to-hex color)) + (let* ((len (/ (1- (length color)) 3)) + (start (+ 1 len len))) + (/ (hexrgb-hex-to-int (substring color start (+ start len))) + (expt 16.0 (/ (1- (length color)) 3.0))))) + +;;;###autoload +(defun hexrgb-rgb-to-hsv (red green blue) + "Convert RED, GREEN, BLUE components to HSV (hue, saturation, value). +Each input component is 0.0 to 1.0, inclusive. +Returns a list of HSV components of value 0.0 to 1.0, inclusive." + (let* ((min (min red green blue)) + (max (max red green blue)) + (value max) + (delta (- max min)) + hue saturation) + (if (hexrgb-approx-equal 0.0 delta) + (setq hue 0.0 + saturation 0.0) ; Gray scale - no color; only value. + (if (and (condition-case nil + (setq saturation (/ delta max)) + (arith-error nil)) + ;; Must be a number, not a NaN. The standard test for a NaN is (not (= N N)), + ;; but an Emacs 20 bug makes (= N N) return t for a NaN also. + (or (< emacs-major-version 21) (= saturation saturation))) + (if (hexrgb-approx-equal 0.0 saturation) + (setq hue 0.0 + saturation 0.0) ; Again, no color; only value. + ;; Color + (setq hue (if (hexrgb-approx-equal red max) + (/ (- green blue) delta) ; Between yellow & magenta. + (if (hexrgb-approx-equal green max) + (+ 2.0 (/ (- blue red) delta)) ; Between cyan & yellow. + (+ 4.0 (/ (- red green) delta)))) ; Between magenta & cyan. + hue (/ hue 6.0)) + ;; (when (<= hue 0.0) (setq hue (+ hue 1.0))) ; $$$$$$ + ;; (when (>= hue 1.0) (setq hue (- hue 1.0)))) ; $$$$$$ + (when (< hue 0.0) (setq hue (+ hue 1.0))) + (when (> hue 1.0) (setq hue (- hue 1.0)))) + (setq hue 0.0 ; Div by zero (max=0): H:=0, S:=0. (Hue undefined.) + saturation 0.0))) + (list hue saturation value))) + +;;;###autoload +(defun hexrgb-hsv-to-rgb (hue saturation value) + "Convert HUE, SATURATION, VALUE components to RGB (red, green, blue). +Each input component is 0.0 to 1.0, inclusive. +Returns a list of RGB components of value 0.0 to 1.0, inclusive." + (let (red green blue int-hue fract pp qq tt ww) + (if (hexrgb-approx-equal 0.0 saturation) + (setq red value + green value + blue value) ; Gray + (setq hue (* hue 6.0) ; Sectors: 0 to 5 + int-hue (floor hue) + fract (- hue int-hue) + pp (* value (- 1 saturation)) + qq (* value (- 1 (* saturation fract))) + ww (* value (- 1 (* saturation (- 1 (- hue int-hue)))))) + (case int-hue + ((0 6) (setq red value + green ww + blue pp)) + (1 (setq red qq + green value + blue pp)) + (2 (setq red pp + green value + blue ww)) + (3 (setq red pp + green qq + blue value)) + (4 (setq red ww + green pp + blue value)) + (otherwise (setq red value + green pp + blue qq)))) + (list red green blue))) + +;;;###autoload +(defun hexrgb-hsv-to-hex (hue saturation value) + "Return the hex RBG color string for inputs HUE, SATURATION, VALUE. +The inputs are each in the range 0 to 1. +The output string is of the form \"#RRRRGGGGBBBB\"." + (hexrgb-color-values-to-hex + (mapcar (lambda (x) (floor (* x 65535.0))) (hexrgb-hsv-to-rgb hue saturation value)))) + +;;;###autoload +(defun hexrgb-rgb-to-hex (red green blue) + "Return the hex RBG color string for inputs RED, GREEN, BLUE. +The inputs are each in the range 0 to 1. +The output string is of the form \"#RRRRGGGGBBBB\"." + (hexrgb-color-values-to-hex + (mapcar (lambda (x) (floor (* x 65535.0))) (list red green blue)))) + +;;;###autoload +(defun hexrgb-hex-to-hsv (color) + "Return a list of HSV (hue, saturation, value) color components. +Each component is a value from 0.0 to 1.0, inclusive. +COLOR is a color name or a hex RGB string that starts with \"#\" and +is followed by an equal number of hex digits for red, green, and blue +components." + (let ((rgb-components (hexrgb-hex-to-rgb color))) + (apply #'hexrgb-rgb-to-hsv rgb-components))) + +;;;###autoload +(defun hexrgb-hex-to-rgb (color) + "Return a list of RGB (red, green, blue) color components. +Each component is a value from 0.0 to 1.0, inclusive. +COLOR is a color name or a hex RGB string that starts with \"#\" and +is followed by an equal number of hex digits for red, green, and blue +components." + (unless (hexrgb-rgb-hex-string-p color) (setq color (hexrgb-color-name-to-hex color))) + (let ((len (/ (1- (length color)) 3))) + (list (/ (hexrgb-hex-to-int (substring color 1 (1+ len))) 65535.0) + (/ (hexrgb-hex-to-int (substring color (1+ len) (+ 1 len len))) 65535.0) + (/ (hexrgb-hex-to-int (substring color (+ 1 len len))) 65535.0)))) + +;;;###autoload +(defun hexrgb-color-name-to-hex (color) + "Return the RGB hex string for the COLOR name, starting with \"#\". +If COLOR is already a string starting with \"#\", then just return it." + (let ((components (x-color-values color))) + (unless components (error "No such color: %S" color)) + (unless (hexrgb-rgb-hex-string-p color) + (setq color (hexrgb-color-values-to-hex components)))) + color) + +;; Just hard-code 4 as the number of hex digits, since `x-color-values' +;; seems to produce appropriate integer values for this value. +;; +;; Color "components" would be better in the name than color "value" +;; but this name follows the Emacs tradition (e.g. `x-color-values', +;; 'ps-color-values', `ps-e-x-color-values'). +;;;###autoload +(defun hexrgb-color-values-to-hex (values) + "Convert list of rgb color VALUES to a hex string, #XXXXXXXXXXXX. +Each X in the string is a hexadecimal digit. +Input VALUES is as for the output of `x-color-values'." + (concat "#" (hexrgb-int-to-hex (nth 0 values) 4) ; red + (hexrgb-int-to-hex (nth 1 values) 4) ; green + (hexrgb-int-to-hex (nth 2 values) 4))) ; blue + +;;;###autoload +(defun hexrgb-hex-to-color-values (color) + "Convert hex COLOR to a list of rgb color values. +COLOR is a hex rgb color string, #XXXXXXXXXXXX +Each X in the string is a hexadecimal digit. There are 3N X's, N > 0. +The output list is as for `x-color-values'." + (let* ((hex-strgp (string-match + "^\\(#\\)?\\(\\([a-fA-F0-9][a-fA-F0-9][a-fA-F0-9]\\)+\\)$" + color)) + (ndigits (/ (if (eq (match-beginning 1) (match-end 1)) + (length color) + (1- (length color))) + 3)) + red green blue) + (unless hex-strgp (error "Invalid RGB color string: %s" color)) + (setq color (substring color (match-beginning 2) (match-end 2)) + red (hexrgb-hex-to-int (substring color 0 ndigits)) + green (hexrgb-hex-to-int (substring color ndigits (* 2 ndigits))) + blue (hexrgb-hex-to-int (substring color ndigits (* 3 ndigits)))) + (list red green blue))) + +;;;###autoload +(defun hexrgb-increment-red (hex nb-digits increment &optional wrap-p) + "Increment red value of rgb string HEX by INCREMENT. +String HEX starts with \"#\". Each color is NB-DIGITS hex digits long. +If optional arg WRAP-P is non-nil, then the result wraps around zero. +For example, incrementing \"#FFFFFFFFF\" by 1 will cause it to wrap +around to \"#000000000\"." + (concat "#" + (hexrgb-increment-hex (substring hex 1 (1+ nb-digits)) increment nb-digits wrap-p) + (substring hex (1+ nb-digits) (1+ (* nb-digits 2))) + (substring hex (1+ (* nb-digits 2))))) + +;;;###autoload +(defun hexrgb-increment-green (hex nb-digits increment &optional wrap-p) + "Increment green value of rgb string HEX by INCREMENT. +String HEX starts with \"#\". Each color is NB-DIGITS hex digits long. +For example, incrementing \"#FFFFFFFFF\" by 1 will cause it to wrap +around to \"#000000000\"." + (concat + "#" (substring hex 1 (1+ nb-digits)) + (hexrgb-increment-hex (substring hex (1+ nb-digits) (1+ (* nb-digits 2))) + increment + nb-digits + wrap-p) + (substring hex (1+ (* nb-digits 2))))) + +;;;###autoload +(defun hexrgb-increment-blue (hex nb-digits increment &optional wrap-p) + "Increment blue value of rgb string HEX by INCREMENT. +String HEX starts with \"#\". Each color is NB-DIGITS hex digits long. +For example, incrementing \"#FFFFFFFFF\" by 1 will cause it to wrap +around to \"#000000000\"." + (concat "#" (substring hex 1 (1+ (* nb-digits 2))) + (hexrgb-increment-hex (substring hex (1+ (* nb-digits 2))) + increment + nb-digits + wrap-p))) + +;;;###autoload +(defun hexrgb-increment-equal-rgb (hex nb-digits increment &optional wrap-p) + "Increment each color value (r,g,b) of rgb string HEX by INCREMENT. +String HEX starts with \"#\". Each color is NB-DIGITS hex digits long. +For example, incrementing \"#FFFFFFFFF\" by 1 will cause it to wrap +around to \"#000000000\"." + (concat + "#" (hexrgb-increment-hex (substring hex 1 (1+ nb-digits)) increment nb-digits wrap-p) + (hexrgb-increment-hex (substring hex (1+ nb-digits) (1+ (* nb-digits 2))) + increment + nb-digits + wrap-p) + (hexrgb-increment-hex (substring hex (1+ (* nb-digits 2))) increment nb-digits wrap-p))) + +;;;###autoload +(defun hexrgb-increment-hex (hex increment nb-digits &optional wrap-p) + "Increment HEX number (a string NB-DIGITS long) by INCREMENT. +For example, incrementing \"FFFFFFFFF\" by 1 will cause it to wrap +around to \"000000000\"." + (let* ((int (hexrgb-hex-to-int hex)) + (new-int (+ increment int))) + (if (or wrap-p + (and (>= int 0) ; Not too large for the machine. + (>= new-int 0) ; For the case where increment < 0. + (<= (length (format (concat "%X") new-int)) nb-digits))) ; Not too long. + (hexrgb-int-to-hex new-int nb-digits) ; Use incremented number. + hex))) ; Don't increment. + +;;;###autoload +(defun hexrgb-hex-to-int (hex) + "Convert HEX string argument to an integer. +The characters of HEX must be hex characters." + (let* ((factor 1) + (len (length hex)) + (indx (1- len)) + (int 0)) + (while (>= indx 0) + (setq int (+ int (* factor (hexrgb-hex-char-to-integer (aref hex indx)))) + indx (1- indx) + factor (* 16 factor))) + int)) + +;; From `hexl.el'. This is the same as `hexl-hex-char-to-integer' defined there. +;;;###autoload +(defun hexrgb-hex-char-to-integer (character) + "Take a CHARACTER and return its value as if it were a hex digit." + (if (and (>= character ?0) (<= character ?9)) + (- character ?0) + (let ((ch (logior character 32))) + (if (and (>= ch ?a) (<= ch ?f)) + (- ch (- ?a 10)) + (error "Invalid hex digit `%c'" ch))))) + +;; Originally, I used the code from `int-to-hex-string' in `float.el'. +;; This version is thanks to Juri Linkov <juri@jurta.org>. +;; +;;;###autoload +(defun hexrgb-int-to-hex (int &optional nb-digits) + "Convert integer argument INT to a #XXXXXXXXXXXX format hex string. +Each X in the output string is a hexadecimal digit. +NB-DIGITS is the number of hex digits. If INT is too large to be +represented with NB-DIGITS, then the result is truncated from the +left. So, for example, INT=256 and NB-DIGITS=2 returns \"00\", since +the hex equivalent of 256 decimal is 100, which is more than 2 digits." + (setq nb-digits (or nb-digits 4)) + (substring (format (concat "%0" (int-to-string nb-digits) "X") int) (- nb-digits))) + +;; Inspired by Elisp Info manual, node "Comparison of Numbers". +;;;###autoload +(defun hexrgb-approx-equal (x y &optional rfuzz afuzz) + "Return non-nil if numbers X and Y are approximately equal. +RFUZZ is a relative fuzz factor. AFUZZ is an absolute fuzz factor. +RFUZZ defaults to 1.0e-8. AFUZZ defaults to (/ RFUZZ 10). +RFUZZ and AFUZZ are converted to their absolute values. +The algorithm is: + (< (abs (- X Y)) (+ AFUZZ (* RFUZZ (+ (abs X) (abs Y)))))." + (setq rfuzz (or rfuzz 1.0e-8) + rfuzz (abs rfuzz) + afuzz (or afuzz (/ rfuzz 10)) + afuzz (abs afuzz)) + (< (abs (- x y)) (+ afuzz (* rfuzz (+ (abs x) (abs y)))))) + +;;;###autoload +(defun hexrgb-color-value-to-float (n) + "Return the floating-point equivalent of color value N. +N must be an integer between 0 and 65535, or else an error is raised." + (unless (and (wholenump n) (<= n 65535)) + (error "Not a whole number less than 65536")) + (/ (float n) 65535.0)) + +;;;###autoload +(defun hexrgb-float-to-color-value (x) + "Return the color value equivalent of floating-point number X. +X must be between 0.0 and 1.0, or else an error is raised." + (unless (and (numberp x) (<= 0.0 x) (<= x 1.0)) + (error "Not a floating-point number between 0.0 and 1.0")) + (floor (* x 65535.0))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(provide 'hexrgb) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; hexrgb.el ends here |