Commit 6d713256 authored by Chong Yidong's avatar Chong Yidong

Merge some code from hexrgb.el into color.el.

* lisp/color.el (color-name-to-rgb): Rename from color-rgb->normalize.
Autoload.  Add optional arg FRAME, and pass it to color-values.
(color-complement): Caller changed.  Doc fix.
(color-gradient): Rewrite for better clarity and efficiency.
(color-rgb-to-hex): Rename from color-rgb->hex.
(color-rgb-to-hsv): Rename from color-rgb->hsv.  Force hue and
saturation to zero if the value is too small.
(color-rgb-to-hsl): Rename from color-rgb->hsl.
(color-srgb-to-xyz): Rename from color-srgb->xyz.  Doc fix.
(color-xyz-to-srgb): Rename from color-xyz->srgb.  Doc fix.
(color-xyz-to-lab): Rename from color-xyz->lab.  Doc fix.
(color-lab-to-xyz): Rename from color-lab->xyz.  Doc fix.
(color-lab-to-srgb): Rename from color-lab->srgb.  Doc fix.
(color-cie-de2000): Doc fix.

* lisp/facemenu.el (color-rgb-to-hsv): Deleted; use the version in
lisp/color.el instead.
(list-colors-sort-key, list-colors-print): Use
color-normalized-values.

* lisp/faces.el (color-values): Use co...
parent 6b483b66
2011-02-21 Chong Yidong <cyd@stupidchicken.com>
* color.el (color-name-to-rgb): Rename from color-rgb->normalize.
Autoload. Add optional arg FRAME, and pass it to color-values.
(color-complement): Caller changed. Doc fix.
(color-gradient): Rewrite for better clarity and efficiency.
* faces.el (color-values): Use cond for clarity. Doc fix.
* facemenu.el (color-rgb-to-hsv): Deleted; use the version in
color.el instead.
(list-colors-sort-key, list-colors-print): Use
color-normalized-values.
2011-02-20 Drew Adams <drew.adams@oracle.com>
* color.el: First part of merge from hexrgb.el.
(color-rgb-to-hex): Rename from color-rgb->hex.
(color-rgb-to-hsv): Rename from color-rgb->hsv. Force hue and
saturation to zero if the value is too small.
(color-rgb-to-hsl): Rename from color-rgb->hsl.
(color-srgb-to-xyz): Rename from color-srgb->xyz. Doc fix.
(color-xyz-to-srgb): Rename from color-xyz->srgb. Doc fix.
(color-xyz-to-lab): Rename from color-xyz->lab. Doc fix.
(color-lab-to-xyz): Rename from color-lab->xyz. Doc fix.
(color-lab-to-srgb): Rename from color-lab->srgb. Doc fix.
(color-cie-de2000): Doc fix.
2011-02-20 Alan Mackenzie <acm@muc.de>
* progmodes/cc-cmds.el (c-beginning-of-statement): Avoid loop in
......
;;; color.el --- Color manipulation laboratory routines -*- coding: utf-8; -*-
;;; color.el --- Color manipulation library -*- coding: utf-8; -*-
;; Copyright (C) 2010-2011 Free Software Foundation, Inc.
;; Author: Julien Danjou <julien@danjou.info>
;; Keywords: html
;; Authors: Julien Danjou <julien@danjou.info>
;; Drew Adams <drew.adams@oracle.com>
;; Keywords: lisp, faces, color, hex, rgb, hsv, hsl, cie-lab, background
;; This file is part of GNU Emacs.
......@@ -22,7 +23,13 @@
;;; Commentary:
;; This package provides color manipulation functions.
;; This package provides functions for manipulating colors, including
;; converting between color representations, computing color
;; complements, and computing CIEDE2000 color distances.
;;
;; Supported color representations include RGB (red, green, blue), HSV
;; (hue, saturation, value), HSL (hue, saturation, luminence), sRGB,
;; CIE XYZ, and CIE L*a*b* color components.
;;; Code:
......@@ -34,15 +41,31 @@
(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."
;;;###autoload
(defun color-name-to-rgb (color &optional frame)
"Convert COLOR string to a list of normalized RGB components.
COLOR should be a color name (e.g. \"white\") or an RGB triplet
string (e.g. \"#ff12ec\").
Normally the return value is a list of three floating-point
numbers, (RED GREEN BLUE), each between 0.0 and 1.0 inclusive.
Optional arg FRAME specifies the frame where the color is to be
displayed. If FRAME is omitted or nil, use the selected frame.
If FRAME cannot display COLOR, return nil."
(mapcar (lambda (x) (/ x 65535.0)) (color-values color frame)))
(defun color-rgb-to-hex (red green blue)
"Return hexadecimal notation for the color RED GREEN BLUE.
RED GREEN BLUE must be numbers between 0.0 and 1.0 inclusive."
(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)))
(defun color-complement (color-name)
"Return the color that is the complement of COLOR-NAME.
COLOR-NAME should be a string naming a color (e.g. \"white\"), or
a string specifying a color's RGB components (e.g. \"#ff12ec\")."
(let ((color (color-name-to-rgb color-name)))
(list (- 1.0 (car color))
(- 1.0 (cadr color))
(- 1.0 (caddr color)))))
......@@ -52,50 +75,62 @@ RED GREEN BLUE must be values between 0 and 1 inclusively."
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)))))
(let* ((r (nth 0 start))
(g (nth 1 start))
(b (nth 2 start))
(r-step (/ (- (nth 0 stop) r) (1+ step-number)))
(g-step (/ (- (nth 1 stop) g) (1+ step-number)))
(b-step (/ (- (nth 2 stop) b) (1+ step-number)))
result)
(dotimes (n step-number)
(push (list (setq r (+ r r-step))
(setq g (+ g g-step))
(setq b (+ b b-step)))
result))
(nreverse result)))
(defun color-complement-hex (color)
"Return the color that is the complement of COLOR, in hexadecimal format."
(apply 'color-rgb->hex (color-complement color)))
(apply 'color-rgb-to-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."
(let* ((r (float red))
(defun color-rgb-to-hsv (red green blue)
"Convert RED, GREEN, and BLUE color components to HSV.
RED, GREEN, and BLUE should each be numbers between 0.0 and 1.0,
inclusive. Return a list (HUE, SATURATION, VALUE), where HUE is
in radians and both SATURATION and VALUE are between 0.0 and 1.0,
inclusive."
(let* ((r (float red))
(g (float green))
(b (float blue))
(max (max r g b))
(min (min r g b)))
(list
(/ (* 2 float-pi
(cond ((and (= r g) (= g b)) 0)
((and (= r max)
(>= g b))
(* 60 (/ (- g b) (- max min))))
((and (= r max)
(< g b))
(+ 360 (* 60 (/ (- g b) (- max min)))))
((= max g)
(+ 120 (* 60 (/ (- b r) (- max min)))))
((= max b)
(+ 240 (* 60 (/ (- r g) (- max min)))))))
360)
(if (= max 0)
0
(- 1 (/ min max)))
(/ max 255.0))))
(defun color-rgb->hsl (red green blue)
(if (< (- max min) 1e-8)
(list 0.0 0.0 0.0)
(list
(/ (* 2 float-pi
(cond ((and (= r g) (= g b)) 0)
((and (= r max)
(>= g b))
(* 60 (/ (- g b) (- max min))))
((and (= r max)
(< g b))
(+ 360 (* 60 (/ (- g b) (- max min)))))
((= max g)
(+ 120 (* 60 (/ (- b r) (- max min)))))
((= max b)
(+ 240 (* 60 (/ (- r g) (- max min)))))))
360)
(if (= max 0) 0 (- 1 (/ min max)))
(/ max 255.0)))))
(defun color-rgb-to-hsl (red green blue)
"Convert RED GREEN BLUE colors to their HSL representation.
RED, GREEN and BLUE must be between 0 and 1 inclusively."
RED, GREEN, and BLUE should each be numbers between 0.0 and 1.0,
inclusive.
Return a list (HUE, SATURATION, LUMINENCE), where HUE is in radians
and both SATURATION and LUMINENCE are between 0.0 and 1.0,
inclusive."
(let* ((r red)
(g green)
(b blue)
......@@ -104,13 +139,13 @@ RED, GREEN and BLUE must be between 0 and 1 inclusively."
(delta (- max min))
(l (/ (+ max min) 2.0)))
(list
(if (= max min)
(if (< (- max min) 1e-8)
0
(* 2 float-pi
(/ (cond ((= max r)
(+ (/ (- g b) delta) (if (< g b) 6 0)))
((= max g)
(+ (/ (- b r) delta) 2))
(+ (/ (- b r) delta) 2))
(t
(+ (/ (- r g) delta) 4)))
6)))
......@@ -121,9 +156,9 @@ RED, GREEN and BLUE must be between 0 and 1 inclusively."
(/ 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."
(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 between 0 and 1, inclusive."
(let ((r (if (<= red 0.04045)
(/ red 12.95)
(expt (/ (+ red 0.055) 1.055) 2.4)))
......@@ -137,8 +172,8 @@ RED, BLUE and GREEN must be between 0 and 1 inclusively."
(+ (* 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."
(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))))
......@@ -158,10 +193,10 @@ RED, BLUE and GREEN must be between 0 and 1 inclusively."
(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."
(defun color-xyz-to-lab (X Y Z &optional white-point)
"Convert CIE XYZ to CIE L*a*b*.
WHITE-POINT specifies the (X Y Z) white point for the
conversion. If omitted or nil, use `color-d65-xyz'."
(destructuring-bind (Xr Yr Zr) (or white-point color-d65-xyz)
(let* ((xr (/ X Xr))
(yr (/ Y Yr))
......@@ -180,10 +215,10 @@ none is set, `color-d65-xyz' is used."
(* 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."
(defun color-lab-to-xyz (L a b &optional white-point)
"Convert CIE L*a*b* to CIE XYZ.
WHITE-POINT specifies the (X Y Z) white point for the
conversion. If omitted or nil, use `color-d65-xyz'."
(destructuring-bind (Xr Yr Zr) (or white-point color-d65-xyz)
(let* ((fy (/ (+ L 16) 116.0))
(fz (- fy (/ b 200.0)))
......@@ -201,21 +236,18 @@ none is set, `color-d65-xyz' is used."
(* 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-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)))
(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-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)))
(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."
"Return the CIEDE2000 color distance between COLOR1 and COLOR2.
Both COLOR1 and COLOR2 should be in CIE L*a*b* format, as
returned by `color-srgb-to-lab' or `color-xyz-to-lab'."
(destructuring-bind (L a b) color1
(destructuring-bind (L a b) color2
(let* ((kL (or kL 1))
......
......@@ -463,25 +463,6 @@ These special properties include `invisible', `intangible' and `read-only'."
(defalias 'facemenu-read-color 'read-color)
(defun color-rgb-to-hsv (r g b)
"For R, G, B color components return a list of hue, saturation, value.
R, G, B input values should be in [0..65535] range.
Output values for hue are integers in [0..360] range.
Output values for saturation and value are integers in [0..100] range."
(let* ((r (/ r 65535.0))
(g (/ g 65535.0))
(b (/ b 65535.0))
(max (max r g b))
(min (min r g b))
(h (cond ((= max min) 0)
((= max r) (mod (+ (* 60 (/ (- g b) (- max min))) 360) 360))
((= max g) (+ (* 60 (/ (- b r) (- max min))) 120))
((= max b) (+ (* 60 (/ (- r g) (- max min))) 240))))
(s (cond ((= max 0) 0)
(t (- 1 (/ min max)))))
(v max))
(list (round h) (round s 0.01) (round v 0.01))))
(defcustom list-colors-sort nil
"Color sort order for `list-colors-display'.
`nil' means default implementation-dependent order (defined in `x-colors').
......@@ -508,6 +489,7 @@ and excludes grayscale colors."
"Return a list of keys for sorting colors depending on `list-colors-sort'.
COLOR is the name of the color. When return value is nil,
filter out the color from the output."
(require 'color)
(cond
((null list-colors-sort) color)
((eq list-colors-sort 'name)
......@@ -517,12 +499,12 @@ filter out the color from the output."
((eq (car-safe list-colors-sort) 'rgb-dist)
(color-distance color (cdr list-colors-sort)))
((eq list-colors-sort 'hsv)
(apply 'color-rgb-to-hsv (color-values color)))
(apply 'color-rgb-to-hsv (color-name-to-rgb color)))
((eq (car-safe list-colors-sort) 'hsv-dist)
(let* ((c-rgb (color-values color))
(let* ((c-rgb (color-name-to-rgb color))
(c-hsv (apply 'color-rgb-to-hsv c-rgb))
(o-hsv (apply 'color-rgb-to-hsv
(color-values (cdr list-colors-sort)))))
(color-name-to-rgb (cdr list-colors-sort)))))
(unless (and (eq (nth 0 c-rgb) (nth 1 c-rgb)) ; exclude grayscale
(eq (nth 1 c-rgb) (nth 2 c-rgb)))
;; 3D Euclidean distance (sqrt is not needed for sorting)
......@@ -638,7 +620,7 @@ You can change the color sort order by customizing `list-colors-sort'."
'mouse-face 'highlight
'help-echo
(let ((hsv (apply 'color-rgb-to-hsv
(color-values (car color)))))
(color-name-to-rgb (car color)))))
(format "H:%d S:%d V:%d"
(nth 0 hsv) (nth 1 hsv) (nth 2 hsv)))))
(when callback
......
......@@ -1653,18 +1653,28 @@ If COLOR is the symbol `unspecified' or one of the strings
(defun color-values (color &optional frame)
"Return a description of the color named COLOR on frame FRAME.
The value is a list of integer RGB values--(RED GREEN BLUE).
These values appear to range from 0 to 65280 or 65535, depending
on the system; white is \(65280 65280 65280\) or \(65535 65535 65535\).
COLOR should be a string naming a color (e.g. \"white\"), or a
string specifying a color's RGB components (e.g. \"#ff12ec\").
Return a list of three integers, (RED GREEN BLUE), each between 0
and either 65280 or 65535 (the maximum depends on the system).
Use `color-name-to-rgb' if you want RGB floating-point values
normalized to 1.0.
If FRAME is omitted or nil, use the selected frame.
If FRAME cannot display COLOR, the value is nil.
If COLOR is the symbol `unspecified' or one of the strings
\"unspecified-fg\" or \"unspecified-bg\", the value is nil."
(if (member color '(unspecified "unspecified-fg" "unspecified-bg"))
nil
(if (memq (framep (or frame (selected-frame))) '(x w32 ns))
(xw-color-values color frame)
(tty-color-values color frame))))
COLOR can also be the symbol `unspecified' or one of the strings
\"unspecified-fg\" or \"unspecified-bg\", in which case the
return value is nil."
(cond
((member color '(unspecified "unspecified-fg" "unspecified-bg"))
nil)
((memq (framep (or frame (selected-frame))) '(x w32 ns))
(xw-color-values color frame))
(t
(tty-color-values color frame))))
(defalias 'x-color-values 'color-values)
(declare-function xw-display-color-p "xfns.c" (&optional terminal))
......
2011-02-20 Chong Yidong <cyd@stupidchicken.com>
* shr-color.el (shr-color->hexadecimal): Use renamed function names
color-rgb-to-hex, color-name-to-rgb, color-srgb-to-lab, and
color-lab-to-srgb.
2011-02-19 Glenn Morris <rgm@gnu.org>
* gnus.el (gnus-meta): Doc fix.
......
......@@ -259,7 +259,7 @@ Like rgb() or hsl()."
(l (/ (string-to-number (match-string-no-properties 3 color)) 100.0)))
(destructuring-bind (r g b)
(shr-color-hsl-to-rgb-fractions h s l)
(color-rgb->hex r g b))))
(color-rgb-to-hex r g b))))
;; Color names
((cdr (assoc-string color shr-color-html-colors-alist t)))
;; Unrecognized color :(
......@@ -325,13 +325,13 @@ If FIXED-BACKGROUND is set, and if the color are not visible, a
new background color will not be computed. Only the foreground
color will be adapted to be visible on BG."
;; Convert fg and bg to CIE Lab
(let ((fg-norm (color-rgb->normalize fg))
(bg-norm (color-rgb->normalize bg)))
(let ((fg-norm (color-name-to-rgb fg))
(bg-norm (color-name-to-rgb bg)))
(if (or (null fg-norm)
(null bg-norm))
(list bg fg)
(let* ((fg-lab (apply 'color-srgb->lab fg-norm))
(bg-lab (apply 'color-srgb->lab bg-norm))
(let* ((fg-lab (apply 'color-srgb-to-lab fg-norm))
(bg-lab (apply 'color-srgb-to-lab bg-norm))
;; Compute color distance using CIE DE 2000
(fg-bg-distance (color-cie-de2000 fg-lab bg-lab))
;; Compute luminance distance (substract L component)
......@@ -351,10 +351,10 @@ color will be adapted to be visible on BG."
bg
(apply 'format "#%02x%02x%02x"
(mapcar (lambda (x) (* (max (min 1 x) 0) 255))
(apply 'color-lab->srgb bg-lab))))
(apply 'color-lab-to-srgb bg-lab))))
(apply 'format "#%02x%02x%02x"
(mapcar (lambda (x) (* (max (min 1 x) 0) 255))
(apply 'color-lab->srgb fg-lab))))))))))
(apply 'color-lab-to-srgb fg-lab))))))))))
(provide 'shr-color)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment