diff -c -w color-BZR-2011-02-16.el color-2011-02-16.el
*** color-BZR-2011-02-16.el	Wed Feb 16 14:40:04 2011
--- color-2011-02-16.el	Wed Feb 16 15:46:08 2011
***************
*** 1,9 ****
! ;;; color.el --- Color manipulation laboratory routines -*- coding: utf-8; -*-
  
! ;; Copyright (C) 2010-2011 Free Software Foundation, Inc.
  
! ;; Author: Julien Danjou <julien@danjou.info>
! ;; Keywords: html
  
  ;; This file is part of GNU Emacs.
  
--- 1,10 ----
! ;;; color.el --- Color manipulation -*- coding: utf-8; -*-
  
! ;; Copyright (C) 2011 Free Software Foundation, Inc.
  
! ;; Author: Drew Adams <drew.adams@oracle.com>
! ;;	Julien Danjou <julien@danjou.info>
! ;; Keywords: color, hex, rgb, hsv, hsl, cie-lab, background, display, face
  
  ;; This file is part of GNU Emacs.
  
***************
*** 22,71 ****
  
  ;;; Commentary:
  
! ;; This package provides color manipulation functions.
  
  ;;; Code:
  
! (eval-when-compile
!   (require 'cl))
  
  ;; Emacs < 23.3
  (eval-and-compile
    (unless (boundp 'float-pi)
!     (defconst float-pi (* 4 (atan 1)) "The value of Pi (3.1415926...).")))
  
! (defun color-rgb->hex  (red green blue)
!   "Return hexadecimal notation for RED GREEN BLUE color.
! RED GREEN BLUE must be values between 0 and 1 inclusively."
!   (format "#%02x%02x%02x"
!           (* red 255) (* green 255) (* blue 255)))
! 
! (defun color-complement (color)
!   "Return the color that is the complement of COLOR."
!   (let ((color (color-rgb->normalize color)))
!     (list (- 1.0 (car color))
!           (- 1.0 (cadr color))
!           (- 1.0 (caddr color)))))
  
  (defun color-gradient (start stop step-number)
    "Return a list with STEP-NUMBER colors from START to STOP.
  The color list builds a color gradient starting at color START to
! color STOP. It does not include the START and STOP color in the
  resulting list."
    (loop for i from 1 to step-number
          with red-step = (/ (- (car stop) (car start)) (1+ step-number))
          with green-step = (/ (- (cadr stop) (cadr start)) (1+ step-number))
          with blue-step = (/ (- (caddr stop) (caddr start)) (1+ step-number))
!         collect (list
!                  (+ (car start) (* i red-step))
                   (+ (cadr start) (* i green-step))
                   (+ (caddr start) (* i blue-step)))))
  
! (defun color-complement-hex (color)
!   "Return the color that is the complement of COLOR, in hexadecimal format."
!   (apply 'color-rgb->hex (color-complement color)))
  
! (defun color-rgb->hsv (red green blue)
    "Convert RED GREEN BLUE values to HSV representation.
  Hue is in radians. Saturation and values are between 0 and 1
  inclusively."
--- 23,468 ----
  
  ;;; Commentary:
  
! ;; This library provides color manipulation functions.
! ;;
! ;; It provides functions for converting between RGB (red, green,
! ;; blue), HSV (hue, saturation, value), HSL (hue, saturation,
! ;; luminence), sRGB, CIE XYZ, and CIE L*a*b* color components.  It
! ;; helps you convert among all of the following:
! ;;
! ;; * Emacs RGB color components (aka color "values"), which are whole
! ;;   numbers from 0 through 65535
! ;; * RGB, HSV, HSL, sRGB, CIE XYZ, and CIE L*a*b* floating-point
! ;;   components (0.0 through 1.0)
! ;; * Emacs color-name strings, such as "blue"
! ;; * RGB triplet strings, such as "#FC43A7912"
! ;;
! ;; An RGB triplet string has 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
! ;; components.
! ;;
! ;; It also provides functions to do the following:
! ;; * Increment an RGB triplet (string) in various ways
! ;; * Return the complement of a color as an RGB triplet or components
! ;; * Return the CIEDE2000 color distance between two colors
! ;; * Return an individual floating-point RGB or HSV component of a
! ;;   color-name or RGB triplet string
! ;;
! ;; FIXME/TODO (?):
! ;;
! ;;  Add functions:
! ;;    color-hex-to-hsl, color-hsl-to-hex, color-hsl-to-rgb,
! ;;    color-hsv-radians-to-rgb, color-luminance
! ;;  color-cie-ε: Add doc string
! ;;  color-cie-κ: Add doc string
! ;;  color-cie-de2000:  Specify return value in doc string
! ;;  color-lab-to-srgb: Specify return value in doc string
! ;;  color-lab-to-xyz:  Specify return value in doc string
! ;;  color-srgb-to-lab: Specify return value in doc string
! ;;  color-srgb-to-xyz: Specify return value in doc string
! ;;  color-xyz-to-lab:  Specify return value in doc string
! ;;  color-xyz-to-srgb: Specify return value in doc string
  
  ;;; Code:
  
! (eval-when-compile (require 'cl))       ; loop
  
  ;; Emacs < 23.3
  (eval-and-compile
    (unless (boundp 'float-pi)
!     (defconst float-pi (* 4 (atan 1)) "The math constant pi (3.141592653589793...).")))
! 
! (eval-and-compile
!  (defun color-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  (color-delete-whitespace-from-string (downcase this) 0 (length this)))
!        (unless (member this new) (push this new))
!        (pop tail))
!      (nreverse new)))
! 
!  (defun color-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)))))
! 
! (defconst color-defined-colors (eval-when-compile (and window-system (x-defined-colors)))
!   "List of all supported colors.")
! 
! (defconst color-defined-colors-no-dups
!     (eval-when-compile
!      (and window-system (color-canonicalize-defined-colors (x-defined-colors))))
!   "List of all supported color names, with no duplicates.
! Names are all lowercase, without any spaces.")
! 
! (defconst color-d65-xyz '(0.950455 1.0 1.088753)
!   "D65 white point in CIE XYZ.")
! 
! ;; FIXME/TODO? Add doc string
! (defconst color-cie-ε (/ 216 24389.0))
! 
! ;; FIXME/TODO? Add doc string
! (defconst color-cie-κ (/ 24389 27.0))
! 
! (defcustom color-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 'faces)
! 
! ;; Use function `color-defined-colors', not the constants, so users
! ;; can change the behavior by customizing `color-canonicalize-defined-colors-flag'.
! 
! (defun color-defined-colors ()
!   "List of supported color names.
! If `color-canonicalize-defined-colors-flag' is non-nil, then names
! are lowercased, whitespace is removed, and there are no duplicates."
!   (if color-canonicalize-defined-colors-flag
!       color-defined-colors-no-dups
!     color-defined-colors))
! 
! (defun read-color (&optional prompt convert-to-RGB allow-empty-name msg)
!   "Read a color name or RGB triplet.
! Completion is available for color names, but not for RGB triplets.
! 
! RGB triplets have the form #XXXXXXXXXXXX, where each X is a
! hexadecimal digit.  The number of X's must be a multiple of 3, with
! the same number of X's for each of red, green, and blue.  The order of
! the color components 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 `color-canonicalize-defined-colors-flag' to nil.
! 
! In addition to standard color names and RGB hex components, the
! following are available as color candidates.  In each case, the
! corresponding color is used.
! 
!  * `foreground at point'   - foreground under the cursor
!  * `background at point'   - background under the cursor
! 
! Optional arg PROMPT is the prompt; if nil, use a default prompt.
! 
! Interactively, or with optional arg CONVERT-TO-RGB non-nil, convert an
! input color name to an RGB triplet string.  Return the triplet string.
! Otherwise, return the user input (color name or triplet) as a string.
! 
! If optional arg ALLOW-EMPTY-NAME is non-nil, the user is allowed
! to enter an empty color name (the empty string).
! 
! Interactively, or with optional arg MSG non-nil, print the returned
! string in the echo area."
!   (interactive "i\np\ni\np")    ; Always convert to RGB interactively.
!   (let* ((completion-ignore-case t)
! 	 (colors (or facemenu-color-alist
! 		     (append '("foreground at point" "background at point")
! 			     (if allow-empty-name '(""))
! 			     (color-defined-colors))))
! 	 (color (completing-read
! 		 (or prompt "Color (name or #RGB triplet): ")
! 		 ;; Completing function for colors - accepts color names & RGB triplets.
! 		 (lambda (string pred flag)
! 		   (cond
! 		    ((null flag) ; Try completion.
! 		     (or (try-completion string colors pred)
! 			 (if (color-defined-p string) string)))
! 		    ((eq flag t) ; List all completions.
! 		     (or (all-completions string colors pred)
! 			 (if (color-defined-p string) (list string))))
! 		    ((eq flag 'lambda) ; Test completion.
! 		     (or (memq string colors) (color-defined-p string)))))
! 		 nil t))
! 	 hex-string)
!     (when (member color colors)
!       (cond ((string-equal color "foreground at point")
!              (setq color (foreground-color-at-point)))
! 	    ((string-equal color "background at point")
!              (setq color (background-color-at-point))))
!       (when (and convert-to-RGB (not (string-equal color "")))
! 	(setq color  (color-name-to-hex color))))
!     (when msg (message "Color: `%s'" color))
!     color))
! 
! (defun color-rgb-hex-string-p (color &optional laxp)
!   "Non-nil if COLOR is an RGB triplet string \"#XXXXXXXXXXXX\".
! Each X is a hexadecimal digit.  The number of X's must be a multiple
! of 3, with the same number of X's for each of red, green, and blue.
! The first group of X's is for red, the second is for green, the third
! is for 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)))
! 
! ;; This version is thanks to Juri Linkov <juri@jurta.org>.
! (defun color-int-to-hex (int &optional nb-digits)
!   "Convert integer argument INT to a RGB triplet string.
! The string satisfies `color-rgb-hex-string-p'.
! 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)))
! 
! ;; These are the color "values" of `x-color-values', `ps-color-values', and
! ;; `ps-e-x-color-values'.  But especially given the use of "value" in HSV, "components" is
! ;; better in the name than "values".
! (defun color-components-to-hex (components)
!   "Convert list of rgb color COMPONENTS to an RGB triplet string.
! Input COMPONENTS is as for the output of `x-color-values'."
!   ;; Just hard-code 4 as the number of hex digits, since `x-color-values'
!   ;; seems to produce appropriate integer values.
!   (concat "#" (color-int-to-hex (nth 0 components) 4) ; red
!           (color-int-to-hex (nth 1 components) 4)     ; green
!           (color-int-to-hex (nth 2 components) 4)))   ; blue
! 
! (defun color-name-to-hex (color)
!   "Return the RGB triplet string for COLOR.
! COLOR is a color name.
! It can also be an RGB triplet, which is just returned as is.
! The string returned satisfies `color-rgb-hex-string-p'."
!   (let ((components  (x-color-values color)))
!     (unless components (error "No such color: %S" color))
!     (unless (color-rgb-hex-string-p color)
!       (setq color  (color-components-to-hex components))))
!   color)
! 
! (defun color-rgb-to-hex (red green blue)
!   "Return the RBG triplet for inputs RED, GREEN, BLUE.
! The inputs are each in the range 0 to 1, inclusive.
! The string returned satisfies `color-rgb-hex-string-p'."
!   (color-components-to-hex
!    (mapcar (lambda (x) (floor (* x 65535.0))) (list red green blue))))
! 
! (defun color-hsv-to-hex (hue saturation value)
!   "Return the RBG triplet string for inputs HUE, SATURATION, and VALUE.
! The inputs are each in the range 0 to 1, inclusive.
! The string returned satisfies `color-rgb-hex-string-p'."
!   (color-components-to-hex
!    (mapcar (lambda (x) (floor (* x 65535.0))) (color-hsv-to-rgb hue saturation value))))
! 
! ;; FIXME/TODO? (defun color-hsl-to-hex ...)
! 
! ;; Same as `hexl-hex-char-to-integer', defined in `hexl.el'.
! (defun color-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)))))
! 
! (defun color-hex-to-int (hex)
!   "Convert hexadecimal string HEX to a whole-number value.
! The characters of HEX must be hexadecimal-digit characters."
!   (let* ((factor  1)
!          (len     (length hex))
!          (indx    (1- len))
!          (int     0))
!     (while (>= indx 0)
!       (setq int     (+ int (* factor (color-hex-char-to-integer (aref hex indx))))
!             indx    (1- indx)
!             factor  (* 16 factor)))
!     int))
! 
! (defun color-hex-to-components (rgb-triplet)
!   "Return the RGB color components for RGB-TRIPLET.
! RGB-TRIPLET is an RGB triplet string (`color-rgb-hex-string-p').
! 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]\\)+\\)$"
!                       rgb-triplet))
!          (ndigits    (/ (if (eq (match-beginning 1) (match-end 1))
!                             (length rgb-triplet)
!                           (1- (length rgb-triplet)))
!                         3))
!          red green blue)
!     (unless hex-strgp (error "Invalid RGB triplet string: %s" rgb-triplet))
!     (setq rgb-triplet  (substring rgb-triplet (match-beginning 2) (match-end 2))
!           red    (color-hex-to-int (substring rgb-triplet 0 ndigits))
!           green  (color-hex-to-int (substring rgb-triplet ndigits (* 2 ndigits)))
!           blue   (color-hex-to-int (substring rgb-triplet (* 2 ndigits) (* 3 ndigits))))
!     (list red green blue)))
! 
! (defun color-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 RGB triplet string (satisfies
! `color-rgb-hex-string-p')."
!   (unless (color-rgb-hex-string-p color) (setq color  (color-name-to-hex color)))
!   (let ((len  (/ (1- (length color)) 3)))
!     (list (/ (color-hex-to-int (substring color 1 (1+ len))) 65535.0)
!           (/ (color-hex-to-int (substring color (1+ len) (+ 1 len len))) 65535.0)
!           (/ (color-hex-to-int (substring color (+ 1 len len))) 65535.0))))
! 
! (defun color-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 RGB triplet string (satisfies
! `color-rgb-hex-string-p')."
!   (let ((rgb-components  (color-hex-to-rgb color)))
!     (apply #'color-rgb-to-hsv rgb-components)))
! 
! ;; FIXME/TODO? (defun color-hex-to-hsl ...)
! 
! (defun color-red (color)
!   "Return the red component of COLOR, in range 0 to 1, inclusive.
! COLOR is a color name or RGB triplet string."
!   (interactive (list (read-color)))
!   (setq color  (color-name-to-hex color))
!   (/ (color-hex-to-int (substring color 1 (1+ (/ (1- (length color)) 3))))
!      (expt 16.0 (/ (1- (length color)) 3.0))))
! 
! (defun color-green (color)
!   "Return the green component of COLOR, in range 0 to 1, inclusive.
! COLOR is a color name or RGB triplet string."
!   (interactive (list (read-color)))
!   (setq color  (color-name-to-hex color))
!   (let* ((len    (/ (1- (length color)) 3))
!          (start  (1+ len)))
!     (/ (color-hex-to-int (substring color start (+ start len)))
!        (expt 16.0 (/ (1- (length color)) 3.0)))))
! 
! (defun color-blue (color)
!   "Return the blue component of COLOR, in range 0 to 1, inclusive.
! COLOR is a color name or RGB triplet string."
!   (interactive (list (read-color)))
!   (setq color  (color-name-to-hex color))
!   (let* ((len    (/ (1- (length color)) 3))
!          (start  (+ 1 len len)))
!     (/ (color-hex-to-int (substring color start (+ start len)))
!        (expt 16.0 (/ (1- (length color)) 3.0)))))
! 
! (defun color-hue (color)
!   "Return the hue component of COLOR, in range 0 to 1, inclusive.
! COLOR is a color name or RGB triplet string."
!   (interactive (list (read-color)))
!   (setq color  (color-name-to-hex color))
!   (car (color-rgb-to-hsv (color-red color) (color-green color) (color-blue color))))
! 
! (defun color-saturation (color)
!   "Return the saturation component of COLOR, in range 0 to 1, inclusive.
! COLOR is a color name or RGB triplet string."
!   (interactive (list (read-color)))
!   (setq color  (color-name-to-hex color))
!   (cadr (color-rgb-to-hsv (color-red color) (color-green color) (color-blue color))))
! 
! (defun color-value (color)
!   "Return the value component of COLOR, in range 0 to 1, inclusive.
! COLOR is a color name or RGB triplet string."
!   (interactive (list (read-color)))
!   (setq color  (color-name-to-hex color))
!   (caddr (color-rgb-to-hsv (color-red color) (color-green color) (color-blue color))))
! 
! ;; FIXME/TODO? (defun color-luminance ...)
! 
! (defun color-rgb-normalize (color)
!   "Return the normalized RGB components of COLOR as a list.
! COLOR is a color name or RGB triplet string.
! Each component returned is 0 to 1, inclusive."
!   (mapcar (lambda (x) (/ x 65535.0)) (x-color-values color)))
  
! (defun color-complement-hex (color-name)
!   "Return the complement of COLOR-NAME as an RGB triplet.
! \(COLOR-NAME can also be an RGB triplet - it is just returned.)
! Interactively, you are prompted for COLOR-NAME."
!   (interactive (list (read-color)))
!   (apply 'color-rgb-to-hex (color-complement-components color-name)))
! 
! (defun color-complement-components (color)
!   "Return the RGB color components for the complement of COLOR.
! COLOR is a color name or RGB triplet string."
!   (let ((color  (color-rgb-normalize color)))
!     (list (- 1.0 (car color)) (- 1.0 (cadr color)) (- 1.0 (caddr color)))))
  
  (defun color-gradient (start stop step-number)
    "Return a list with STEP-NUMBER colors from START to STOP.
  The color list builds a color gradient starting at color START to
! color STOP.  It does not include the START and STOP colors in the
  resulting list."
    (loop for i from 1 to step-number
       with red-step = (/ (- (car stop) (car start)) (1+ step-number))
       with green-step = (/ (- (cadr stop) (cadr start)) (1+ step-number))
       with blue-step = (/ (- (caddr stop) (caddr start)) (1+ step-number))
!      collect (list (+ (car start) (* i red-step))
                     (+ (cadr start) (* i green-step))
                     (+ (caddr start) (* i blue-step)))))
  
! ;; From Elisp Info manual, node "Comparison of Numbers".
! (defun color-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))))))
! 
! (defun color-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 (color-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.  Standard test for a NaN is (not (= N N)),
!                (= saturation saturation))
!           (if (color-approx-equal 0.0 saturation)
!               (setq hue         0.0
!                     saturation  0.0)    ; Again, no color - only value.
!             (setq hue  (if (color-approx-equal red max)
!                            (/ (- green blue) delta) ; Between yellow & magenta.
!                          (if (color-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))))
!         (setq hue         0.0           ; Div by zero (max=0): H:=0, S:=0. (Hue undefined.)
!               saturation  0.0)))
!     (list hue saturation value)))
  
! (defun color-rgb-to-hsv-radians (red green blue)
    "Convert RED GREEN BLUE values to HSV representation.
  Hue is in radians. Saturation and values are between 0 and 1
  inclusively."
***************
*** 93,101 ****
          (- 1 (/ min max)))
        (/ max 255.0))))
  
! (defun color-rgb->hsl (red green blue)
    "Convert RED GREEN BLUE colors to their HSL representation.
! RED, GREEN and BLUE must be between 0 and 1 inclusively."
    (let* ((r red)
           (g green)
           (b blue)
--- 490,536 ----
         (- 1 (/ min max)))
       (/ max 255.0))))
  
! ;; FIXME/TODO? (defun color-hsv-radians-to-rgb ...)
! 
! (defun color-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 (color-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)))
! 
! (defun color-rgb-to-hsl (red green blue)
    "Convert RED GREEN BLUE colors to their HSL representation.
! RED, GREEN and BLUE must be from 0 to 1, inclusive."
    (let* ((r red)
           (g green)
           (b blue)
***************
*** 121,129 ****
           (/ delta (+ max min))))
       l)))
  
! (defun color-srgb->xyz (red green blue)
!   "Converts RED GREEN BLUE colors from the sRGB color space to CIE XYZ.
! RED, BLUE and GREEN must be between 0 and 1 inclusively."
    (let ((r (if (<= red 0.04045)
                 (/ red 12.95)
               (expt (/ (+ red 0.055) 1.055) 2.4)))
--- 556,567 ----
           (/ delta (+ max min))))
       l)))
  
! ;; FIXME/TODO? (defun color-hsl-to-rgb ...)
! 
! ;; FIXME/TODO? Specify return value in doc string.
! (defun color-srgb-to-xyz (red green blue)
!   "Convert RED GREEN BLUE colors from the sRGB color space to CIE XYZ.
! RED, BLUE and GREEN must be from 0 to 1, inclusive."
    (let ((r (if (<= red 0.04045)
                 (/ red 12.95)
               (expt (/ (+ red 0.055) 1.055) 2.4)))
***************
*** 137,144 ****
            (+ (* 0.21266729 r) (* 0.7151522 g) (* 0.0721750 b))
            (+ (* 0.0193339 r) (* 0.1191920 g) (* 0.9503041 b)))))
  
! (defun color-xyz->srgb (X Y Z)
!   "Converts CIE X Y Z colors to sRGB color space."
    (let ((r (+ (* 3.2404542 X) (* -1.5371385 Y) (* -0.4985314 Z)))
          (g (+ (* -0.9692660 X) (* 1.8760108 Y) (* 0.0415560 Z)))
          (b (+ (* 0.0556434 X) (* -0.2040259 Y) (* 1.0572252 Z))))
--- 575,583 ----
            (+ (* 0.21266729 r) (* 0.7151522 g) (* 0.0721750 b))
            (+ (* 0.0193339 r) (* 0.1191920 g) (* 0.9503041 b)))))
  
! ;; FIXME/TODO? Specify return value in doc string.
! (defun color-xyz-to-srgb (X Y Z)
!   "Convert CIE X Y Z colors to sRGB color space."
    (let ((r (+ (* 3.2404542 X) (* -1.5371385 Y) (* -0.4985314 Z)))
          (g (+ (* -0.9692660 X) (* 1.8760108 Y) (* 0.0415560 Z)))
          (b (+ (* 0.0556434 X) (* -0.2040259 Y) (* 1.0572252 Z))))
***************
*** 152,165 ****
                (* 12.92 b)
              (- (* 1.055 (expt b (/ 1 2.4))) 0.055)))))
  
! (defconst color-d65-xyz '(0.950455 1.0 1.088753)
!   "D65 white point in CIE XYZ.")
! 
! (defconst color-cie-ε (/ 216 24389.0))
! (defconst color-cie-κ (/ 24389 27.0))
! 
! (defun color-xyz->lab (X Y Z &optional white-point)
!   "Converts CIE XYZ to CIE L*a*b*.
  WHITE-POINT can be specified as (X Y Z) white point to use. If
  none is set, `color-d65-xyz' is used."
    (destructuring-bind (Xr Yr Zr) (or white-point color-d65-xyz)
--- 591,599 ----
                (* 12.92 b)
              (- (* 1.055 (expt b (/ 1 2.4))) 0.055)))))
  
! ;; FIXME/TODO? Specify return value in doc string.
! (defun color-xyz-to-lab (X Y Z &optional white-point)
!   "Convert CIE XYZ to CIE L*a*b*.
  WHITE-POINT can be specified as (X Y Z) white point to use. If
  none is set, `color-d65-xyz' is used."
    (destructuring-bind (Xr Yr Zr) (or white-point color-d65-xyz)
***************
*** 180,187 ****
           (* 500 (- fx fy))                  ; a
           (* 200 (- fy fz))))))              ; b
  
! (defun color-lab->xyz (L a b &optional white-point)
!   "Converts CIE L*a*b* to CIE XYZ.
  WHITE-POINT can be specified as (X Y Z) white point to use. If
  none is set, `color-d65-xyz' is used."
    (destructuring-bind (Xr Yr Zr) (or white-point color-d65-xyz)
--- 614,622 ----
           (* 500 (- fx fy))                  ; a
           (* 200 (- fy fz))))))              ; b
  
! ;; FIXME/TODO? Specify return value in doc string.
! (defun color-lab-to-xyz (L a b &optional white-point)
!   "Convert CIE L*a*b* to CIE XYZ.
  WHITE-POINT can be specified as (X Y Z) white point to use. If
  none is set, `color-d65-xyz' is used."
    (destructuring-bind (Xr Yr Zr) (or white-point color-d65-xyz)
***************
*** 201,218 ****
                (* yr Yr)                 ; Y
                (* zr Zr)))))             ; Z
  
! (defun color-srgb->lab (red green blue)
!   "Converts RGB to CIE L*a*b*."
!   (apply 'color-xyz->lab (color-srgb->xyz red green blue)))
! 
! (defun color-rgb->normalize (color)
!   "Normalize a RGB color to values between 0 and 1 inclusively."
!   (mapcar (lambda (x) (/ x 65535.0)) (x-color-values color)))
! 
! (defun color-lab->srgb (L a b)
!   "Converts CIE L*a*b* to RGB."
!   (apply 'color-xyz->srgb (color-lab->xyz L a b)))
  
  (defun color-cie-de2000 (color1 color2 &optional kL kC kH)
    "Computes the CIEDE2000 color distance between COLOR1 and COLOR2.
  Colors must be in CIE L*a*b* format."
--- 636,652 ----
                (* yr Yr)                 ; Y
                (* zr Zr)))))             ; Z
  
! ;; FIXME/TODO? Specify return value in doc string.
! (defun color-srgb-to-lab (red green blue)
!   "Convert RGB to CIE L*a*b*."
!   (apply 'color-xyz-to-lab (color-srgb-to-xyz red green blue)))
! 
! ;; FIXME/TODO? Specify return value in doc string.
! (defun color-lab-to-srgb (L a b)
!   "Convert CIE L*a*b* to RGB."
!   (apply 'color-xyz-to-srgb (color-lab-to-xyz L a b)))
  
+ ;; FIXME/TODO? Specify return value in doc string.
  (defun color-cie-de2000 (color1 color2 &optional kL kC kH)
    "Computes the CIEDE2000 color distance between COLOR1 and COLOR2.
  Colors must be in CIE L*a*b* format."
***************
*** 267,273 ****
                     (* 0.24 (cos (* h̄′ 2)))
                     (* 0.32 (cos (+ (* h̄′ 3) (degrees-to-radians 6))))
                     (- (* 0.20 (cos (- (* h̄′ 4) (degrees-to-radians 63)))))))
!              (Δθ (* (degrees-to-radians 30) (exp (- (expt (/ (- h̄′ (degrees-to-radians 275)) (degrees-to-radians 25)) 2.0)))))
               (Rc (* 2 (sqrt (/ (expt C̄′ 7.0) (+ (expt C̄′ 7.0) (expt 25.0 7.0))))))
               (Sl (+ 1 (/ (* 0.015 (expt (- L̄′ 50) 2.0)) (sqrt (+ 20 (expt (- L̄′ 50) 2.0))))))
               (Sc (+ 1 (* C̄′ 0.045)))
--- 701,709 ----
                     (* 0.24 (cos (* h̄′ 2)))
                     (* 0.32 (cos (+ (* h̄′ 3) (degrees-to-radians 6))))
                     (- (* 0.20 (cos (- (* h̄′ 4) (degrees-to-radians 63)))))))
!              (Δθ (* (degrees-to-radians 30)
!                     (exp (- (expt (/ (- h̄′ (degrees-to-radians 275)) (degrees-to-radians 25))
!                                   2.0)))))
               (Rc (* 2 (sqrt (/ (expt C̄′ 7.0) (+ (expt C̄′ 7.0) (expt 25.0 7.0))))))
               (Sl (+ 1 (/ (* 0.015 (expt (- L̄′ 50) 2.0)) (sqrt (+ 20 (expt (- L̄′ 50) 2.0))))))
               (Sc (+ 1 (* C̄′ 0.045)))
***************
*** 278,283 ****
--- 714,803 ----
                   (expt (/ ΔH′ (* Sh kH)) 2.0)
                   (* Rt (/ ΔC′ (* Sc kC)) (/ ΔH′ (* Sh kH)))))))))
  
+ (defun color-component-to-float (n)
+   "Return the floating-point equivalent of color-component 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))
+ 
+ (defun color-float-to-component (x)
+   "Return the color-component 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)))
+ 
+ (defun color-increment-hex (hex nb-digits increment &optional wrap-p)
+   "Increment HEX number (a string NB-DIGITS long) by INCREMENT.
+ If optional arg WRAP-P is non-nil then the result wraps around zero.
+   For example, with NB-DIGITS 3, incrementing \"fff\" by 1 causes it
+   to wrap around to \"000\"."
+   (let* ((int      (color-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.
+         (color-int-to-hex new-int nb-digits) ; Use incremented number.
+       hex)))                            ; Don't increment.
+ 
+ (defun color-increment-red (hex nb-digits increment &optional wrap-p)
+   "Increment red component of RGB triplet string HEX by INCREMENT.
+ String HEX satisfies `color-rgb-hex-string-p'.
+ Each component in HEX is NB-DIGITS hex digits long.
+ If optional arg WRAP-P is non-nil then the result wraps around zero.
+   For example, with NB-DIGITS 3, incrementing \"#fffffffff\" by 1
+   causes it to wrap around to \"#000ffffff\"."
+   (concat "#"
+           (color-increment-hex (substring hex 1 (1+ nb-digits)) nb-digits increment wrap-p)
+           (substring hex (1+ nb-digits) (1+ (* nb-digits 2)))
+           (substring hex (1+ (* nb-digits 2)))))
+ 
+ (defun color-increment-green (hex nb-digits increment &optional wrap-p)
+   "Increment green component of RGB triplet string HEX by INCREMENT.
+ String HEX satisfies `color-rgb-hex-string-p'.
+ Each component in HEX is NB-DIGITS hex digits long.
+ If optional arg WRAP-P is non-nil then the result wraps around zero.
+   For example, with NB-DIGITS 3, incrementing \"#fffffffff\" by 1
+   causes it to wrap around to \"#fff000fff\"."
+   (concat
+    "#" (substring hex 1 (1+ nb-digits))
+    (color-increment-hex (substring hex (1+ nb-digits) (1+ (* nb-digits 2)))
+                          nb-digits
+                          increment
+                          wrap-p)
+    (substring hex (1+ (* nb-digits 2)))))
+ 
+ (defun color-increment-blue (hex nb-digits increment &optional wrap-p)
+   "Increment blue component of RGB triplet string HEX by INCREMENT.
+ String HEX satisfies `color-rgb-hex-string-p'.
+ Each component in HEX is NB-DIGITS hex digits long.
+ If optional arg WRAP-P is non-nil then the result wraps around zero.
+   For example, with NB-DIGITS 3, incrementing \"#fffffffff\" by 1
+   causes it to wrap around to \"#ffffff000\"."
+   (concat "#" (substring hex 1 (1+ (* nb-digits 2)))
+           (color-increment-hex (substring hex (1+ (* nb-digits 2)))
+                                 nb-digits
+                                 increment
+                                 wrap-p)))
+ 
+ (defun color-increment-equal-rgb (hex nb-digits increment &optional wrap-p)
+   "Increment each color component (r,g,b) 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, with NB-DIGITS 3, incrementing \"#fffffffff\" by 1
+   causes it to wrap around to \"#000000000\"."
+   (concat
+    "#"
+    (color-increment-hex (substring hex 1 (1+ nb-digits)) nb-digits increment wrap-p)
+    (color-increment-hex (substring hex (1+ nb-digits) (1+ (* nb-digits 2)))
+                          nb-digits
+                          increment
+                          wrap-p)
+    (color-increment-hex (substring hex (1+ (* nb-digits 2))) nb-digits increment wrap-p)))
+ 
+ 
  (provide 'color)
  
  ;;; color.el ends here

Diff finished.  Wed Feb 16 15:59:47 2011
