From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!not-for-mail From: "Drew Adams" Newsgroups: gmane.emacs.devel Subject: color.el Date: Wed, 16 Feb 2011 16:23:00 -0800 Message-ID: NNTP-Posting-Host: lo.gmane.org Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="----=_NextPart_000_00F1_01CBCDF5.C7BE9A30" X-Trace: dough.gmane.org 1297902367 25047 80.91.229.12 (17 Feb 2011 00:26:07 GMT) X-Complaints-To: usenet@dough.gmane.org NNTP-Posting-Date: Thu, 17 Feb 2011 00:26:07 +0000 (UTC) To: Original-X-From: emacs-devel-bounces+ged-emacs-devel=m.gmane.org@gnu.org Thu Feb 17 01:26:03 2011 Return-path: Envelope-to: ged-emacs-devel@m.gmane.org Original-Received: from lists.gnu.org ([199.232.76.165]) by lo.gmane.org with esmtp (Exim 4.69) (envelope-from ) id 1Pprex-0004om-4Z for ged-emacs-devel@m.gmane.org; Thu, 17 Feb 2011 01:26:03 +0100 Original-Received: from localhost ([127.0.0.1]:38015 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.43) id 1Pprev-00033d-Gj for ged-emacs-devel@m.gmane.org; Wed, 16 Feb 2011 19:23:49 -0500 Original-Received: from [140.186.70.92] (port=38761 helo=eggs.gnu.org) by lists.gnu.org with esmtp (Exim 4.43) id 1Ppreo-00033Y-3M for emacs-devel@gnu.org; Wed, 16 Feb 2011 19:23:43 -0500 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1Ppren-0007nY-4A for emacs-devel@gnu.org; Wed, 16 Feb 2011 19:23:42 -0500 Original-Received: from rcsinet10.oracle.com ([148.87.113.121]:27076) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1Pprem-0007nQ-MQ for emacs-devel@gnu.org; Wed, 16 Feb 2011 19:23:41 -0500 Original-Received: from rcsinet13.oracle.com (rcsinet13.oracle.com [148.87.113.125]) by rcsinet10.oracle.com (Switch-3.4.2/Switch-3.4.2) with ESMTP id p1H0Nbj5008267 (version=TLSv1/SSLv3 cipher=DHE-RSA-AES256-SHA bits=256 verify=OK) for ; Thu, 17 Feb 2011 00:23:38 GMT Original-Received: from acsmt355.oracle.com (acsmt355.oracle.com [141.146.40.155]) by rcsinet13.oracle.com (Switch-3.4.2/Switch-3.4.1) with ESMTP id p1GL9Cfp028302 for ; Thu, 17 Feb 2011 00:23:35 GMT Original-Received: from abhmt013.oracle.com by acsmt355.oracle.com with ESMTP id 1061824591297902180; Wed, 16 Feb 2011 16:23:00 -0800 Original-Received: from dradamslap1 (/10.159.48.107) by default (Oracle Beehive Gateway v4.0) with ESMTP ; Wed, 16 Feb 2011 16:22:57 -0800 X-Mailer: Microsoft Office Outlook 11 Thread-Index: AcvOONUSs5vawxyaSuubTlIx6H7Lsw== X-MimeOLE: Produced By Microsoft MimeOLE V6.00.2900.5994 X-Source-IP: acsmt355.oracle.com [141.146.40.155] X-Auth-Type: Internal IP X-CT-RefId: str=0001.0A090204.4D5C6A89.0019:SCFMA4539814,ss=1,fgs=0 X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.6 (newer, 3) X-Received-From: 148.87.113.121 X-BeenThere: emacs-devel@gnu.org X-Mailman-Version: 2.1.5 Precedence: list List-Id: "Emacs development discussions." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Original-Sender: emacs-devel-bounces+ged-emacs-devel=m.gmane.org@gnu.org Errors-To: emacs-devel-bounces+ged-emacs-devel=m.gmane.org@gnu.org Xref: news.gmane.org gmane.emacs.devel:136122 Archived-At: This is a multi-part message in MIME format. ------=_NextPart_000_00F1_01CBCDF5.C7BE9A30 Content-Type: text/plain; charset="us-ascii" Content-Transfer-Encoding: 7bit I thought that `hexrgb.el' and `color-lab.el' were going to be merged. I suggested the name `color.el' for the combination, which was accepted. See the thread, from 2010/11: http://lists.gnu.org/archive/html/emacs-devel/2010-11/msg00897.html http://lists.gnu.org/archive/html/emacs-devel/2010-11/msg00894.html Instead, it seems that all that has happened so far is that `color-lab.el' was renamed `color.el'. AFAICT there is nothing from `hexrgb.el' in the file. In addition, Yidong mentioned moving `read-color' there, but that has not been done yet either. I've merged the two libraries now, moved `read-color' to it, and cleaned things up (e.g. doc). When there was overlap I kept the best version (e.g. most precise or most general). I did not include anything from `eyedropper.el' (e.g. for `read-color'). Attached is the result, both a patch from the latest `color.el' and the new result. (`read-color' also needs to be removed from `faces.el' - I did not include that patch.) ------=_NextPart_000_00F1_01CBCDF5.C7BE9A30 Content-Type: application/octet-stream; name="color-2011-02-16.patch" Content-Transfer-Encoding: quoted-printable Content-Disposition: attachment; filename="color-2011-02-16.patch" diff -c -w color-BZR-2011-02-16.el color-2011-02-16.el=0A= *** color-BZR-2011-02-16.el Wed Feb 16 14:40:04 2011=0A= --- color-2011-02-16.el Wed Feb 16 15:46:08 2011=0A= ***************=0A= *** 1,9 ****=0A= ! ;;; color.el --- Color manipulation laboratory routines -*- coding: = utf-8; -*-=0A= =0A= ! ;; Copyright (C) 2010-2011 Free Software Foundation, Inc.=0A= =0A= ! ;; Author: Julien Danjou =0A= ! ;; Keywords: html=0A= =0A= ;; This file is part of GNU Emacs.=0A= =0A= --- 1,10 ----=0A= ! ;;; color.el --- Color manipulation -*- coding: utf-8; -*-=0A= =0A= ! ;; Copyright (C) 2011 Free Software Foundation, Inc.=0A= =0A= ! ;; Author: Drew Adams =0A= ! ;; Julien Danjou =0A= ! ;; Keywords: color, hex, rgb, hsv, hsl, cie-lab, background, display, = face=0A= =0A= ;; This file is part of GNU Emacs.=0A= =0A= ***************=0A= *** 22,71 ****=0A= =0A= ;;; Commentary:=0A= =0A= ! ;; This package provides color manipulation functions.=0A= =0A= ;;; Code:=0A= =0A= ! (eval-when-compile=0A= ! (require 'cl))=0A= =0A= ;; Emacs < 23.3=0A= (eval-and-compile=0A= (unless (boundp 'float-pi)=0A= ! (defconst float-pi (* 4 (atan 1)) "The value of Pi = (3.1415926...).")))=0A= =0A= ! (defun color-rgb->hex (red green blue)=0A= ! "Return hexadecimal notation for RED GREEN BLUE color.=0A= ! RED GREEN BLUE must be values between 0 and 1 inclusively."=0A= ! (format "#%02x%02x%02x"=0A= ! (* red 255) (* green 255) (* blue 255)))=0A= ! =0A= ! (defun color-complement (color)=0A= ! "Return the color that is the complement of COLOR."=0A= ! (let ((color (color-rgb->normalize color)))=0A= ! (list (- 1.0 (car color))=0A= ! (- 1.0 (cadr color))=0A= ! (- 1.0 (caddr color)))))=0A= =0A= (defun color-gradient (start stop step-number)=0A= "Return a list with STEP-NUMBER colors from START to STOP.=0A= The color list builds a color gradient starting at color START to=0A= ! color STOP. It does not include the START and STOP color in the=0A= resulting list."=0A= (loop for i from 1 to step-number=0A= with red-step =3D (/ (- (car stop) (car start)) (1+ = step-number))=0A= with green-step =3D (/ (- (cadr stop) (cadr start)) (1+ = step-number))=0A= with blue-step =3D (/ (- (caddr stop) (caddr start)) (1+ = step-number))=0A= ! collect (list=0A= ! (+ (car start) (* i red-step))=0A= (+ (cadr start) (* i green-step))=0A= (+ (caddr start) (* i blue-step)))))=0A= =0A= ! (defun color-complement-hex (color)=0A= ! "Return the color that is the complement of COLOR, in hexadecimal = format."=0A= ! (apply 'color-rgb->hex (color-complement color)))=0A= =0A= ! (defun color-rgb->hsv (red green blue)=0A= "Convert RED GREEN BLUE values to HSV representation.=0A= Hue is in radians. Saturation and values are between 0 and 1=0A= inclusively."=0A= --- 23,468 ----=0A= =0A= ;;; Commentary:=0A= =0A= ! ;; This library provides color manipulation functions.=0A= ! ;;=0A= ! ;; It provides functions for converting between RGB (red, green,=0A= ! ;; blue), HSV (hue, saturation, value), HSL (hue, saturation,=0A= ! ;; luminence), sRGB, CIE XYZ, and CIE L*a*b* color components. It=0A= ! ;; helps you convert among all of the following:=0A= ! ;;=0A= ! ;; * Emacs RGB color components (aka color "values"), which are whole=0A= ! ;; numbers from 0 through 65535=0A= ! ;; * RGB, HSV, HSL, sRGB, CIE XYZ, and CIE L*a*b* floating-point=0A= ! ;; components (0.0 through 1.0)=0A= ! ;; * Emacs color-name strings, such as "blue"=0A= ! ;; * RGB triplet strings, such as "#FC43A7912"=0A= ! ;;=0A= ! ;; An RGB triplet string has 1 + (3 * n) characters, the first of=0A= ! ;; which is "#". The other characters are hexadecimal digits, in=0A= ! ;; three groups representing (from the left): red, green, and blue=0A= ! ;; components.=0A= ! ;;=0A= ! ;; It also provides functions to do the following:=0A= ! ;; * Increment an RGB triplet (string) in various ways=0A= ! ;; * Return the complement of a color as an RGB triplet or components=0A= ! ;; * Return the CIEDE2000 color distance between two colors=0A= ! ;; * Return an individual floating-point RGB or HSV component of a=0A= ! ;; color-name or RGB triplet string=0A= ! ;;=0A= ! ;; FIXME/TODO (?):=0A= ! ;;=0A= ! ;; Add functions:=0A= ! ;; color-hex-to-hsl, color-hsl-to-hex, color-hsl-to-rgb,=0A= ! ;; color-hsv-radians-to-rgb, color-luminance=0A= ! ;; color-cie-=CE=B5: Add doc string=0A= ! ;; color-cie-=CE=BA: Add doc string=0A= ! ;; color-cie-de2000: Specify return value in doc string=0A= ! ;; color-lab-to-srgb: Specify return value in doc string=0A= ! ;; color-lab-to-xyz: Specify return value in doc string=0A= ! ;; color-srgb-to-lab: Specify return value in doc string=0A= ! ;; color-srgb-to-xyz: Specify return value in doc string=0A= ! ;; color-xyz-to-lab: Specify return value in doc string=0A= ! ;; color-xyz-to-srgb: Specify return value in doc string=0A= =0A= ;;; Code:=0A= =0A= ! (eval-when-compile (require 'cl)) ; loop=0A= =0A= ;; Emacs < 23.3=0A= (eval-and-compile=0A= (unless (boundp 'float-pi)=0A= ! (defconst float-pi (* 4 (atan 1)) "The math constant pi = (3.141592653589793...).")))=0A= ! =0A= ! (eval-and-compile=0A= ! (defun color-canonicalize-defined-colors (list)=0A= ! "Copy of LIST with color names canonicalized.=0A= ! LIST is a list of color names (strings).=0A= ! Canonical names are lowercase, with no whitespace.=0A= ! There are no duplicate names."=0A= ! (let ((tail list)=0A= ! this new)=0A= ! (while tail=0A= ! (setq this (car tail)=0A= ! this (color-delete-whitespace-from-string (downcase = this) 0 (length this)))=0A= ! (unless (member this new) (push this new))=0A= ! (pop tail))=0A= ! (nreverse new)))=0A= ! =0A= ! (defun color-delete-whitespace-from-string (string &optional from to)=0A= ! "Remove whitespace from substring of STRING from FROM to TO.=0A= ! If FROM is nil, then start at the beginning of STRING (FROM =3D 0).=0A= ! If TO is nil, then end at the end of STRING (TO =3D length of STRING).=0A= ! FROM and TO are zero-based indexes into STRING.=0A= ! Character FROM is affected (possibly deleted). Character TO is not."=0A= ! (setq from (or from 0)=0A= ! to (or to (length string)))=0A= ! (with-temp-buffer=0A= ! (insert string)=0A= ! (goto-char (+ from (point-min)))=0A= ! (let ((count from)=0A= ! char)=0A= ! (while (and (not (eobp)) (< count to))=0A= ! (setq char (char-after))=0A= ! (if (memq char '(?\ ?\t ?\n)) (delete-char 1) = (forward-char 1))=0A= ! (setq count (1+ count)))=0A= ! (buffer-string)))))=0A= ! =0A= ! (defconst color-defined-colors (eval-when-compile (and window-system = (x-defined-colors)))=0A= ! "List of all supported colors.")=0A= ! =0A= ! (defconst color-defined-colors-no-dups=0A= ! (eval-when-compile=0A= ! (and window-system (color-canonicalize-defined-colors = (x-defined-colors))))=0A= ! "List of all supported color names, with no duplicates.=0A= ! Names are all lowercase, without any spaces.")=0A= ! =0A= ! (defconst color-d65-xyz '(0.950455 1.0 1.088753)=0A= ! "D65 white point in CIE XYZ.")=0A= ! =0A= ! ;; FIXME/TODO? Add doc string=0A= ! (defconst color-cie-=CE=B5 (/ 216 24389.0))=0A= ! =0A= ! ;; FIXME/TODO? Add doc string=0A= ! (defconst color-cie-=CE=BA (/ 24389 27.0))=0A= ! =0A= ! (defcustom color-canonicalize-defined-colors-flag t=0A= ! "*Non-nil means remove duplicate color names.=0A= ! Names are considered duplicates if they are the same when abstracting=0A= ! from whitespace and letter case."=0A= ! :type 'boolean :group 'faces)=0A= ! =0A= ! ;; Use function `color-defined-colors', not the constants, so users=0A= ! ;; can change the behavior by customizing = `color-canonicalize-defined-colors-flag'.=0A= ! =0A= ! (defun color-defined-colors ()=0A= ! "List of supported color names.=0A= ! If `color-canonicalize-defined-colors-flag' is non-nil, then names=0A= ! are lowercased, whitespace is removed, and there are no duplicates."=0A= ! (if color-canonicalize-defined-colors-flag=0A= ! color-defined-colors-no-dups=0A= ! color-defined-colors))=0A= ! =0A= ! (defun read-color (&optional prompt convert-to-RGB allow-empty-name = msg)=0A= ! "Read a color name or RGB triplet.=0A= ! Completion is available for color names, but not for RGB triplets.=0A= ! =0A= ! RGB triplets have the form #XXXXXXXXXXXX, where each X is a=0A= ! hexadecimal digit. The number of X's must be a multiple of 3, with=0A= ! the same number of X's for each of red, green, and blue. The order of=0A= ! the color components is red, green, blue.=0A= ! =0A= ! Color names that are normally considered equivalent are canonicalized:=0A= ! They are lowercased, whitespace is removed, and duplicates are=0A= ! eliminated. E.g. \"LightBlue\" and \"light blue\" are both replaced=0A= ! by \"lightblue\". If you do not want this behavior, but want to=0A= ! choose names that might contain whitespace or uppercase letters, then=0A= ! customize option `color-canonicalize-defined-colors-flag' to nil.=0A= ! =0A= ! In addition to standard color names and RGB hex components, the=0A= ! following are available as color candidates. In each case, the=0A= ! corresponding color is used.=0A= ! =0A= ! * `foreground at point' - foreground under the cursor=0A= ! * `background at point' - background under the cursor=0A= ! =0A= ! Optional arg PROMPT is the prompt; if nil, use a default prompt.=0A= ! =0A= ! Interactively, or with optional arg CONVERT-TO-RGB non-nil, convert an=0A= ! input color name to an RGB triplet string. Return the triplet string.=0A= ! Otherwise, return the user input (color name or triplet) as a string.=0A= ! =0A= ! If optional arg ALLOW-EMPTY-NAME is non-nil, the user is allowed=0A= ! to enter an empty color name (the empty string).=0A= ! =0A= ! Interactively, or with optional arg MSG non-nil, print the returned=0A= ! string in the echo area."=0A= ! (interactive "i\np\ni\np") ; Always convert to RGB interactively.=0A= ! (let* ((completion-ignore-case t)=0A= ! (colors (or facemenu-color-alist=0A= ! (append '("foreground at point" "background at point")=0A= ! (if allow-empty-name '(""))=0A= ! (color-defined-colors))))=0A= ! (color (completing-read=0A= ! (or prompt "Color (name or #RGB triplet): ")=0A= ! ;; Completing function for colors - accepts color names & RGB = triplets.=0A= ! (lambda (string pred flag)=0A= ! (cond=0A= ! ((null flag) ; Try completion.=0A= ! (or (try-completion string colors pred)=0A= ! (if (color-defined-p string) string)))=0A= ! ((eq flag t) ; List all completions.=0A= ! (or (all-completions string colors pred)=0A= ! (if (color-defined-p string) (list string))))=0A= ! ((eq flag 'lambda) ; Test completion.=0A= ! (or (memq string colors) (color-defined-p string)))))=0A= ! nil t))=0A= ! hex-string)=0A= ! (when (member color colors)=0A= ! (cond ((string-equal color "foreground at point")=0A= ! (setq color (foreground-color-at-point)))=0A= ! ((string-equal color "background at point")=0A= ! (setq color (background-color-at-point))))=0A= ! (when (and convert-to-RGB (not (string-equal color "")))=0A= ! (setq color (color-name-to-hex color))))=0A= ! (when msg (message "Color: `%s'" color))=0A= ! color))=0A= ! =0A= ! (defun color-rgb-hex-string-p (color &optional laxp)=0A= ! "Non-nil if COLOR is an RGB triplet string \"#XXXXXXXXXXXX\".=0A= ! Each X is a hexadecimal digit. The number of X's must be a multiple=0A= ! of 3, with the same number of X's for each of red, green, and blue.=0A= ! The first group of X's is for red, the second is for green, the third=0A= ! is for blue.=0A= ! =0A= ! Non-nil optional arg LAXP means that the initial `#' is optional. In=0A= ! that case, for a valid string of hex digits: when # is present 0 is=0A= ! returned; otherwise, t is returned."=0A= ! (or (string-match "^#\\([a-fA-F0-9][a-fA-F0-9][a-fA-F0-9]\\)+$" = color)=0A= ! (and laxp (string-match = "^\\([a-fA-F0-9][a-fA-F0-9][a-fA-F0-9]\\)+$" color) t)))=0A= ! =0A= ! ;; This version is thanks to Juri Linkov .=0A= ! (defun color-int-to-hex (int &optional nb-digits)=0A= ! "Convert integer argument INT to a RGB triplet string.=0A= ! The string satisfies `color-rgb-hex-string-p'.=0A= ! NB-DIGITS is the number of hex digits. If INT is too large to be=0A= ! represented with NB-DIGITS, then the result is truncated from the=0A= ! left. So for example, INT=3D256 and NB-DIGITS=3D2 returns \"00\", = since=0A= ! the hex equivalent of 256 decimal is 100, which is more than 2 digits."=0A= ! (setq nb-digits (or nb-digits 4))=0A= ! (substring (format (concat "%0" (int-to-string nb-digits) "X") int) = (- nb-digits)))=0A= ! =0A= ! ;; These are the color "values" of `x-color-values', = `ps-color-values', and=0A= ! ;; `ps-e-x-color-values'. But especially given the use of "value" in = HSV, "components" is=0A= ! ;; better in the name than "values".=0A= ! (defun color-components-to-hex (components)=0A= ! "Convert list of rgb color COMPONENTS to an RGB triplet string.=0A= ! Input COMPONENTS is as for the output of `x-color-values'."=0A= ! ;; Just hard-code 4 as the number of hex digits, since = `x-color-values'=0A= ! ;; seems to produce appropriate integer values.=0A= ! (concat "#" (color-int-to-hex (nth 0 components) 4) ; red=0A= ! (color-int-to-hex (nth 1 components) 4) ; green=0A= ! (color-int-to-hex (nth 2 components) 4))) ; blue=0A= ! =0A= ! (defun color-name-to-hex (color)=0A= ! "Return the RGB triplet string for COLOR.=0A= ! COLOR is a color name.=0A= ! It can also be an RGB triplet, which is just returned as is.=0A= ! The string returned satisfies `color-rgb-hex-string-p'."=0A= ! (let ((components (x-color-values color)))=0A= ! (unless components (error "No such color: %S" color))=0A= ! (unless (color-rgb-hex-string-p color)=0A= ! (setq color (color-components-to-hex components))))=0A= ! color)=0A= ! =0A= ! (defun color-rgb-to-hex (red green blue)=0A= ! "Return the RBG triplet for inputs RED, GREEN, BLUE.=0A= ! The inputs are each in the range 0 to 1, inclusive.=0A= ! The string returned satisfies `color-rgb-hex-string-p'."=0A= ! (color-components-to-hex=0A= ! (mapcar (lambda (x) (floor (* x 65535.0))) (list red green blue))))=0A= ! =0A= ! (defun color-hsv-to-hex (hue saturation value)=0A= ! "Return the RBG triplet string for inputs HUE, SATURATION, and VALUE.=0A= ! The inputs are each in the range 0 to 1, inclusive.=0A= ! The string returned satisfies `color-rgb-hex-string-p'."=0A= ! (color-components-to-hex=0A= ! (mapcar (lambda (x) (floor (* x 65535.0))) (color-hsv-to-rgb hue = saturation value))))=0A= ! =0A= ! ;; FIXME/TODO? (defun color-hsl-to-hex ...)=0A= ! =0A= ! ;; Same as `hexl-hex-char-to-integer', defined in `hexl.el'.=0A= ! (defun color-hex-char-to-integer (character)=0A= ! "Take a CHARACTER and return its value as if it were a hex digit."=0A= ! (if (and (>=3D character ?0) (<=3D character ?9))=0A= ! (- character ?0)=0A= ! (let ((ch (logior character 32)))=0A= ! (if (and (>=3D ch ?a) (<=3D ch ?f))=0A= ! (- ch (- ?a 10))=0A= ! (error "Invalid hex digit `%c'" ch)))))=0A= ! =0A= ! (defun color-hex-to-int (hex)=0A= ! "Convert hexadecimal string HEX to a whole-number value.=0A= ! The characters of HEX must be hexadecimal-digit characters."=0A= ! (let* ((factor 1)=0A= ! (len (length hex))=0A= ! (indx (1- len))=0A= ! (int 0))=0A= ! (while (>=3D indx 0)=0A= ! (setq int (+ int (* factor (color-hex-char-to-integer (aref = hex indx))))=0A= ! indx (1- indx)=0A= ! factor (* 16 factor)))=0A= ! int))=0A= ! =0A= ! (defun color-hex-to-components (rgb-triplet)=0A= ! "Return the RGB color components for RGB-TRIPLET.=0A= ! RGB-TRIPLET is an RGB triplet string (`color-rgb-hex-string-p').=0A= ! The output list is as for `x-color-values'."=0A= ! (let* ((hex-strgp (string-match=0A= ! = "^\\(#\\)?\\(\\([a-fA-F0-9][a-fA-F0-9][a-fA-F0-9]\\)+\\)$"=0A= ! rgb-triplet))=0A= ! (ndigits (/ (if (eq (match-beginning 1) (match-end 1))=0A= ! (length rgb-triplet)=0A= ! (1- (length rgb-triplet)))=0A= ! 3))=0A= ! red green blue)=0A= ! (unless hex-strgp (error "Invalid RGB triplet string: %s" = rgb-triplet))=0A= ! (setq rgb-triplet (substring rgb-triplet (match-beginning 2) = (match-end 2))=0A= ! red (color-hex-to-int (substring rgb-triplet 0 ndigits))=0A= ! green (color-hex-to-int (substring rgb-triplet ndigits (* 2 = ndigits)))=0A= ! blue (color-hex-to-int (substring rgb-triplet (* 2 = ndigits) (* 3 ndigits))))=0A= ! (list red green blue)))=0A= ! =0A= ! (defun color-hex-to-rgb (color)=0A= ! "Return a list of RGB (red, green, blue) color components.=0A= ! Each component is a value from 0.0 to 1.0, inclusive.=0A= ! COLOR is a color name or RGB triplet string (satisfies=0A= ! `color-rgb-hex-string-p')."=0A= ! (unless (color-rgb-hex-string-p color) (setq color = (color-name-to-hex color)))=0A= ! (let ((len (/ (1- (length color)) 3)))=0A= ! (list (/ (color-hex-to-int (substring color 1 (1+ len))) 65535.0)=0A= ! (/ (color-hex-to-int (substring color (1+ len) (+ 1 len = len))) 65535.0)=0A= ! (/ (color-hex-to-int (substring color (+ 1 len len))) = 65535.0))))=0A= ! =0A= ! (defun color-hex-to-hsv (color)=0A= ! "Return a list of HSV (hue, saturation, value) color components.=0A= ! Each component is a value from 0.0 to 1.0, inclusive.=0A= ! COLOR is a color name or RGB triplet string (satisfies=0A= ! `color-rgb-hex-string-p')."=0A= ! (let ((rgb-components (color-hex-to-rgb color)))=0A= ! (apply #'color-rgb-to-hsv rgb-components)))=0A= ! =0A= ! ;; FIXME/TODO? (defun color-hex-to-hsl ...)=0A= ! =0A= ! (defun color-red (color)=0A= ! "Return the red component of COLOR, in range 0 to 1, inclusive.=0A= ! COLOR is a color name or RGB triplet string."=0A= ! (interactive (list (read-color)))=0A= ! (setq color (color-name-to-hex color))=0A= ! (/ (color-hex-to-int (substring color 1 (1+ (/ (1- (length color)) = 3))))=0A= ! (expt 16.0 (/ (1- (length color)) 3.0))))=0A= ! =0A= ! (defun color-green (color)=0A= ! "Return the green component of COLOR, in range 0 to 1, inclusive.=0A= ! COLOR is a color name or RGB triplet string."=0A= ! (interactive (list (read-color)))=0A= ! (setq color (color-name-to-hex color))=0A= ! (let* ((len (/ (1- (length color)) 3))=0A= ! (start (1+ len)))=0A= ! (/ (color-hex-to-int (substring color start (+ start len)))=0A= ! (expt 16.0 (/ (1- (length color)) 3.0)))))=0A= ! =0A= ! (defun color-blue (color)=0A= ! "Return the blue component of COLOR, in range 0 to 1, inclusive.=0A= ! COLOR is a color name or RGB triplet string."=0A= ! (interactive (list (read-color)))=0A= ! (setq color (color-name-to-hex color))=0A= ! (let* ((len (/ (1- (length color)) 3))=0A= ! (start (+ 1 len len)))=0A= ! (/ (color-hex-to-int (substring color start (+ start len)))=0A= ! (expt 16.0 (/ (1- (length color)) 3.0)))))=0A= ! =0A= ! (defun color-hue (color)=0A= ! "Return the hue component of COLOR, in range 0 to 1, inclusive.=0A= ! COLOR is a color name or RGB triplet string."=0A= ! (interactive (list (read-color)))=0A= ! (setq color (color-name-to-hex color))=0A= ! (car (color-rgb-to-hsv (color-red color) (color-green color) = (color-blue color))))=0A= ! =0A= ! (defun color-saturation (color)=0A= ! "Return the saturation component of COLOR, in range 0 to 1, = inclusive.=0A= ! COLOR is a color name or RGB triplet string."=0A= ! (interactive (list (read-color)))=0A= ! (setq color (color-name-to-hex color))=0A= ! (cadr (color-rgb-to-hsv (color-red color) (color-green color) = (color-blue color))))=0A= ! =0A= ! (defun color-value (color)=0A= ! "Return the value component of COLOR, in range 0 to 1, inclusive.=0A= ! COLOR is a color name or RGB triplet string."=0A= ! (interactive (list (read-color)))=0A= ! (setq color (color-name-to-hex color))=0A= ! (caddr (color-rgb-to-hsv (color-red color) (color-green color) = (color-blue color))))=0A= ! =0A= ! ;; FIXME/TODO? (defun color-luminance ...)=0A= ! =0A= ! (defun color-rgb-normalize (color)=0A= ! "Return the normalized RGB components of COLOR as a list.=0A= ! COLOR is a color name or RGB triplet string.=0A= ! Each component returned is 0 to 1, inclusive."=0A= ! (mapcar (lambda (x) (/ x 65535.0)) (x-color-values color)))=0A= =0A= ! (defun color-complement-hex (color-name)=0A= ! "Return the complement of COLOR-NAME as an RGB triplet.=0A= ! \(COLOR-NAME can also be an RGB triplet - it is just returned.)=0A= ! Interactively, you are prompted for COLOR-NAME."=0A= ! (interactive (list (read-color)))=0A= ! (apply 'color-rgb-to-hex (color-complement-components color-name)))=0A= ! =0A= ! (defun color-complement-components (color)=0A= ! "Return the RGB color components for the complement of COLOR.=0A= ! COLOR is a color name or RGB triplet string."=0A= ! (let ((color (color-rgb-normalize color)))=0A= ! (list (- 1.0 (car color)) (- 1.0 (cadr color)) (- 1.0 (caddr = color)))))=0A= =0A= (defun color-gradient (start stop step-number)=0A= "Return a list with STEP-NUMBER colors from START to STOP.=0A= The color list builds a color gradient starting at color START to=0A= ! color STOP. It does not include the START and STOP colors in the=0A= resulting list."=0A= (loop for i from 1 to step-number=0A= with red-step =3D (/ (- (car stop) (car start)) (1+ step-number))=0A= with green-step =3D (/ (- (cadr stop) (cadr start)) (1+ = step-number))=0A= with blue-step =3D (/ (- (caddr stop) (caddr start)) (1+ = step-number))=0A= ! collect (list (+ (car start) (* i red-step))=0A= (+ (cadr start) (* i green-step))=0A= (+ (caddr start) (* i blue-step)))))=0A= =0A= ! ;; From Elisp Info manual, node "Comparison of Numbers".=0A= ! (defun color-approx-equal (x y &optional rfuzz afuzz)=0A= ! "Return non-nil if numbers X and Y are approximately equal.=0A= ! RFUZZ is a relative fuzz factor. AFUZZ is an absolute fuzz factor.=0A= ! RFUZZ defaults to 1.0e-8. AFUZZ defaults to (/ RFUZZ 10).=0A= ! RFUZZ and AFUZZ are converted to their absolute values.=0A= ! The algorithm is:=0A= ! (< (abs (- X Y)) (+ AFUZZ (* RFUZZ (+ (abs X) (abs Y)))))."=0A= ! (setq rfuzz (or rfuzz 1.0e-8)=0A= ! rfuzz (abs rfuzz)=0A= ! afuzz (or afuzz (/ rfuzz 10))=0A= ! afuzz (abs afuzz))=0A= ! (< (abs (- x y)) (+ afuzz (* rfuzz (+ (abs x) (abs y))))))=0A= ! =0A= ! (defun color-rgb-to-hsv (red green blue)=0A= ! "Convert RED, GREEN, BLUE components to HSV (hue, saturation, value).=0A= ! Each input component is 0.0 to 1.0, inclusive.=0A= ! Returns a list of HSV components of value 0.0 to 1.0, inclusive."=0A= ! (let* ((min (min red green blue))=0A= ! (max (max red green blue))=0A= ! (value max)=0A= ! (delta (- max min))=0A= ! hue saturation)=0A= ! (if (color-approx-equal 0.0 delta)=0A= ! (setq hue 0.0=0A= ! saturation 0.0) ; Gray scale - no color; only = value.=0A= ! (if (and (condition-case nil=0A= ! (setq saturation (/ delta max))=0A= ! (arith-error nil))=0A= ! ;; Must be a number, not a NaN. Standard test for a = NaN is (not (=3D N N)),=0A= ! (=3D saturation saturation))=0A= ! (if (color-approx-equal 0.0 saturation)=0A= ! (setq hue 0.0=0A= ! saturation 0.0) ; Again, no color - only value.=0A= ! (setq hue (if (color-approx-equal red max)=0A= ! (/ (- green blue) delta) ; Between yellow & = magenta.=0A= ! (if (color-approx-equal green max)=0A= ! (+ 2.0 (/ (- blue red) delta)) ; Between = cyan & yellow.=0A= ! (+ 4.0 (/ (- red green) delta)))) ; Between = magenta & cyan.=0A= ! hue (/ hue 6.0))=0A= ! (when (< hue 0.0) (setq hue (+ hue 1.0)))=0A= ! (when (> hue 1.0) (setq hue (- hue 1.0))))=0A= ! (setq hue 0.0 ; Div by zero (max=3D0): = H:=3D0, S:=3D0. (Hue undefined.)=0A= ! saturation 0.0)))=0A= ! (list hue saturation value)))=0A= =0A= ! (defun color-rgb-to-hsv-radians (red green blue)=0A= "Convert RED GREEN BLUE values to HSV representation.=0A= Hue is in radians. Saturation and values are between 0 and 1=0A= inclusively."=0A= ***************=0A= *** 93,101 ****=0A= (- 1 (/ min max)))=0A= (/ max 255.0))))=0A= =0A= ! (defun color-rgb->hsl (red green blue)=0A= "Convert RED GREEN BLUE colors to their HSL representation.=0A= ! RED, GREEN and BLUE must be between 0 and 1 inclusively."=0A= (let* ((r red)=0A= (g green)=0A= (b blue)=0A= --- 490,536 ----=0A= (- 1 (/ min max)))=0A= (/ max 255.0))))=0A= =0A= ! ;; FIXME/TODO? (defun color-hsv-radians-to-rgb ...)=0A= ! =0A= ! (defun color-hsv-to-rgb (hue saturation value)=0A= ! "Convert HUE, SATURATION, VALUE components to RGB (red, green, blue).=0A= ! Each input component is 0.0 to 1.0, inclusive.=0A= ! Returns a list of RGB components of value 0.0 to 1.0, inclusive."=0A= ! (let (red green blue int-hue fract pp qq tt ww)=0A= ! (if (color-approx-equal 0.0 saturation)=0A= ! (setq red value=0A= ! green value=0A= ! blue value) ; Gray=0A= ! (setq hue (* hue 6.0) ; Sectors: 0 to 5=0A= ! int-hue (floor hue)=0A= ! fract (- hue int-hue)=0A= ! pp (* value (- 1 saturation))=0A= ! qq (* value (- 1 (* saturation fract)))=0A= ! ww (* value (- 1 (* saturation (- 1 (- hue = int-hue))))))=0A= ! (case int-hue=0A= ! ((0 6) (setq red value=0A= ! green ww=0A= ! blue pp))=0A= ! (1 (setq red qq=0A= ! green value=0A= ! blue pp))=0A= ! (2 (setq red pp=0A= ! green value=0A= ! blue ww))=0A= ! (3 (setq red pp=0A= ! green qq=0A= ! blue value))=0A= ! (4 (setq red ww=0A= ! green pp=0A= ! blue value))=0A= ! (otherwise (setq red value=0A= ! green pp=0A= ! blue qq))))=0A= ! (list red green blue)))=0A= ! =0A= ! (defun color-rgb-to-hsl (red green blue)=0A= "Convert RED GREEN BLUE colors to their HSL representation.=0A= ! RED, GREEN and BLUE must be from 0 to 1, inclusive."=0A= (let* ((r red)=0A= (g green)=0A= (b blue)=0A= ***************=0A= *** 121,129 ****=0A= (/ delta (+ max min))))=0A= l)))=0A= =0A= ! (defun color-srgb->xyz (red green blue)=0A= ! "Converts RED GREEN BLUE colors from the sRGB color space to CIE XYZ.=0A= ! RED, BLUE and GREEN must be between 0 and 1 inclusively."=0A= (let ((r (if (<=3D red 0.04045)=0A= (/ red 12.95)=0A= (expt (/ (+ red 0.055) 1.055) 2.4)))=0A= --- 556,567 ----=0A= (/ delta (+ max min))))=0A= l)))=0A= =0A= ! ;; FIXME/TODO? (defun color-hsl-to-rgb ...)=0A= ! =0A= ! ;; FIXME/TODO? Specify return value in doc string.=0A= ! (defun color-srgb-to-xyz (red green blue)=0A= ! "Convert RED GREEN BLUE colors from the sRGB color space to CIE XYZ.=0A= ! RED, BLUE and GREEN must be from 0 to 1, inclusive."=0A= (let ((r (if (<=3D red 0.04045)=0A= (/ red 12.95)=0A= (expt (/ (+ red 0.055) 1.055) 2.4)))=0A= ***************=0A= *** 137,144 ****=0A= (+ (* 0.21266729 r) (* 0.7151522 g) (* 0.0721750 b))=0A= (+ (* 0.0193339 r) (* 0.1191920 g) (* 0.9503041 b)))))=0A= =0A= ! (defun color-xyz->srgb (X Y Z)=0A= ! "Converts CIE X Y Z colors to sRGB color space."=0A= (let ((r (+ (* 3.2404542 X) (* -1.5371385 Y) (* -0.4985314 Z)))=0A= (g (+ (* -0.9692660 X) (* 1.8760108 Y) (* 0.0415560 Z)))=0A= (b (+ (* 0.0556434 X) (* -0.2040259 Y) (* 1.0572252 Z))))=0A= --- 575,583 ----=0A= (+ (* 0.21266729 r) (* 0.7151522 g) (* 0.0721750 b))=0A= (+ (* 0.0193339 r) (* 0.1191920 g) (* 0.9503041 b)))))=0A= =0A= ! ;; FIXME/TODO? Specify return value in doc string.=0A= ! (defun color-xyz-to-srgb (X Y Z)=0A= ! "Convert CIE X Y Z colors to sRGB color space."=0A= (let ((r (+ (* 3.2404542 X) (* -1.5371385 Y) (* -0.4985314 Z)))=0A= (g (+ (* -0.9692660 X) (* 1.8760108 Y) (* 0.0415560 Z)))=0A= (b (+ (* 0.0556434 X) (* -0.2040259 Y) (* 1.0572252 Z))))=0A= ***************=0A= *** 152,165 ****=0A= (* 12.92 b)=0A= (- (* 1.055 (expt b (/ 1 2.4))) 0.055)))))=0A= =0A= ! (defconst color-d65-xyz '(0.950455 1.0 1.088753)=0A= ! "D65 white point in CIE XYZ.")=0A= ! =0A= ! (defconst color-cie-=CE=B5 (/ 216 24389.0))=0A= ! (defconst color-cie-=CE=BA (/ 24389 27.0))=0A= ! =0A= ! (defun color-xyz->lab (X Y Z &optional white-point)=0A= ! "Converts CIE XYZ to CIE L*a*b*.=0A= WHITE-POINT can be specified as (X Y Z) white point to use. If=0A= none is set, `color-d65-xyz' is used."=0A= (destructuring-bind (Xr Yr Zr) (or white-point color-d65-xyz)=0A= --- 591,599 ----=0A= (* 12.92 b)=0A= (- (* 1.055 (expt b (/ 1 2.4))) 0.055)))))=0A= =0A= ! ;; FIXME/TODO? Specify return value in doc string.=0A= ! (defun color-xyz-to-lab (X Y Z &optional white-point)=0A= ! "Convert CIE XYZ to CIE L*a*b*.=0A= WHITE-POINT can be specified as (X Y Z) white point to use. If=0A= none is set, `color-d65-xyz' is used."=0A= (destructuring-bind (Xr Yr Zr) (or white-point color-d65-xyz)=0A= ***************=0A= *** 180,187 ****=0A= (* 500 (- fx fy)) ; a=0A= (* 200 (- fy fz)))))) ; b=0A= =0A= ! (defun color-lab->xyz (L a b &optional white-point)=0A= ! "Converts CIE L*a*b* to CIE XYZ.=0A= WHITE-POINT can be specified as (X Y Z) white point to use. If=0A= none is set, `color-d65-xyz' is used."=0A= (destructuring-bind (Xr Yr Zr) (or white-point color-d65-xyz)=0A= --- 614,622 ----=0A= (* 500 (- fx fy)) ; a=0A= (* 200 (- fy fz)))))) ; b=0A= =0A= ! ;; FIXME/TODO? Specify return value in doc string.=0A= ! (defun color-lab-to-xyz (L a b &optional white-point)=0A= ! "Convert CIE L*a*b* to CIE XYZ.=0A= WHITE-POINT can be specified as (X Y Z) white point to use. If=0A= none is set, `color-d65-xyz' is used."=0A= (destructuring-bind (Xr Yr Zr) (or white-point color-d65-xyz)=0A= ***************=0A= *** 201,218 ****=0A= (* yr Yr) ; Y=0A= (* zr Zr))))) ; Z=0A= =0A= ! (defun color-srgb->lab (red green blue)=0A= ! "Converts RGB to CIE L*a*b*."=0A= ! (apply 'color-xyz->lab (color-srgb->xyz red green blue)))=0A= ! =0A= ! (defun color-rgb->normalize (color)=0A= ! "Normalize a RGB color to values between 0 and 1 inclusively."=0A= ! (mapcar (lambda (x) (/ x 65535.0)) (x-color-values color)))=0A= ! =0A= ! (defun color-lab->srgb (L a b)=0A= ! "Converts CIE L*a*b* to RGB."=0A= ! (apply 'color-xyz->srgb (color-lab->xyz L a b)))=0A= =0A= (defun color-cie-de2000 (color1 color2 &optional kL kC kH)=0A= "Computes the CIEDE2000 color distance between COLOR1 and COLOR2.=0A= Colors must be in CIE L*a*b* format."=0A= --- 636,652 ----=0A= (* yr Yr) ; Y=0A= (* zr Zr))))) ; Z=0A= =0A= ! ;; FIXME/TODO? Specify return value in doc string.=0A= ! (defun color-srgb-to-lab (red green blue)=0A= ! "Convert RGB to CIE L*a*b*."=0A= ! (apply 'color-xyz-to-lab (color-srgb-to-xyz red green blue)))=0A= ! =0A= ! ;; FIXME/TODO? Specify return value in doc string.=0A= ! (defun color-lab-to-srgb (L a b)=0A= ! "Convert CIE L*a*b* to RGB."=0A= ! (apply 'color-xyz-to-srgb (color-lab-to-xyz L a b)))=0A= =0A= + ;; FIXME/TODO? Specify return value in doc string.=0A= (defun color-cie-de2000 (color1 color2 &optional kL kC kH)=0A= "Computes the CIEDE2000 color distance between COLOR1 and COLOR2.=0A= Colors must be in CIE L*a*b* format."=0A= ***************=0A= *** 267,273 ****=0A= (* 0.24 (cos (* h=CC=84=E2=80=B2 2)))=0A= (* 0.32 (cos (+ (* h=CC=84=E2=80=B2 3) = (degrees-to-radians 6))))=0A= (- (* 0.20 (cos (- (* h=CC=84=E2=80=B2 4) = (degrees-to-radians 63)))))))=0A= ! (=CE=94=CE=B8 (* (degrees-to-radians 30) (exp (- (expt (/ = (- h=CC=84=E2=80=B2 (degrees-to-radians 275)) (degrees-to-radians 25)) = 2.0)))))=0A= (Rc (* 2 (sqrt (/ (expt C=CC=84=E2=80=B2 7.0) (+ (expt = C=CC=84=E2=80=B2 7.0) (expt 25.0 7.0))))))=0A= (Sl (+ 1 (/ (* 0.015 (expt (- L=CC=84=E2=80=B2 50) 2.0)) = (sqrt (+ 20 (expt (- L=CC=84=E2=80=B2 50) 2.0))))))=0A= (Sc (+ 1 (* C=CC=84=E2=80=B2 0.045)))=0A= --- 701,709 ----=0A= (* 0.24 (cos (* h=CC=84=E2=80=B2 2)))=0A= (* 0.32 (cos (+ (* h=CC=84=E2=80=B2 3) = (degrees-to-radians 6))))=0A= (- (* 0.20 (cos (- (* h=CC=84=E2=80=B2 4) = (degrees-to-radians 63)))))))=0A= ! (=CE=94=CE=B8 (* (degrees-to-radians 30)=0A= ! (exp (- (expt (/ (- h=CC=84=E2=80=B2 = (degrees-to-radians 275)) (degrees-to-radians 25))=0A= ! 2.0)))))=0A= (Rc (* 2 (sqrt (/ (expt C=CC=84=E2=80=B2 7.0) (+ (expt = C=CC=84=E2=80=B2 7.0) (expt 25.0 7.0))))))=0A= (Sl (+ 1 (/ (* 0.015 (expt (- L=CC=84=E2=80=B2 50) 2.0)) = (sqrt (+ 20 (expt (- L=CC=84=E2=80=B2 50) 2.0))))))=0A= (Sc (+ 1 (* C=CC=84=E2=80=B2 0.045)))=0A= ***************=0A= *** 278,283 ****=0A= --- 714,803 ----=0A= (expt (/ =CE=94H=E2=80=B2 (* Sh kH)) 2.0)=0A= (* Rt (/ =CE=94C=E2=80=B2 (* Sc kC)) (/ = =CE=94H=E2=80=B2 (* Sh kH)))))))))=0A= =0A= + (defun color-component-to-float (n)=0A= + "Return the floating-point equivalent of color-component value N.=0A= + N must be an integer between 0 and 65535, or else an error is raised."=0A= + (unless (and (wholenump n) (<=3D n 65535))=0A= + (error "Not a whole number less than 65536"))=0A= + (/ (float n) 65535.0))=0A= + =0A= + (defun color-float-to-component (x)=0A= + "Return the color-component value equivalent of floating-point = number X.=0A= + X must be between 0.0 and 1.0, or else an error is raised."=0A= + (unless (and (numberp x) (<=3D 0.0 x) (<=3D x 1.0))=0A= + (error "Not a floating-point number between 0.0 and 1.0"))=0A= + (floor (* x 65535.0)))=0A= + =0A= + (defun color-increment-hex (hex nb-digits increment &optional wrap-p)=0A= + "Increment HEX number (a string NB-DIGITS long) by INCREMENT.=0A= + If optional arg WRAP-P is non-nil then the result wraps around zero.=0A= + For example, with NB-DIGITS 3, incrementing \"fff\" by 1 causes it=0A= + to wrap around to \"000\"."=0A= + (let* ((int (color-hex-to-int hex))=0A= + (new-int (+ increment int)))=0A= + (if (or wrap-p=0A= + (and (>=3D int 0) ; Not too large for the = machine.=0A= + (>=3D new-int 0) ; For the case where = increment < 0.=0A= + (<=3D (length (format (concat "%X") new-int)) = nb-digits))) ; Not too long.=0A= + (color-int-to-hex new-int nb-digits) ; Use incremented number.=0A= + hex))) ; Don't increment.=0A= + =0A= + (defun color-increment-red (hex nb-digits increment &optional wrap-p)=0A= + "Increment red component of RGB triplet string HEX by INCREMENT.=0A= + String HEX satisfies `color-rgb-hex-string-p'.=0A= + Each component in HEX is NB-DIGITS hex digits long.=0A= + If optional arg WRAP-P is non-nil then the result wraps around zero.=0A= + For example, with NB-DIGITS 3, incrementing \"#fffffffff\" by 1=0A= + causes it to wrap around to \"#000ffffff\"."=0A= + (concat "#"=0A= + (color-increment-hex (substring hex 1 (1+ nb-digits)) = nb-digits increment wrap-p)=0A= + (substring hex (1+ nb-digits) (1+ (* nb-digits 2)))=0A= + (substring hex (1+ (* nb-digits 2)))))=0A= + =0A= + (defun color-increment-green (hex nb-digits increment &optional wrap-p)=0A= + "Increment green component of RGB triplet string HEX by INCREMENT.=0A= + String HEX satisfies `color-rgb-hex-string-p'.=0A= + Each component in HEX is NB-DIGITS hex digits long.=0A= + If optional arg WRAP-P is non-nil then the result wraps around zero.=0A= + For example, with NB-DIGITS 3, incrementing \"#fffffffff\" by 1=0A= + causes it to wrap around to \"#fff000fff\"."=0A= + (concat=0A= + "#" (substring hex 1 (1+ nb-digits))=0A= + (color-increment-hex (substring hex (1+ nb-digits) (1+ (* nb-digits = 2)))=0A= + nb-digits=0A= + increment=0A= + wrap-p)=0A= + (substring hex (1+ (* nb-digits 2)))))=0A= + =0A= + (defun color-increment-blue (hex nb-digits increment &optional wrap-p)=0A= + "Increment blue component of RGB triplet string HEX by INCREMENT.=0A= + String HEX satisfies `color-rgb-hex-string-p'.=0A= + Each component in HEX is NB-DIGITS hex digits long.=0A= + If optional arg WRAP-P is non-nil then the result wraps around zero.=0A= + For example, with NB-DIGITS 3, incrementing \"#fffffffff\" by 1=0A= + causes it to wrap around to \"#ffffff000\"."=0A= + (concat "#" (substring hex 1 (1+ (* nb-digits 2)))=0A= + (color-increment-hex (substring hex (1+ (* nb-digits 2)))=0A= + nb-digits=0A= + increment=0A= + wrap-p)))=0A= + =0A= + (defun color-increment-equal-rgb (hex nb-digits increment &optional = wrap-p)=0A= + "Increment each color component (r,g,b) of rgb string HEX by = INCREMENT.=0A= + String HEX starts with \"#\". Each color is NB-DIGITS hex digits long.=0A= + If optional arg WRAP-P is non-nil then the result wraps around zero.=0A= + For example, with NB-DIGITS 3, incrementing \"#fffffffff\" by 1=0A= + causes it to wrap around to \"#000000000\"."=0A= + (concat=0A= + "#"=0A= + (color-increment-hex (substring hex 1 (1+ nb-digits)) nb-digits = increment wrap-p)=0A= + (color-increment-hex (substring hex (1+ nb-digits) (1+ (* nb-digits = 2)))=0A= + nb-digits=0A= + increment=0A= + wrap-p)=0A= + (color-increment-hex (substring hex (1+ (* nb-digits 2))) nb-digits = increment wrap-p)))=0A= + =0A= + =0A= (provide 'color)=0A= =0A= ;;; color.el ends here=0A= =0A= Diff finished. Wed Feb 16 15:59:47 2011=0A= ------=_NextPart_000_00F1_01CBCDF5.C7BE9A30 Content-Type: application/octet-stream; name="color-2011-02-16.el" Content-Transfer-Encoding: quoted-printable Content-Disposition: attachment; filename="color-2011-02-16.el" ;;; color.el --- Color manipulation -*- coding: utf-8; -*-=0A= =0A= ;; Copyright (C) 2011 Free Software Foundation, Inc.=0A= =0A= ;; Author: Drew Adams =0A= ;; Julien Danjou =0A= ;; Keywords: color, hex, rgb, hsv, hsl, cie-lab, background, display, = face=0A= =0A= ;; This file is part of GNU Emacs.=0A= =0A= ;; GNU Emacs is free software: you can redistribute it and/or modify=0A= ;; it under the terms of the GNU General Public License as published by=0A= ;; the Free Software Foundation, either version 3 of the License, or=0A= ;; (at your option) any later version.=0A= =0A= ;; GNU Emacs is distributed in the hope that it will be useful,=0A= ;; but WITHOUT ANY WARRANTY; without even the implied warranty of=0A= ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the=0A= ;; GNU General Public License for more details.=0A= =0A= ;; You should have received a copy of the GNU General Public License=0A= ;; along with GNU Emacs. If not, see .=0A= =0A= ;;; Commentary:=0A= =0A= ;; This library provides color manipulation functions.=0A= ;;=0A= ;; It provides functions for converting between RGB (red, green,=0A= ;; blue), HSV (hue, saturation, value), HSL (hue, saturation,=0A= ;; luminence), sRGB, CIE XYZ, and CIE L*a*b* color components. It=0A= ;; helps you convert among all of the following:=0A= ;;=0A= ;; * Emacs RGB color components (aka color "values"), which are whole=0A= ;; numbers from 0 through 65535=0A= ;; * RGB, HSV, HSL, sRGB, CIE XYZ, and CIE L*a*b* floating-point=0A= ;; components (0.0 through 1.0)=0A= ;; * Emacs color-name strings, such as "blue"=0A= ;; * RGB triplet strings, such as "#FC43A7912"=0A= ;;=0A= ;; An RGB triplet string has 1 + (3 * n) characters, the first of=0A= ;; which is "#". The other characters are hexadecimal digits, in=0A= ;; three groups representing (from the left): red, green, and blue=0A= ;; components.=0A= ;;=0A= ;; It also provides functions to do the following:=0A= ;; * Increment an RGB triplet (string) in various ways=0A= ;; * Return the complement of a color as an RGB triplet or components=0A= ;; * Return the CIEDE2000 color distance between two colors=0A= ;; * Return an individual floating-point RGB or HSV component of a=0A= ;; color-name or RGB triplet string=0A= ;;=0A= ;; FIXME/TODO (?):=0A= ;;=0A= ;; Add functions:=0A= ;; color-hex-to-hsl, color-hsl-to-hex, color-hsl-to-rgb,=0A= ;; color-hsv-radians-to-rgb, color-luminance=0A= ;; color-cie-=CE=B5: Add doc string=0A= ;; color-cie-=CE=BA: Add doc string=0A= ;; color-cie-de2000: Specify return value in doc string=0A= ;; color-lab-to-srgb: Specify return value in doc string=0A= ;; color-lab-to-xyz: Specify return value in doc string=0A= ;; color-srgb-to-lab: Specify return value in doc string=0A= ;; color-srgb-to-xyz: Specify return value in doc string=0A= ;; color-xyz-to-lab: Specify return value in doc string=0A= ;; color-xyz-to-srgb: Specify return value in doc string=0A= =0A= ;;; Code:=0A= =0A= (eval-when-compile (require 'cl)) ; loop=0A= =0A= ;; Emacs < 23.3=0A= (eval-and-compile=0A= (unless (boundp 'float-pi)=0A= (defconst float-pi (* 4 (atan 1)) "The math constant pi = (3.141592653589793...).")))=0A= =0A= (eval-and-compile=0A= (defun color-canonicalize-defined-colors (list)=0A= "Copy of LIST with color names canonicalized.=0A= LIST is a list of color names (strings).=0A= Canonical names are lowercase, with no whitespace.=0A= There are no duplicate names."=0A= (let ((tail list)=0A= this new)=0A= (while tail=0A= (setq this (car tail)=0A= this (color-delete-whitespace-from-string (downcase this) = 0 (length this)))=0A= (unless (member this new) (push this new))=0A= (pop tail))=0A= (nreverse new)))=0A= =0A= (defun color-delete-whitespace-from-string (string &optional from to)=0A= "Remove whitespace from substring of STRING from FROM to TO.=0A= If FROM is nil, then start at the beginning of STRING (FROM =3D 0).=0A= If TO is nil, then end at the end of STRING (TO =3D length of STRING).=0A= FROM and TO are zero-based indexes into STRING.=0A= Character FROM is affected (possibly deleted). Character TO is not."=0A= (setq from (or from 0)=0A= to (or to (length string)))=0A= (with-temp-buffer=0A= (insert string)=0A= (goto-char (+ from (point-min)))=0A= (let ((count from)=0A= char)=0A= (while (and (not (eobp)) (< count to))=0A= (setq char (char-after))=0A= (if (memq char '(?\ ?\t ?\n)) (delete-char 1) (forward-char = 1))=0A= (setq count (1+ count)))=0A= (buffer-string)))))=0A= =0A= (defconst color-defined-colors (eval-when-compile (and window-system = (x-defined-colors)))=0A= "List of all supported colors.")=0A= =0A= (defconst color-defined-colors-no-dups=0A= (eval-when-compile=0A= (and window-system (color-canonicalize-defined-colors = (x-defined-colors))))=0A= "List of all supported color names, with no duplicates.=0A= Names are all lowercase, without any spaces.")=0A= =0A= (defconst color-d65-xyz '(0.950455 1.0 1.088753)=0A= "D65 white point in CIE XYZ.")=0A= =0A= ;; FIXME/TODO? Add doc string=0A= (defconst color-cie-=CE=B5 (/ 216 24389.0))=0A= =0A= ;; FIXME/TODO? Add doc string=0A= (defconst color-cie-=CE=BA (/ 24389 27.0))=0A= =0A= (defcustom color-canonicalize-defined-colors-flag t=0A= "*Non-nil means remove duplicate color names.=0A= Names are considered duplicates if they are the same when abstracting=0A= from whitespace and letter case."=0A= :type 'boolean :group 'faces)=0A= =0A= ;; Use function `color-defined-colors', not the constants, so users=0A= ;; can change the behavior by customizing = `color-canonicalize-defined-colors-flag'.=0A= =0A= (defun color-defined-colors ()=0A= "List of supported color names.=0A= If `color-canonicalize-defined-colors-flag' is non-nil, then names=0A= are lowercased, whitespace is removed, and there are no duplicates."=0A= (if color-canonicalize-defined-colors-flag=0A= color-defined-colors-no-dups=0A= color-defined-colors))=0A= =0A= (defun read-color (&optional prompt convert-to-RGB allow-empty-name msg)=0A= "Read a color name or RGB triplet.=0A= Completion is available for color names, but not for RGB triplets.=0A= =0A= RGB triplets have the form #XXXXXXXXXXXX, where each X is a=0A= hexadecimal digit. The number of X's must be a multiple of 3, with=0A= the same number of X's for each of red, green, and blue. The order of=0A= the color components is red, green, blue.=0A= =0A= Color names that are normally considered equivalent are canonicalized:=0A= They are lowercased, whitespace is removed, and duplicates are=0A= eliminated. E.g. \"LightBlue\" and \"light blue\" are both replaced=0A= by \"lightblue\". If you do not want this behavior, but want to=0A= choose names that might contain whitespace or uppercase letters, then=0A= customize option `color-canonicalize-defined-colors-flag' to nil.=0A= =0A= In addition to standard color names and RGB hex components, the=0A= following are available as color candidates. In each case, the=0A= corresponding color is used.=0A= =0A= * `foreground at point' - foreground under the cursor=0A= * `background at point' - background under the cursor=0A= =0A= Optional arg PROMPT is the prompt; if nil, use a default prompt.=0A= =0A= Interactively, or with optional arg CONVERT-TO-RGB non-nil, convert an=0A= input color name to an RGB triplet string. Return the triplet string.=0A= Otherwise, return the user input (color name or triplet) as a string.=0A= =0A= If optional arg ALLOW-EMPTY-NAME is non-nil, the user is allowed=0A= to enter an empty color name (the empty string).=0A= =0A= Interactively, or with optional arg MSG non-nil, print the returned=0A= string in the echo area."=0A= (interactive "i\np\ni\np") ; Always convert to RGB interactively.=0A= (let* ((completion-ignore-case t)=0A= (colors (or facemenu-color-alist=0A= (append '("foreground at point" "background at point")=0A= (if allow-empty-name '(""))=0A= (color-defined-colors))))=0A= (color (completing-read=0A= (or prompt "Color (name or #RGB triplet): ")=0A= ;; Completing function for colors - accepts color names & RGB = triplets.=0A= (lambda (string pred flag)=0A= (cond=0A= ((null flag) ; Try completion.=0A= (or (try-completion string colors pred)=0A= (if (color-defined-p string) string)))=0A= ((eq flag t) ; List all completions.=0A= (or (all-completions string colors pred)=0A= (if (color-defined-p string) (list string))))=0A= ((eq flag 'lambda) ; Test completion.=0A= (or (memq string colors) (color-defined-p string)))))=0A= nil t))=0A= hex-string)=0A= (when (member color colors)=0A= (cond ((string-equal color "foreground at point")=0A= (setq color (foreground-color-at-point)))=0A= ((string-equal color "background at point")=0A= (setq color (background-color-at-point))))=0A= (when (and convert-to-RGB (not (string-equal color "")))=0A= (setq color (color-name-to-hex color))))=0A= (when msg (message "Color: `%s'" color))=0A= color))=0A= =0A= (defun color-rgb-hex-string-p (color &optional laxp)=0A= "Non-nil if COLOR is an RGB triplet string \"#XXXXXXXXXXXX\".=0A= Each X is a hexadecimal digit. The number of X's must be a multiple=0A= of 3, with the same number of X's for each of red, green, and blue.=0A= The first group of X's is for red, the second is for green, the third=0A= is for blue.=0A= =0A= Non-nil optional arg LAXP means that the initial `#' is optional. In=0A= that case, for a valid string of hex digits: when # is present 0 is=0A= returned; otherwise, t is returned."=0A= (or (string-match "^#\\([a-fA-F0-9][a-fA-F0-9][a-fA-F0-9]\\)+$" color)=0A= (and laxp (string-match = "^\\([a-fA-F0-9][a-fA-F0-9][a-fA-F0-9]\\)+$" color) t)))=0A= =0A= ;; This version is thanks to Juri Linkov .=0A= (defun color-int-to-hex (int &optional nb-digits)=0A= "Convert integer argument INT to a RGB triplet string.=0A= The string satisfies `color-rgb-hex-string-p'.=0A= NB-DIGITS is the number of hex digits. If INT is too large to be=0A= represented with NB-DIGITS, then the result is truncated from the=0A= left. So for example, INT=3D256 and NB-DIGITS=3D2 returns \"00\", since=0A= the hex equivalent of 256 decimal is 100, which is more than 2 digits."=0A= (setq nb-digits (or nb-digits 4))=0A= (substring (format (concat "%0" (int-to-string nb-digits) "X") int) (- = nb-digits)))=0A= =0A= ;; These are the color "values" of `x-color-values', `ps-color-values', = and=0A= ;; `ps-e-x-color-values'. But especially given the use of "value" in = HSV, "components" is=0A= ;; better in the name than "values".=0A= (defun color-components-to-hex (components)=0A= "Convert list of rgb color COMPONENTS to an RGB triplet string.=0A= Input COMPONENTS is as for the output of `x-color-values'."=0A= ;; Just hard-code 4 as the number of hex digits, since `x-color-values'=0A= ;; seems to produce appropriate integer values.=0A= (concat "#" (color-int-to-hex (nth 0 components) 4) ; red=0A= (color-int-to-hex (nth 1 components) 4) ; green=0A= (color-int-to-hex (nth 2 components) 4))) ; blue=0A= =0A= (defun color-name-to-hex (color)=0A= "Return the RGB triplet string for COLOR.=0A= COLOR is a color name.=0A= It can also be an RGB triplet, which is just returned as is.=0A= The string returned satisfies `color-rgb-hex-string-p'."=0A= (let ((components (x-color-values color)))=0A= (unless components (error "No such color: %S" color))=0A= (unless (color-rgb-hex-string-p color)=0A= (setq color (color-components-to-hex components))))=0A= color)=0A= =0A= (defun color-rgb-to-hex (red green blue)=0A= "Return the RBG triplet for inputs RED, GREEN, BLUE.=0A= The inputs are each in the range 0 to 1, inclusive.=0A= The string returned satisfies `color-rgb-hex-string-p'."=0A= (color-components-to-hex=0A= (mapcar (lambda (x) (floor (* x 65535.0))) (list red green blue))))=0A= =0A= (defun color-hsv-to-hex (hue saturation value)=0A= "Return the RBG triplet string for inputs HUE, SATURATION, and VALUE.=0A= The inputs are each in the range 0 to 1, inclusive.=0A= The string returned satisfies `color-rgb-hex-string-p'."=0A= (color-components-to-hex=0A= (mapcar (lambda (x) (floor (* x 65535.0))) (color-hsv-to-rgb hue = saturation value))))=0A= =0A= ;; FIXME/TODO? (defun color-hsl-to-hex ...)=0A= =0A= ;; Same as `hexl-hex-char-to-integer', defined in `hexl.el'.=0A= (defun color-hex-char-to-integer (character)=0A= "Take a CHARACTER and return its value as if it were a hex digit."=0A= (if (and (>=3D character ?0) (<=3D character ?9))=0A= (- character ?0)=0A= (let ((ch (logior character 32)))=0A= (if (and (>=3D ch ?a) (<=3D ch ?f))=0A= (- ch (- ?a 10))=0A= (error "Invalid hex digit `%c'" ch)))))=0A= =0A= (defun color-hex-to-int (hex)=0A= "Convert hexadecimal string HEX to a whole-number value.=0A= The characters of HEX must be hexadecimal-digit characters."=0A= (let* ((factor 1)=0A= (len (length hex))=0A= (indx (1- len))=0A= (int 0))=0A= (while (>=3D indx 0)=0A= (setq int (+ int (* factor (color-hex-char-to-integer (aref = hex indx))))=0A= indx (1- indx)=0A= factor (* 16 factor)))=0A= int))=0A= =0A= (defun color-hex-to-components (rgb-triplet)=0A= "Return the RGB color components for RGB-TRIPLET.=0A= RGB-TRIPLET is an RGB triplet string (`color-rgb-hex-string-p').=0A= The output list is as for `x-color-values'."=0A= (let* ((hex-strgp (string-match=0A= = "^\\(#\\)?\\(\\([a-fA-F0-9][a-fA-F0-9][a-fA-F0-9]\\)+\\)$"=0A= rgb-triplet))=0A= (ndigits (/ (if (eq (match-beginning 1) (match-end 1))=0A= (length rgb-triplet)=0A= (1- (length rgb-triplet)))=0A= 3))=0A= red green blue)=0A= (unless hex-strgp (error "Invalid RGB triplet string: %s" = rgb-triplet))=0A= (setq rgb-triplet (substring rgb-triplet (match-beginning 2) = (match-end 2))=0A= red (color-hex-to-int (substring rgb-triplet 0 ndigits))=0A= green (color-hex-to-int (substring rgb-triplet ndigits (* 2 = ndigits)))=0A= blue (color-hex-to-int (substring rgb-triplet (* 2 ndigits) = (* 3 ndigits))))=0A= (list red green blue)))=0A= =0A= (defun color-hex-to-rgb (color)=0A= "Return a list of RGB (red, green, blue) color components.=0A= Each component is a value from 0.0 to 1.0, inclusive.=0A= COLOR is a color name or RGB triplet string (satisfies=0A= `color-rgb-hex-string-p')."=0A= (unless (color-rgb-hex-string-p color) (setq color (color-name-to-hex = color)))=0A= (let ((len (/ (1- (length color)) 3)))=0A= (list (/ (color-hex-to-int (substring color 1 (1+ len))) 65535.0)=0A= (/ (color-hex-to-int (substring color (1+ len) (+ 1 len len))) = 65535.0)=0A= (/ (color-hex-to-int (substring color (+ 1 len len))) = 65535.0))))=0A= =0A= (defun color-hex-to-hsv (color)=0A= "Return a list of HSV (hue, saturation, value) color components.=0A= Each component is a value from 0.0 to 1.0, inclusive.=0A= COLOR is a color name or RGB triplet string (satisfies=0A= `color-rgb-hex-string-p')."=0A= (let ((rgb-components (color-hex-to-rgb color)))=0A= (apply #'color-rgb-to-hsv rgb-components)))=0A= =0A= ;; FIXME/TODO? (defun color-hex-to-hsl ...)=0A= =0A= (defun color-red (color)=0A= "Return the red component of COLOR, in range 0 to 1, inclusive.=0A= COLOR is a color name or RGB triplet string."=0A= (interactive (list (read-color)))=0A= (setq color (color-name-to-hex color))=0A= (/ (color-hex-to-int (substring color 1 (1+ (/ (1- (length color)) = 3))))=0A= (expt 16.0 (/ (1- (length color)) 3.0))))=0A= =0A= (defun color-green (color)=0A= "Return the green component of COLOR, in range 0 to 1, inclusive.=0A= COLOR is a color name or RGB triplet string."=0A= (interactive (list (read-color)))=0A= (setq color (color-name-to-hex color))=0A= (let* ((len (/ (1- (length color)) 3))=0A= (start (1+ len)))=0A= (/ (color-hex-to-int (substring color start (+ start len)))=0A= (expt 16.0 (/ (1- (length color)) 3.0)))))=0A= =0A= (defun color-blue (color)=0A= "Return the blue component of COLOR, in range 0 to 1, inclusive.=0A= COLOR is a color name or RGB triplet string."=0A= (interactive (list (read-color)))=0A= (setq color (color-name-to-hex color))=0A= (let* ((len (/ (1- (length color)) 3))=0A= (start (+ 1 len len)))=0A= (/ (color-hex-to-int (substring color start (+ start len)))=0A= (expt 16.0 (/ (1- (length color)) 3.0)))))=0A= =0A= (defun color-hue (color)=0A= "Return the hue component of COLOR, in range 0 to 1, inclusive.=0A= COLOR is a color name or RGB triplet string."=0A= (interactive (list (read-color)))=0A= (setq color (color-name-to-hex color))=0A= (car (color-rgb-to-hsv (color-red color) (color-green color) = (color-blue color))))=0A= =0A= (defun color-saturation (color)=0A= "Return the saturation component of COLOR, in range 0 to 1, inclusive.=0A= COLOR is a color name or RGB triplet string."=0A= (interactive (list (read-color)))=0A= (setq color (color-name-to-hex color))=0A= (cadr (color-rgb-to-hsv (color-red color) (color-green color) = (color-blue color))))=0A= =0A= (defun color-value (color)=0A= "Return the value component of COLOR, in range 0 to 1, inclusive.=0A= COLOR is a color name or RGB triplet string."=0A= (interactive (list (read-color)))=0A= (setq color (color-name-to-hex color))=0A= (caddr (color-rgb-to-hsv (color-red color) (color-green color) = (color-blue color))))=0A= =0A= ;; FIXME/TODO? (defun color-luminance ...)=0A= =0A= (defun color-rgb-normalize (color)=0A= "Return the normalized RGB components of COLOR as a list.=0A= COLOR is a color name or RGB triplet string.=0A= Each component returned is 0 to 1, inclusive."=0A= (mapcar (lambda (x) (/ x 65535.0)) (x-color-values color)))=0A= =0A= (defun color-complement-hex (color-name)=0A= "Return the complement of COLOR-NAME as an RGB triplet.=0A= \(COLOR-NAME can also be an RGB triplet - it is just returned.)=0A= Interactively, you are prompted for COLOR-NAME."=0A= (interactive (list (read-color)))=0A= (apply 'color-rgb-to-hex (color-complement-components color-name)))=0A= =0A= (defun color-complement-components (color)=0A= "Return the RGB color components for the complement of COLOR.=0A= COLOR is a color name or RGB triplet string."=0A= (let ((color (color-rgb-normalize color)))=0A= (list (- 1.0 (car color)) (- 1.0 (cadr color)) (- 1.0 (caddr = color)))))=0A= =0A= (defun color-gradient (start stop step-number)=0A= "Return a list with STEP-NUMBER colors from START to STOP.=0A= The color list builds a color gradient starting at color START to=0A= color STOP. It does not include the START and STOP colors in the=0A= resulting list."=0A= (loop for i from 1 to step-number=0A= with red-step =3D (/ (- (car stop) (car start)) (1+ step-number))=0A= with green-step =3D (/ (- (cadr stop) (cadr start)) (1+ = step-number))=0A= with blue-step =3D (/ (- (caddr stop) (caddr start)) (1+ = step-number))=0A= collect (list (+ (car start) (* i red-step))=0A= (+ (cadr start) (* i green-step))=0A= (+ (caddr start) (* i blue-step)))))=0A= =0A= ;; From Elisp Info manual, node "Comparison of Numbers".=0A= (defun color-approx-equal (x y &optional rfuzz afuzz)=0A= "Return non-nil if numbers X and Y are approximately equal.=0A= RFUZZ is a relative fuzz factor. AFUZZ is an absolute fuzz factor.=0A= RFUZZ defaults to 1.0e-8. AFUZZ defaults to (/ RFUZZ 10).=0A= RFUZZ and AFUZZ are converted to their absolute values.=0A= The algorithm is:=0A= (< (abs (- X Y)) (+ AFUZZ (* RFUZZ (+ (abs X) (abs Y)))))."=0A= (setq rfuzz (or rfuzz 1.0e-8)=0A= rfuzz (abs rfuzz)=0A= afuzz (or afuzz (/ rfuzz 10))=0A= afuzz (abs afuzz))=0A= (< (abs (- x y)) (+ afuzz (* rfuzz (+ (abs x) (abs y))))))=0A= =0A= (defun color-rgb-to-hsv (red green blue)=0A= "Convert RED, GREEN, BLUE components to HSV (hue, saturation, value).=0A= Each input component is 0.0 to 1.0, inclusive.=0A= Returns a list of HSV components of value 0.0 to 1.0, inclusive."=0A= (let* ((min (min red green blue))=0A= (max (max red green blue))=0A= (value max)=0A= (delta (- max min))=0A= hue saturation)=0A= (if (color-approx-equal 0.0 delta)=0A= (setq hue 0.0=0A= saturation 0.0) ; Gray scale - no color; only = value.=0A= (if (and (condition-case nil=0A= (setq saturation (/ delta max))=0A= (arith-error nil))=0A= ;; Must be a number, not a NaN. Standard test for a NaN = is (not (=3D N N)),=0A= (=3D saturation saturation))=0A= (if (color-approx-equal 0.0 saturation)=0A= (setq hue 0.0=0A= saturation 0.0) ; Again, no color - only value.=0A= (setq hue (if (color-approx-equal red max)=0A= (/ (- green blue) delta) ; Between yellow & = magenta.=0A= (if (color-approx-equal green max)=0A= (+ 2.0 (/ (- blue red) delta)) ; Between = cyan & yellow.=0A= (+ 4.0 (/ (- red green) delta)))) ; Between = magenta & cyan.=0A= hue (/ hue 6.0))=0A= (when (< hue 0.0) (setq hue (+ hue 1.0)))=0A= (when (> hue 1.0) (setq hue (- hue 1.0))))=0A= (setq hue 0.0 ; Div by zero (max=3D0): H:=3D0, = S:=3D0. (Hue undefined.)=0A= saturation 0.0)))=0A= (list hue saturation value)))=0A= =0A= (defun color-rgb-to-hsv-radians (red green blue)=0A= "Convert RED GREEN BLUE values to HSV representation.=0A= Hue is in radians. Saturation and values are between 0 and 1=0A= inclusively."=0A= (let* ((r (float red))=0A= (g (float green))=0A= (b (float blue))=0A= (max (max r g b))=0A= (min (min r g b)))=0A= (list=0A= (/ (* 2 float-pi=0A= (cond ((and (=3D r g) (=3D g b)) 0)=0A= ((and (=3D r max)=0A= (>=3D g b))=0A= (* 60 (/ (- g b) (- max min))))=0A= ((and (=3D r max)=0A= (< g b))=0A= (+ 360 (* 60 (/ (- g b) (- max min)))))=0A= ((=3D max g)=0A= (+ 120 (* 60 (/ (- b r) (- max min)))))=0A= ((=3D max b)=0A= (+ 240 (* 60 (/ (- r g) (- max min)))))))=0A= 360)=0A= (if (=3D max 0)=0A= 0=0A= (- 1 (/ min max)))=0A= (/ max 255.0))))=0A= =0A= ;; FIXME/TODO? (defun color-hsv-radians-to-rgb ...)=0A= =0A= (defun color-hsv-to-rgb (hue saturation value)=0A= "Convert HUE, SATURATION, VALUE components to RGB (red, green, blue).=0A= Each input component is 0.0 to 1.0, inclusive.=0A= Returns a list of RGB components of value 0.0 to 1.0, inclusive."=0A= (let (red green blue int-hue fract pp qq tt ww)=0A= (if (color-approx-equal 0.0 saturation)=0A= (setq red value=0A= green value=0A= blue value) ; Gray=0A= (setq hue (* hue 6.0) ; Sectors: 0 to 5=0A= int-hue (floor hue)=0A= fract (- hue int-hue)=0A= pp (* value (- 1 saturation))=0A= qq (* value (- 1 (* saturation fract)))=0A= ww (* value (- 1 (* saturation (- 1 (- hue = int-hue))))))=0A= (case int-hue=0A= ((0 6) (setq red value=0A= green ww=0A= blue pp))=0A= (1 (setq red qq=0A= green value=0A= blue pp))=0A= (2 (setq red pp=0A= green value=0A= blue ww))=0A= (3 (setq red pp=0A= green qq=0A= blue value))=0A= (4 (setq red ww=0A= green pp=0A= blue value))=0A= (otherwise (setq red value=0A= green pp=0A= blue qq))))=0A= (list red green blue)))=0A= =0A= (defun color-rgb-to-hsl (red green blue)=0A= "Convert RED GREEN BLUE colors to their HSL representation.=0A= RED, GREEN and BLUE must be from 0 to 1, inclusive."=0A= (let* ((r red)=0A= (g green)=0A= (b blue)=0A= (max (max r g b))=0A= (min (min r g b))=0A= (delta (- max min))=0A= (l (/ (+ max min) 2.0)))=0A= (list=0A= (if (=3D max min)=0A= 0=0A= (* 2 float-pi=0A= (/ (cond ((=3D max r)=0A= (+ (/ (- g b) delta) (if (< g b) 6 0)))=0A= ((=3D max g)=0A= (+ (/ (- b r) delta) 2))=0A= (t=0A= (+ (/ (- r g) delta) 4)))=0A= 6)))=0A= (if (=3D max min)=0A= 0=0A= (if (> l 0.5)=0A= (/ delta (- 2 (+ max min)))=0A= (/ delta (+ max min))))=0A= l)))=0A= =0A= ;; FIXME/TODO? (defun color-hsl-to-rgb ...)=0A= =0A= ;; FIXME/TODO? Specify return value in doc string.=0A= (defun color-srgb-to-xyz (red green blue)=0A= "Convert RED GREEN BLUE colors from the sRGB color space to CIE XYZ.=0A= RED, BLUE and GREEN must be from 0 to 1, inclusive."=0A= (let ((r (if (<=3D red 0.04045)=0A= (/ red 12.95)=0A= (expt (/ (+ red 0.055) 1.055) 2.4)))=0A= (g (if (<=3D green 0.04045)=0A= (/ green 12.95)=0A= (expt (/ (+ green 0.055) 1.055) 2.4)))=0A= (b (if (<=3D blue 0.04045)=0A= (/ blue 12.95)=0A= (expt (/ (+ blue 0.055) 1.055) 2.4))))=0A= (list (+ (* 0.4124564 r) (* 0.3575761 g) (* 0.1804375 b))=0A= (+ (* 0.21266729 r) (* 0.7151522 g) (* 0.0721750 b))=0A= (+ (* 0.0193339 r) (* 0.1191920 g) (* 0.9503041 b)))))=0A= =0A= ;; FIXME/TODO? Specify return value in doc string.=0A= (defun color-xyz-to-srgb (X Y Z)=0A= "Convert CIE X Y Z colors to sRGB color space."=0A= (let ((r (+ (* 3.2404542 X) (* -1.5371385 Y) (* -0.4985314 Z)))=0A= (g (+ (* -0.9692660 X) (* 1.8760108 Y) (* 0.0415560 Z)))=0A= (b (+ (* 0.0556434 X) (* -0.2040259 Y) (* 1.0572252 Z))))=0A= (list (if (<=3D r 0.0031308)=0A= (* 12.92 r)=0A= (- (* 1.055 (expt r (/ 1 2.4))) 0.055))=0A= (if (<=3D g 0.0031308)=0A= (* 12.92 g)=0A= (- (* 1.055 (expt g (/ 1 2.4))) 0.055))=0A= (if (<=3D b 0.0031308)=0A= (* 12.92 b)=0A= (- (* 1.055 (expt b (/ 1 2.4))) 0.055)))))=0A= =0A= ;; FIXME/TODO? Specify return value in doc string.=0A= (defun color-xyz-to-lab (X Y Z &optional white-point)=0A= "Convert CIE XYZ to CIE L*a*b*.=0A= WHITE-POINT can be specified as (X Y Z) white point to use. If=0A= none is set, `color-d65-xyz' is used."=0A= (destructuring-bind (Xr Yr Zr) (or white-point color-d65-xyz)=0A= (let* ((xr (/ X Xr))=0A= (yr (/ Y Yr))=0A= (zr (/ Z Zr))=0A= (fx (if (> xr color-cie-=CE=B5)=0A= (expt xr (/ 1 3.0))=0A= (/ (+ (* color-cie-=CE=BA xr) 16) 116.0)))=0A= (fy (if (> yr color-cie-=CE=B5)=0A= (expt yr (/ 1 3.0))=0A= (/ (+ (* color-cie-=CE=BA yr) 16) 116.0)))=0A= (fz (if (> zr color-cie-=CE=B5)=0A= (expt zr (/ 1 3.0))=0A= (/ (+ (* color-cie-=CE=BA zr) 16) 116.0))))=0A= (list=0A= (- (* 116 fy) 16) ; L=0A= (* 500 (- fx fy)) ; a=0A= (* 200 (- fy fz)))))) ; b=0A= =0A= ;; FIXME/TODO? Specify return value in doc string.=0A= (defun color-lab-to-xyz (L a b &optional white-point)=0A= "Convert CIE L*a*b* to CIE XYZ.=0A= WHITE-POINT can be specified as (X Y Z) white point to use. If=0A= none is set, `color-d65-xyz' is used."=0A= (destructuring-bind (Xr Yr Zr) (or white-point color-d65-xyz)=0A= (let* ((fy (/ (+ L 16) 116.0))=0A= (fz (- fy (/ b 200.0)))=0A= (fx (+ (/ a 500.0) fy))=0A= (xr (if (> (expt fx 3.0) color-cie-=CE=B5)=0A= (expt fx 3.0)=0A= (/ (- (* fx 116) 16) color-cie-=CE=BA)))=0A= (yr (if (> L (* color-cie-=CE=BA color-cie-=CE=B5))=0A= (expt (/ (+ L 16) 116.0) 3.0)=0A= (/ L color-cie-=CE=BA)))=0A= (zr (if (> (expt fz 3) color-cie-=CE=B5)=0A= (expt fz 3.0)=0A= (/ (- (* 116 fz) 16) color-cie-=CE=BA))))=0A= (list (* xr Xr) ; X=0A= (* yr Yr) ; Y=0A= (* zr Zr))))) ; Z=0A= =0A= ;; FIXME/TODO? Specify return value in doc string.=0A= (defun color-srgb-to-lab (red green blue)=0A= "Convert RGB to CIE L*a*b*."=0A= (apply 'color-xyz-to-lab (color-srgb-to-xyz red green blue)))=0A= =0A= ;; FIXME/TODO? Specify return value in doc string.=0A= (defun color-lab-to-srgb (L a b)=0A= "Convert CIE L*a*b* to RGB."=0A= (apply 'color-xyz-to-srgb (color-lab-to-xyz L a b)))=0A= =0A= ;; FIXME/TODO? Specify return value in doc string.=0A= (defun color-cie-de2000 (color1 color2 &optional kL kC kH)=0A= "Computes the CIEDE2000 color distance between COLOR1 and COLOR2.=0A= Colors must be in CIE L*a*b* format."=0A= (destructuring-bind (L=E2=82=81 a=E2=82=81 b=E2=82=81) color1=0A= (destructuring-bind (L=E2=82=82 a=E2=82=82 b=E2=82=82) color2=0A= (let* ((kL (or kL 1))=0A= (kC (or kC 1))=0A= (kH (or kH 1))=0A= (C=E2=82=81 (sqrt (+ (expt a=E2=82=81 2.0) (expt b=E2=82=81 = 2.0))))=0A= (C=E2=82=82 (sqrt (+ (expt a=E2=82=82 2.0) (expt b=E2=82=82 = 2.0))))=0A= (C=CC=84 (/ (+ C=E2=82=81 C=E2=82=82) 2.0))=0A= (G (* 0.5 (- 1 (sqrt (/ (expt C=CC=84 7.0) (+ (expt C=CC=84 = 7.0) (expt 25 7.0)))))))=0A= (a=E2=80=B2=E2=82=81 (* (+ 1 G) a=E2=82=81))=0A= (a=E2=80=B2=E2=82=82 (* (+ 1 G) a=E2=82=82))=0A= (C=E2=80=B2=E2=82=81 (sqrt (+ (expt a=E2=80=B2=E2=82=81 = 2.0) (expt b=E2=82=81 2.0))))=0A= (C=E2=80=B2=E2=82=82 (sqrt (+ (expt a=E2=80=B2=E2=82=82 = 2.0) (expt b=E2=82=82 2.0))))=0A= (h=E2=80=B2=E2=82=81 (if (and (=3D b=E2=82=81 0) (=3D = a=E2=80=B2=E2=82=81 0))=0A= 0=0A= (let ((v (atan b=E2=82=81 a=E2=80=B2=E2=82=81)))=0A= (if (< v 0)=0A= (+ v (* 2 float-pi))=0A= v))))=0A= (h=E2=80=B2=E2=82=82 (if (and (=3D b=E2=82=82 0) (=3D = a=E2=80=B2=E2=82=82 0))=0A= 0=0A= (let ((v (atan b=E2=82=82 a=E2=80=B2=E2=82=82)))=0A= (if (< v 0)=0A= (+ v (* 2 float-pi))=0A= v))))=0A= (=CE=94L=E2=80=B2 (- L=E2=82=82 L=E2=82=81))=0A= (=CE=94C=E2=80=B2 (- C=E2=80=B2=E2=82=82 = C=E2=80=B2=E2=82=81))=0A= (=CE=94h=E2=80=B2 (cond ((=3D (* C=E2=80=B2=E2=82=81 = C=E2=80=B2=E2=82=82) 0)=0A= 0)=0A= ((<=3D (abs (- h=E2=80=B2=E2=82=82 = h=E2=80=B2=E2=82=81)) float-pi)=0A= (- h=E2=80=B2=E2=82=82 h=E2=80=B2=E2=82=81))=0A= ((> (- h=E2=80=B2=E2=82=82 h=E2=80=B2=E2=82=81) = float-pi)=0A= (- (- h=E2=80=B2=E2=82=82 h=E2=80=B2=E2=82=81) = (* 2 float-pi)))=0A= ((< (- h=E2=80=B2=E2=82=82 h=E2=80=B2=E2=82=81) = (- float-pi))=0A= (+ (- h=E2=80=B2=E2=82=82 h=E2=80=B2=E2=82=81) = (* 2 float-pi)))))=0A= (=CE=94H=E2=80=B2 (* 2 (sqrt (* C=E2=80=B2=E2=82=81 = C=E2=80=B2=E2=82=82)) (sin (/ =CE=94h=E2=80=B2 2.0))))=0A= (L=CC=84=E2=80=B2 (/ (+ L=E2=82=81 L=E2=82=82) 2.0))=0A= (C=CC=84=E2=80=B2 (/ (+ C=E2=80=B2=E2=82=81 = C=E2=80=B2=E2=82=82) 2.0))=0A= (h=CC=84=E2=80=B2 (cond ((=3D (* C=E2=80=B2=E2=82=81 = C=E2=80=B2=E2=82=82) 0)=0A= (+ h=E2=80=B2=E2=82=81 h=E2=80=B2=E2=82=82))=0A= ((<=3D (abs (- h=E2=80=B2=E2=82=81 = h=E2=80=B2=E2=82=82)) float-pi)=0A= (/ (+ h=E2=80=B2=E2=82=81 h=E2=80=B2=E2=82=82) = 2.0))=0A= ((< (+ h=E2=80=B2=E2=82=81 h=E2=80=B2=E2=82=82) = (* 2 float-pi))=0A= (/ (+ h=E2=80=B2=E2=82=81 h=E2=80=B2=E2=82=82 (* = 2 float-pi)) 2.0))=0A= ((>=3D (+ h=E2=80=B2=E2=82=81 = h=E2=80=B2=E2=82=82) (* 2 float-pi))=0A= (/ (+ h=E2=80=B2=E2=82=81 h=E2=80=B2=E2=82=82 (* = -2 float-pi)) 2.0))))=0A= (T (+ 1=0A= (- (* 0.17 (cos (- h=CC=84=E2=80=B2 = (degrees-to-radians 30)))))=0A= (* 0.24 (cos (* h=CC=84=E2=80=B2 2)))=0A= (* 0.32 (cos (+ (* h=CC=84=E2=80=B2 3) = (degrees-to-radians 6))))=0A= (- (* 0.20 (cos (- (* h=CC=84=E2=80=B2 4) = (degrees-to-radians 63)))))))=0A= (=CE=94=CE=B8 (* (degrees-to-radians 30)=0A= (exp (- (expt (/ (- h=CC=84=E2=80=B2 = (degrees-to-radians 275)) (degrees-to-radians 25))=0A= 2.0)))))=0A= (Rc (* 2 (sqrt (/ (expt C=CC=84=E2=80=B2 7.0) (+ (expt = C=CC=84=E2=80=B2 7.0) (expt 25.0 7.0))))))=0A= (Sl (+ 1 (/ (* 0.015 (expt (- L=CC=84=E2=80=B2 50) 2.0)) = (sqrt (+ 20 (expt (- L=CC=84=E2=80=B2 50) 2.0))))))=0A= (Sc (+ 1 (* C=CC=84=E2=80=B2 0.045)))=0A= (Sh (+ 1 (* 0.015 C=CC=84=E2=80=B2 T)))=0A= (Rt (- (* (sin (* =CE=94=CE=B8 2)) Rc))))=0A= (sqrt (+ (expt (/ =CE=94L=E2=80=B2 (* Sl kL)) 2.0)=0A= (expt (/ =CE=94C=E2=80=B2 (* Sc kC)) 2.0)=0A= (expt (/ =CE=94H=E2=80=B2 (* Sh kH)) 2.0)=0A= (* Rt (/ =CE=94C=E2=80=B2 (* Sc kC)) (/ = =CE=94H=E2=80=B2 (* Sh kH)))))))))=0A= =0A= (defun color-component-to-float (n)=0A= "Return the floating-point equivalent of color-component value N.=0A= N must be an integer between 0 and 65535, or else an error is raised."=0A= (unless (and (wholenump n) (<=3D n 65535))=0A= (error "Not a whole number less than 65536"))=0A= (/ (float n) 65535.0))=0A= =0A= (defun color-float-to-component (x)=0A= "Return the color-component value equivalent of floating-point number = X.=0A= X must be between 0.0 and 1.0, or else an error is raised."=0A= (unless (and (numberp x) (<=3D 0.0 x) (<=3D x 1.0))=0A= (error "Not a floating-point number between 0.0 and 1.0"))=0A= (floor (* x 65535.0)))=0A= =0A= (defun color-increment-hex (hex nb-digits increment &optional wrap-p)=0A= "Increment HEX number (a string NB-DIGITS long) by INCREMENT.=0A= If optional arg WRAP-P is non-nil then the result wraps around zero.=0A= For example, with NB-DIGITS 3, incrementing \"fff\" by 1 causes it=0A= to wrap around to \"000\"."=0A= (let* ((int (color-hex-to-int hex))=0A= (new-int (+ increment int)))=0A= (if (or wrap-p=0A= (and (>=3D int 0) ; Not too large for the = machine.=0A= (>=3D new-int 0) ; For the case where increment = < 0.=0A= (<=3D (length (format (concat "%X") new-int)) = nb-digits))) ; Not too long.=0A= (color-int-to-hex new-int nb-digits) ; Use incremented number.=0A= hex))) ; Don't increment.=0A= =0A= (defun color-increment-red (hex nb-digits increment &optional wrap-p)=0A= "Increment red component of RGB triplet string HEX by INCREMENT.=0A= String HEX satisfies `color-rgb-hex-string-p'.=0A= Each component in HEX is NB-DIGITS hex digits long.=0A= If optional arg WRAP-P is non-nil then the result wraps around zero.=0A= For example, with NB-DIGITS 3, incrementing \"#fffffffff\" by 1=0A= causes it to wrap around to \"#000ffffff\"."=0A= (concat "#"=0A= (color-increment-hex (substring hex 1 (1+ nb-digits)) = nb-digits increment wrap-p)=0A= (substring hex (1+ nb-digits) (1+ (* nb-digits 2)))=0A= (substring hex (1+ (* nb-digits 2)))))=0A= =0A= (defun color-increment-green (hex nb-digits increment &optional wrap-p)=0A= "Increment green component of RGB triplet string HEX by INCREMENT.=0A= String HEX satisfies `color-rgb-hex-string-p'.=0A= Each component in HEX is NB-DIGITS hex digits long.=0A= If optional arg WRAP-P is non-nil then the result wraps around zero.=0A= For example, with NB-DIGITS 3, incrementing \"#fffffffff\" by 1=0A= causes it to wrap around to \"#fff000fff\"."=0A= (concat=0A= "#" (substring hex 1 (1+ nb-digits))=0A= (color-increment-hex (substring hex (1+ nb-digits) (1+ (* nb-digits = 2)))=0A= nb-digits=0A= increment=0A= wrap-p)=0A= (substring hex (1+ (* nb-digits 2)))))=0A= =0A= (defun color-increment-blue (hex nb-digits increment &optional wrap-p)=0A= "Increment blue component of RGB triplet string HEX by INCREMENT.=0A= String HEX satisfies `color-rgb-hex-string-p'.=0A= Each component in HEX is NB-DIGITS hex digits long.=0A= If optional arg WRAP-P is non-nil then the result wraps around zero.=0A= For example, with NB-DIGITS 3, incrementing \"#fffffffff\" by 1=0A= causes it to wrap around to \"#ffffff000\"."=0A= (concat "#" (substring hex 1 (1+ (* nb-digits 2)))=0A= (color-increment-hex (substring hex (1+ (* nb-digits 2)))=0A= nb-digits=0A= increment=0A= wrap-p)))=0A= =0A= (defun color-increment-equal-rgb (hex nb-digits increment &optional = wrap-p)=0A= "Increment each color component (r,g,b) of rgb string HEX by INCREMENT.=0A= String HEX starts with \"#\". Each color is NB-DIGITS hex digits long.=0A= If optional arg WRAP-P is non-nil then the result wraps around zero.=0A= For example, with NB-DIGITS 3, incrementing \"#fffffffff\" by 1=0A= causes it to wrap around to \"#000000000\"."=0A= (concat=0A= "#"=0A= (color-increment-hex (substring hex 1 (1+ nb-digits)) nb-digits = increment wrap-p)=0A= (color-increment-hex (substring hex (1+ nb-digits) (1+ (* nb-digits = 2)))=0A= nb-digits=0A= increment=0A= wrap-p)=0A= (color-increment-hex (substring hex (1+ (* nb-digits 2))) nb-digits = increment wrap-p)))=0A= =0A= =0A= (provide 'color)=0A= =0A= ;;; color.el ends here=0A= ------=_NextPart_000_00F1_01CBCDF5.C7BE9A30--