[bpt/emacs.git] / lisp / color.el

;;; color.el --- Color manipulation library -*- coding: utf-8; lexical-binding:t -*-

;; Copyright (C) 2010-2013 Free Software Foundation, Inc.

;; 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.

;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;; 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, luminance), sRGB,
;; CIE XYZ, and CIE L*a*b* color components.

;;; Code:

(eval-when-compile
  (require 'cl))

;; Emacs < 23.3
(eval-and-compile
  (unless (boundp 'float-pi)
    (defconst float-pi (* 4 (atan 1)) "The value of Pi (3.1415926...).")))

;;;###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 argument 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."
  ;; `colors-values' maximum value is either 65535 or 65280 depending on the
  ;; display system.  So we use a white conversion to get the max value.
  (let ((valmax (float (car (color-values "#ffffff")))))
    (mapcar (lambda (x) (/ x valmax)) (color-values color frame))))

(defun color-rgb-to-hex  (red green blue)
  "Return hexadecimal notation for the color RED GREEN BLUE.
RED, GREEN, and BLUE should be numbers between 0.0 and 1.0, inclusive."
  (format "#%02x%02x%02x"
          (* red 255) (* green 255) (* blue 255)))

(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)))))

(defun color-gradient (start stop step-number)
  "Return a list with STEP-NUMBER colors from START to STOP.
The color list builds a color gradient starting at color START to
color STOP.  It does not include the START and STOP color in the
resulting list."
  (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 (_ step-number)
      (push (list (setq r (+ r r-step))
		  (setq g (+ g g-step))
		  (setq b (+ b b-step)))
	    result))
    (nreverse result)))

(defun color-hue-to-rgb (v1 v2 h)
  "Compute hue from V1 and V2 H.
Used internally by `color-hsl-to-rgb'."
  (cond
   ((< h (/ 1.0 6))   (+ v1 (* (- v2 v1) h 6.0)))
   ((< h 0.5)         v2)
   ((< h (/ 2.0 3))   (+ v1 (* (- v2 v1) (- (/ 2.0 3) h) 6.0)))
   (t                 v1)))

(defun color-hsl-to-rgb (H S L)
  "Convert hue, saturation and luminance to their RGB representation.
H, S, and L should each be numbers between 0.0 and 1.0, inclusive.
Return a list (RED GREEN BLUE), where each element is between 0.0 and 1.0,
inclusive."
  (if (= S 0.0)
      (list L L L)
    (let* ((m2 (if (<= L 0.5)
		   (* L (+ 1.0 S))
		 (- (+ L S) (* L S))))
	   (m1 (- (* 2.0 L) m2)))
      (list
       (color-hue-to-rgb m1 m2 (mod (+ H (/ 1.0 3)) 1))
       (color-hue-to-rgb m1 m2 H)
       (color-hue-to-rgb m1 m2 (mod (- H (/ 1.0 3)) 1))))))

(defun color-complement-hex (color)
  "Return the color that is the complement of COLOR, in hexadecimal format."
  (apply 'color-rgb-to-hex (color-complement color)))

(defun color-rgb-to-hsv (red green blue)
  "Convert RGB 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)))
    (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 RGB colors to their HSL representation.
RED, GREEN, and BLUE should each be numbers between 0.0 and 1.0,
inclusive.  Return a list (HUE SATURATION LUMINANCE), where
each element is between 0.0 and 1.0, inclusive."
  (let* ((r red)
         (g green)
         (b blue)
         (max (max r g b))
         (min (min r g b))
         (delta (- max min))
         (l (/ (+ max min) 2.0)))
    (if (= delta 0)
	(list 0.0 0.0 l)
      (let* ((s (if (<= l 0.5) (/ delta (+ max min))
		  (/ delta (- 2.0 max min))))
	     (rc (/ (- max r) delta))
	     (gc (/ (- max g) delta))
	     (bc (/ (- max b) delta))
	     (h  (mod
		  (/
		   (cond
		    ((= r max)      (- bc gc))
		    ((= g max)      (+ 2.0 rc (- bc)))
		    (t              (+ 4.0 gc (- rc))))
		   6.0) 1.0)))
	(list h s l)))))

(defun color-srgb-to-xyz (red green blue)
  "Convert RED GREEN BLUE colors from the sRGB color space to CIE XYZ.
RED, GREEN and BLUE should be between 0.0 and 1.0, inclusive."
  (let ((r (if (<= red 0.04045)
               (/ red 12.95)
             (expt (/ (+ red 0.055) 1.055) 2.4)))
        (g (if (<= green 0.04045)
               (/ green 12.95)
             (expt (/ (+ green 0.055) 1.055) 2.4)))
        (b (if (<= blue 0.04045)
               (/ blue 12.95)
             (expt (/ (+ blue 0.055) 1.055) 2.4))))
    (list (+ (* 0.4124564 r) (* 0.3575761 g) (* 0.1804375 b))
          (+ (* 0.21266729 r) (* 0.7151522 g) (* 0.0721750 b))
          (+ (* 0.0193339 r) (* 0.1191920 g) (* 0.9503041 b)))))

(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))))
    (list (if (<= r 0.0031308)
              (* 12.92 r)
            (- (* 1.055 (expt r (/ 1 2.4))) 0.055))
          (if (<= g 0.0031308)
              (* 12.92 g)
            (- (* 1.055 (expt g (/ 1 2.4))) 0.055))
          (if (<= b 0.0031308)
              (* 12.92 b)
            (- (* 1.055 (expt b (/ 1 2.4))) 0.055)))))

(defconst color-d65-xyz '(0.950455 1.0 1.088753)
  "D65 white point in CIE XYZ.")

(defconst color-cie-ε (/ 216 24389.0))
(defconst color-cie-κ (/ 24389 27.0))

(defun color-xyz-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'."
  (pcase-let* ((`(,Xr ,Yr ,Zr) (or white-point color-d65-xyz))
               (xr (/ X Xr))
             (yr (/ Y Yr))
             (zr (/ Z Zr))
             (fx (if (> xr color-cie-ε)
                     (expt xr (/ 1 3.0))
                   (/ (+ (* color-cie-κ xr) 16) 116.0)))
             (fy (if (> yr color-cie-ε)
                     (expt yr (/ 1 3.0))
                   (/ (+ (* color-cie-κ yr) 16) 116.0)))
             (fz (if (> zr color-cie-ε)
                     (expt zr (/ 1 3.0))
                   (/ (+ (* color-cie-κ zr) 16) 116.0))))
        (list
         (- (* 116 fy) 16)                  ; L
         (* 500 (- fx fy))                  ; a
     (* 200 (- fy fz)))))             ; b

(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'."
  (pcase-let* ((`(,Xr ,Yr ,Zr) (or white-point color-d65-xyz))
               (fy (/ (+ L 16) 116.0))
             (fz (- fy (/ b 200.0)))
             (fx (+ (/ a 500.0) fy))
             (xr (if (> (expt fx 3.0) color-cie-ε)
                     (expt fx 3.0)
               (/ (- (* fx 116) 16) color-cie-κ)))
             (yr (if (> L (* color-cie-κ color-cie-ε))
                     (expt (/ (+ L 16) 116.0) 3.0)
                   (/ L color-cie-κ)))
             (zr (if (> (expt fz 3) color-cie-ε)
                     (expt fz 3.0)
                   (/ (- (* 116 fz) 16) color-cie-κ))))
        (list (* xr Xr)                 ; X
              (* yr Yr)                 ; Y
          (* zr Zr))))                ; Z

(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-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)
  "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'."
  (pcase-let*
      ((`(,L₁ ,a₁ ,b₁) color1)
       (`(,L₂ ,a₂ ,b₂) color2)
       (kL (or kL 1))
       (kC (or kC 1))
       (kH (or kH 1))
       (C₁ (sqrt (+ (expt a₁ 2.0) (expt b₁ 2.0))))
       (C₂ (sqrt (+ (expt a₂ 2.0) (expt b₂ 2.0))))
       (C̄ (/ (+ C₁ C₂) 2.0))
       (G (* 0.5 (- 1 (sqrt (/ (expt C̄ 7.0)
                               (+ (expt C̄ 7.0) (expt 25 7.0)))))))
       (a′₁ (* (+ 1 G) a₁))
       (a′₂ (* (+ 1 G) a₂))
       (C′₁ (sqrt (+ (expt a′₁ 2.0) (expt b₁ 2.0))))
       (C′₂ (sqrt (+ (expt a′₂ 2.0) (expt b₂ 2.0))))
       (h′₁ (if (and (= b₁ 0) (= a′₁ 0))
                0
              (let ((v (atan b₁ a′₁)))
                (if (< v 0)
                    (+ v (* 2 float-pi))
                  v))))
       (h′₂ (if (and (= b₂ 0) (= a′₂ 0))
                0
              (let ((v (atan b₂ a′₂)))
                (if (< v 0)
                    (+ v (* 2 float-pi))
                  v))))
       (ΔL′ (- L₂ L₁))
       (ΔC′ (- C′₂ C′₁))
       (Δh′ (cond ((= (* C′₁ C′₂) 0)
                   0)
                  ((<= (abs (- h′₂ h′₁)) float-pi)
                   (- h′₂ h′₁))
                  ((> (- h′₂ h′₁) float-pi)
                   (- (- h′₂ h′₁) (* 2 float-pi)))
                  ((< (- h′₂ h′₁) (- float-pi))
                   (+ (- h′₂ h′₁) (* 2 float-pi)))))
       (ΔH′ (* 2 (sqrt (* C′₁ C′₂)) (sin (/ Δh′ 2.0))))
       (L̄′ (/ (+ L₁ L₂) 2.0))
       (C̄′ (/ (+ C′₁ C′₂) 2.0))
       (h̄′ (cond ((= (* C′₁ C′₂) 0)
                  (+ h′₁ h′₂))
                 ((<= (abs (- h′₁ h′₂)) float-pi)
                  (/ (+ h′₁ h′₂) 2.0))
                 ((< (+ h′₁ h′₂) (* 2 float-pi))
                  (/ (+ h′₁ h′₂ (* 2 float-pi)) 2.0))
                 ((>= (+ h′₁ h′₂) (* 2 float-pi))
                  (/ (+ h′₁ h′₂ (* -2 float-pi)) 2.0))))
       (T (+ 1
             (- (* 0.17 (cos (- h̄′ (degrees-to-radians 30)))))
             (* 0.24 (cos (* h̄′ 2)))
             (* 0.32 (cos (+ (* h̄′ 3) (degrees-to-radians 6))))
             (- (* 0.20 (cos (- (* h̄′ 4) (degrees-to-radians 63)))))))
       (Δθ (* (degrees-to-radians 30)
              (exp (- (expt (/ (- h̄′ (degrees-to-radians 275))
                               (degrees-to-radians 25)) 2.0)))))
       (Rc (* 2 (sqrt (/ (expt C̄′ 7.0) (+ (expt C̄′ 7.0) (expt 25.0 7.0))))))
       (Sl (+ 1 (/ (* 0.015 (expt (- L̄′ 50) 2.0))
                   (sqrt (+ 20 (expt (- L̄′ 50) 2.0))))))
       (Sc (+ 1 (* C̄′ 0.045)))
       (Sh (+ 1 (* 0.015 C̄′ T)))
       (Rt (- (* (sin (* Δθ 2)) Rc))))
        (sqrt (+ (expt (/ ΔL′ (* Sl kL)) 2.0)
                 (expt (/ ΔC′ (* Sc kC)) 2.0)
                 (expt (/ ΔH′ (* Sh kH)) 2.0)
                 (* Rt (/ ΔC′ (* Sc kC)) (/ ΔH′ (* Sh kH)))))))

(defun color-clamp (value)
  "Make sure VALUE is a number between 0.0 and 1.0 inclusive."
  (min 1.0 (max 0.0 value)))

(defun color-saturate-hsl (H S L percent)
  "Make a color more saturated by a specified amount.
Given a color defined in terms of hue, saturation, and luminance
\(arguments H, S, and L), return a color that is PERCENT more
saturated.  Returns a list (HUE SATURATION LUMINANCE)."
  (list H (color-clamp (+ S (/ percent 100.0))) L))

(defun color-saturate-name (name percent)
  "Make a color with a specified NAME more saturated by PERCENT.
See `color-saturate-hsl'."
  (apply 'color-rgb-to-hex
	 (apply 'color-hsl-to-rgb
		(apply 'color-saturate-hsl
		       (append
			(apply 'color-rgb-to-hsl
			       (color-name-to-rgb name))
			(list percent))))))

(defun color-desaturate-hsl (H S L percent)
  "Make a color less saturated by a specified amount.
Given a color defined in terms of hue, saturation, and luminance
\(arguments H, S, and L), return a color that is PERCENT less
saturated.  Returns a list (HUE SATURATION LUMINANCE)."
  (color-saturate-hsl H S L (- percent)))

(defun color-desaturate-name (name percent)
  "Make a color with a specified NAME less saturated by PERCENT.
See `color-desaturate-hsl'."
  (color-saturate-name name (- percent)))

(defun color-lighten-hsl (H S L percent)
  "Make a color lighter by a specified amount.
Given a color defined in terms of hue, saturation, and luminance
\(arguments H, S, and L), return a color that is PERCENT lighter.
Returns a list (HUE SATURATION LUMINANCE)."
  (list H S (color-clamp (+ L (/ percent 100.0)))))

(defun color-lighten-name (name percent)
  "Make a color with a specified NAME lighter by PERCENT.
See `color-lighten-hsl'."
  (apply 'color-rgb-to-hex
	 (apply 'color-hsl-to-rgb
		(apply 'color-lighten-hsl
		       (append
			(apply 'color-rgb-to-hsl
			       (color-name-to-rgb name))
			(list percent))))))

(defun color-darken-hsl (H S L percent)
    "Make a color darker by a specified amount.
Given a color defined in terms of hue, saturation, and luminance
\(arguments H, S, and L), return a color that is PERCENT darker.
Returns a list (HUE SATURATION LUMINANCE)."
  (color-lighten-hsl H S L (- percent)))

(defun color-darken-name (name percent)
  "Make a color with a specified NAME darker by PERCENT.
See `color-darken-hsl'."
  (color-lighten-name name (- percent)))

(provide 'color)

;;; color.el ends here
Commit	Line	Data
aa7c6dbe	1	;;; color.el --- Color manipulation library -- coding: utf-8; lexical-binding:t --
ef6a2907	2
ab422c4d	3	;; Copyright (C) 2010-2013 Free Software Foundation, Inc.
ef6a2907	4
6d713256 CY	5	;; Authors: Julien Danjou <julien@danjou.info>
	6	;; Drew Adams <drew.adams@oracle.com>
	7	;; Keywords: lisp, faces, color, hex, rgb, hsv, hsl, cie-lab, background
ef6a2907 JD	8
	9	;; This file is part of GNU Emacs.
	10
	11	;; GNU Emacs is free software: you can redistribute it and/or modify
	12	;; it under the terms of the GNU General Public License as published by
	13	;; the Free Software Foundation, either version 3 of the License, or
	14	;; (at your option) any later version.
	15
	16	;; GNU Emacs is distributed in the hope that it will be useful,
	17	;; but WITHOUT ANY WARRANTY; without even the implied warranty of
	18	;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	19	;; GNU General Public License for more details.
	20
	21	;; You should have received a copy of the GNU General Public License
	22	;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
	23
	24	;;; Commentary:
	25
6d713256 CY	26	;; This package provides functions for manipulating colors, including
	27	;; converting between color representations, computing color
	28	;; complements, and computing CIEDE2000 color distances.
	29	;;
	30	;; Supported color representations include RGB (red, green, blue), HSV
53964682	31	;; (hue, saturation, value), HSL (hue, saturation, luminance), sRGB,
6d713256	32	;; CIE XYZ, and CIE Lab* color components.
ef6a2907 JD	33
	34	;;; Code:
	35
5b42dfdd JD	36	(eval-when-compile
	37	(require 'cl))
	38
094ae2ab	39	;; Emacs < 23.3
463bcf11 KY	40	(eval-and-compile
	41	(unless (boundp 'float-pi)
	42	(defconst float-pi (* 4 (atan 1)) "The value of Pi (3.1415926...).")))
094ae2ab	43
6d713256 CY	44	;;;###autoload
	45	(defun color-name-to-rgb (color &optional frame)
	46	"Convert COLOR string to a list of normalized RGB components.
	47	COLOR should be a color name (e.g. \"white\") or an RGB triplet
	48	string (e.g. \"#ff12ec\").
	49
	50	Normally the return value is a list of three floating-point
	51	numbers, (RED GREEN BLUE), each between 0.0 and 1.0 inclusive.
	52
d8788e1e	53	Optional argument FRAME specifies the frame where the color is to be
6d713256 CY	54	displayed. If FRAME is omitted or nil, use the selected frame.
6d713256 CY	55	If FRAME cannot display COLOR, return nil."
0d0deb38	56	;; `colors-values' maximum value is either 65535 or 65280 depending on the
d8788e1e	57	;; display system. So we use a white conversion to get the max value.
0d0deb38 JD	58	(let ((valmax (float (car (color-values "#ffffff")))))
0d0deb38 JD	59	(mapcar (lambda (x) (/ x valmax)) (color-values color frame))))
6d713256 CY	60
	61	(defun color-rgb-to-hex (red green blue)
	62	"Return hexadecimal notation for the color RED GREEN BLUE.
d8788e1e	63	RED, GREEN, and BLUE should be numbers between 0.0 and 1.0, inclusive."
fd042993 G	64	(format "#%02x%02x%02x"
	65	(* red 255) (* green 255) (* blue 255)))
	66
6d713256 CY	67	(defun color-complement (color-name)
	68	"Return the color that is the complement of COLOR-NAME.
	69	COLOR-NAME should be a string naming a color (e.g. \"white\"), or
	70	a string specifying a color's RGB components (e.g. \"#ff12ec\")."
	71	(let ((color (color-name-to-rgb color-name)))
fd042993 G	72	(list (- 1.0 (car color))
	73	(- 1.0 (cadr color))
	74	(- 1.0 (caddr color)))))
	75
39cde66c JD	76	(defun color-gradient (start stop step-number)
	77	"Return a list with STEP-NUMBER colors from START to STOP.
	78	The color list builds a color gradient starting at color START to
d8788e1e	79	color STOP. It does not include the START and STOP color in the
39cde66c	80	resulting list."
6d713256 CY	81	(let* ((r (nth 0 start))
	82	(g (nth 1 start))
	83	(b (nth 2 start))
	84	(r-step (/ (- (nth 0 stop) r) (1+ step-number)))
	85	(g-step (/ (- (nth 1 stop) g) (1+ step-number)))
	86	(b-step (/ (- (nth 2 stop) b) (1+ step-number)))
	87	result)
aa7c6dbe	88	(dotimes (_ step-number)
6d713256 CY	89	(push (list (setq r (+ r r-step))
	90	(setq g (+ g g-step))
	91	(setq b (+ b b-step)))
	92	result))
	93	(nreverse result)))
39cde66c	94
6725d21a	95	(defun color-hue-to-rgb (v1 v2 h)
d8788e1e GM	96	"Compute hue from V1 and V2 H.
d8788e1e GM	97	Used internally by `color-hsl-to-rgb'."
6725d21a JD	98	(cond
	99	((< h (/ 1.0 6)) (+ v1 (* (- v2 v1) h 6.0)))
	100	((< h 0.5) v2)
	101	((< h (/ 2.0 3)) (+ v1 (* (- v2 v1) (- (/ 2.0 3) h) 6.0)))
	102	(t v1)))
	103
	104	(defun color-hsl-to-rgb (H S L)
d8788e1e GM	105	"Convert hue, saturation and luminance to their RGB representation.
	106	H, S, and L should each be numbers between 0.0 and 1.0, inclusive.
	107	Return a list (RED GREEN BLUE), where each element is between 0.0 and 1.0,
	108	inclusive."
6725d21a JD	109	(if (= S 0.0)
	110	(list L L L)
	111	(let* ((m2 (if (<= L 0.5)
	112	(* L (+ 1.0 S))
	113	(- (+ L S) (* L S))))
	114	(m1 (- (* 2.0 L) m2)))
	115	(list
123ec157	116	(color-hue-to-rgb m1 m2 (mod (+ H (/ 1.0 3)) 1))
6725d21a	117	(color-hue-to-rgb m1 m2 H)
123ec157	118	(color-hue-to-rgb m1 m2 (mod (- H (/ 1.0 3)) 1))))))
6725d21a	119
fd042993 G	120	(defun color-complement-hex (color)
fd042993 G	121	"Return the color that is the complement of COLOR, in hexadecimal format."
6d713256	122	(apply 'color-rgb-to-hex (color-complement color)))
fd042993	123
6d713256	124	(defun color-rgb-to-hsv (red green blue)
d8788e1e	125	"Convert RGB color components to HSV.
6d713256	126	RED, GREEN, and BLUE should each be numbers between 0.0 and 1.0,
d8788e1e	127	inclusive. Return a list (HUE SATURATION VALUE), where HUE is
6d713256 CY	128	in radians and both SATURATION and VALUE are between 0.0 and 1.0,
	129	inclusive."
	130	(let* ((r (float red))
ef6a2907 JD	131	(g (float green))
	132	(b (float blue))
	133	(max (max r g b))
	134	(min (min r g b)))
6d713256 CY	135	(if (< (- max min) 1e-8)
	136	(list 0.0 0.0 0.0)
	137	(list
	138	(/ (* 2 float-pi
	139	(cond ((and (= r g) (= g b)) 0)
	140	((and (= r max)
	141	(>= g b))
	142	(* 60 (/ (- g b) (- max min))))
	143	((and (= r max)
	144	(< g b))
	145	(+ 360 (* 60 (/ (- g b) (- max min)))))
	146	((= max g)
	147	(+ 120 (* 60 (/ (- b r) (- max min)))))
	148	((= max b)
	149	(+ 240 (* 60 (/ (- r g) (- max min)))))))
	150	360)
	151	(if (= max 0) 0 (- 1 (/ min max)))
	152	(/ max 255.0)))))
	153
	154	(defun color-rgb-to-hsl (red green blue)
d8788e1e	155	"Convert RGB colors to their HSL representation.
6d713256	156	RED, GREEN, and BLUE should each be numbers between 0.0 and 1.0,
d8788e1e GM	157	inclusive. Return a list (HUE SATURATION LUMINANCE), where
d8788e1e GM	158	each element is between 0.0 and 1.0, inclusive."
fd042993 G	159	(let* ((r red)
	160	(g green)
	161	(b blue)
ef6a2907 JD	162	(max (max r g b))
	163	(min (min r g b))
	164	(delta (- max min))
	165	(l (/ (+ max min) 2.0)))
6725d21a JD	166	(if (= delta 0)
	167	(list 0.0 0.0 l)
	168	(let* ((s (if (<= l 0.5) (/ delta (+ max min))
	169	(/ delta (- 2.0 max min))))
	170	(rc (/ (- max r) delta))
	171	(gc (/ (- max g) delta))
	172	(bc (/ (- max b) delta))
	173	(h (mod
	174	(/
	175	(cond
	176	((= r max) (- bc gc))
	177	((= g max) (+ 2.0 rc (- bc)))
	178	(t (+ 4.0 gc (- rc))))
	179	6.0) 1.0)))
	180	(list h s l)))))
ef6a2907	181
6d713256 CY	182	(defun color-srgb-to-xyz (red green blue)
6d713256 CY	183	"Convert RED GREEN BLUE colors from the sRGB color space to CIE XYZ.
d8788e1e	184	RED, GREEN and BLUE should be between 0.0 and 1.0, inclusive."
ef6a2907 JD	185	(let ((r (if (<= red 0.04045)
	186	(/ red 12.95)
	187	(expt (/ (+ red 0.055) 1.055) 2.4)))
	188	(g (if (<= green 0.04045)
	189	(/ green 12.95)
	190	(expt (/ (+ green 0.055) 1.055) 2.4)))
	191	(b (if (<= blue 0.04045)
	192	(/ blue 12.95)
	193	(expt (/ (+ blue 0.055) 1.055) 2.4))))
	194	(list (+ (* 0.4124564 r) (* 0.3575761 g) (* 0.1804375 b))
	195	(+ (* 0.21266729 r) (* 0.7151522 g) (* 0.0721750 b))
	196	(+ (* 0.0193339 r) (* 0.1191920 g) (* 0.9503041 b)))))
	197
6d713256 CY	198	(defun color-xyz-to-srgb (X Y Z)
6d713256 CY	199	"Convert CIE X Y Z colors to sRGB color space."
ef6a2907 JD	200	(let ((r (+ (* 3.2404542 X) (* -1.5371385 Y) (* -0.4985314 Z)))
	201	(g (+ (* -0.9692660 X) (* 1.8760108 Y) (* 0.0415560 Z)))
	202	(b (+ (* 0.0556434 X) (* -0.2040259 Y) (* 1.0572252 Z))))
	203	(list (if (<= r 0.0031308)
	204	(* 12.92 r)
	205	(- (* 1.055 (expt r (/ 1 2.4))) 0.055))
	206	(if (<= g 0.0031308)
	207	(* 12.92 g)
	208	(- (* 1.055 (expt g (/ 1 2.4))) 0.055))
	209	(if (<= b 0.0031308)
	210	(* 12.92 b)
	211	(- (* 1.055 (expt b (/ 1 2.4))) 0.055)))))
	212
fd042993	213	(defconst color-d65-xyz '(0.950455 1.0 1.088753)
ef6a2907 JD	214	"D65 white point in CIE XYZ.")
ef6a2907 JD	215
fd042993 G	216	(defconst color-cie-ε (/ 216 24389.0))
fd042993 G	217	(defconst color-cie-κ (/ 24389 27.0))
ef6a2907	218
6d713256 CY	219	(defun color-xyz-to-lab (X Y Z &optional white-point)
	220	"Convert CIE XYZ to CIE Lab*.
	221	WHITE-POINT specifies the (X Y Z) white point for the
d8788e1e	222	conversion. If omitted or nil, use `color-d65-xyz'."
aa7c6dbe SM	223	(pcase-let* ((`(,Xr ,Yr ,Zr) (or white-point color-d65-xyz))
aa7c6dbe SM	224	(xr (/ X Xr))
ef6a2907 JD	225	(yr (/ Y Yr))
ef6a2907 JD	226	(zr (/ Z Zr))
fd042993	227	(fx (if (> xr color-cie-ε)
ef6a2907	228	(expt xr (/ 1 3.0))
fd042993 G	229	(/ (+ (* color-cie-κ xr) 16) 116.0)))
fd042993 G	230	(fy (if (> yr color-cie-ε)
ef6a2907	231	(expt yr (/ 1 3.0))
fd042993 G	232	(/ (+ (* color-cie-κ yr) 16) 116.0)))
fd042993 G	233	(fz (if (> zr color-cie-ε)
ef6a2907	234	(expt zr (/ 1 3.0))
fd042993	235	(/ (+ (* color-cie-κ zr) 16) 116.0))))
ef6a2907 JD	236	(list
	237	(- (* 116 fy) 16) ; L
	238	(* 500 (- fx fy)) ; a
aa7c6dbe	239	(* 200 (- fy fz))))) ; b
ef6a2907	240
6d713256 CY	241	(defun color-lab-to-xyz (L a b &optional white-point)
	242	"Convert CIE Lab* to CIE XYZ.
	243	WHITE-POINT specifies the (X Y Z) white point for the
d8788e1e	244	conversion. If omitted or nil, use `color-d65-xyz'."
aa7c6dbe SM	245	(pcase-let* ((`(,Xr ,Yr ,Zr) (or white-point color-d65-xyz))
aa7c6dbe SM	246	(fy (/ (+ L 16) 116.0))
ef6a2907 JD	247	(fz (- fy (/ b 200.0)))
ef6a2907 JD	248	(fx (+ (/ a 500.0) fy))
fd042993	249	(xr (if (> (expt fx 3.0) color-cie-ε)
67d43a1d	250	(expt fx 3.0)
fd042993 G	251	(/ (- (* fx 116) 16) color-cie-κ)))
fd042993 G	252	(yr (if (> L (* color-cie-κ color-cie-ε))
67d43a1d	253	(expt (/ (+ L 16) 116.0) 3.0)
fd042993 G	254	(/ L color-cie-κ)))
fd042993 G	255	(zr (if (> (expt fz 3) color-cie-ε)
67d43a1d	256	(expt fz 3.0)
fd042993	257	(/ (- (* 116 fz) 16) color-cie-κ))))
ef6a2907 JD	258	(list (* xr Xr) ; X
ef6a2907 JD	259	(* yr Yr) ; Y
aa7c6dbe	260	(* zr Zr)))) ; Z
ef6a2907	261
6d713256 CY	262	(defun color-srgb-to-lab (red green blue)
	263	"Convert RGB to CIE Lab*."
	264	(apply 'color-xyz-to-lab (color-srgb-to-xyz red green blue)))
ef6a2907	265
6d713256 CY	266	(defun color-lab-to-srgb (L a b)
	267	"Convert CIE Lab* to RGB."
	268	(apply 'color-xyz-to-srgb (color-lab-to-xyz L a b)))
ef6a2907	269
fd042993	270	(defun color-cie-de2000 (color1 color2 &optional kL kC kH)
6d713256 CY	271	"Return the CIEDE2000 color distance between COLOR1 and COLOR2.
	272	Both COLOR1 and COLOR2 should be in CIE Lab* format, as
	273	returned by `color-srgb-to-lab' or `color-xyz-to-lab'."
aa7c6dbe SM	274	(pcase-let*
	275	((`(,L₁ ,a₁ ,b₁) color1)
	276	(`(,L₂ ,a₂ ,b₂) color2)
	277	(kL (or kL 1))
	278	(kC (or kC 1))
	279	(kH (or kH 1))
	280	(C₁ (sqrt (+ (expt a₁ 2.0) (expt b₁ 2.0))))
	281	(C₂ (sqrt (+ (expt a₂ 2.0) (expt b₂ 2.0))))
	282	(C̄ (/ (+ C₁ C₂) 2.0))
	283	(G (* 0.5 (- 1 (sqrt (/ (expt C̄ 7.0)
	284	(+ (expt C̄ 7.0) (expt 25 7.0)))))))
	285	(a′₁ (* (+ 1 G) a₁))
	286	(a′₂ (* (+ 1 G) a₂))
	287	(C′₁ (sqrt (+ (expt a′₁ 2.0) (expt b₁ 2.0))))
	288	(C′₂ (sqrt (+ (expt a′₂ 2.0) (expt b₂ 2.0))))
	289	(h′₁ (if (and (= b₁ 0) (= a′₁ 0))
	290	0
	291	(let ((v (atan b₁ a′₁)))
	292	(if (< v 0)
	293	(+ v (* 2 float-pi))
	294	v))))
	295	(h′₂ (if (and (= b₂ 0) (= a′₂ 0))
	296	0
	297	(let ((v (atan b₂ a′₂)))
	298	(if (< v 0)
	299	(+ v (* 2 float-pi))
	300	v))))
	301	(ΔL′ (- L₂ L₁))
	302	(ΔC′ (- C′₂ C′₁))
	303	(Δh′ (cond ((= (* C′₁ C′₂) 0)
	304	0)
	305	((<= (abs (- h′₂ h′₁)) float-pi)
	306	(- h′₂ h′₁))
	307	((> (- h′₂ h′₁) float-pi)
	308	(- (- h′₂ h′₁) (* 2 float-pi)))
	309	((< (- h′₂ h′₁) (- float-pi))
	310	(+ (- h′₂ h′₁) (* 2 float-pi)))))
	311	(ΔH′ (* 2 (sqrt (* C′₁ C′₂)) (sin (/ Δh′ 2.0))))
	312	(L̄′ (/ (+ L₁ L₂) 2.0))
	313	(C̄′ (/ (+ C′₁ C′₂) 2.0))
	314	(h̄′ (cond ((= (* C′₁ C′₂) 0)
	315	(+ h′₁ h′₂))
	316	((<= (abs (- h′₁ h′₂)) float-pi)
	317	(/ (+ h′₁ h′₂) 2.0))
	318	((< (+ h′₁ h′₂) (* 2 float-pi))
	319	(/ (+ h′₁ h′₂ (* 2 float-pi)) 2.0))
	320	((>= (+ h′₁ h′₂) (* 2 float-pi))
	321	(/ (+ h′₁ h′₂ (* -2 float-pi)) 2.0))))
	322	(T (+ 1
	323	(- (* 0.17 (cos (- h̄′ (degrees-to-radians 30)))))
	324	(* 0.24 (cos (* h̄′ 2)))
	325	(* 0.32 (cos (+ (* h̄′ 3) (degrees-to-radians 6))))
	326	(- (* 0.20 (cos (- (* h̄′ 4) (degrees-to-radians 63)))))))
	327	(Δθ (* (degrees-to-radians 30)
	328	(exp (- (expt (/ (- h̄′ (degrees-to-radians 275))
	329	(degrees-to-radians 25)) 2.0)))))
	330	(Rc (* 2 (sqrt (/ (expt C̄′ 7.0) (+ (expt C̄′ 7.0) (expt 25.0 7.0))))))
	331	(Sl (+ 1 (/ (* 0.015 (expt (- L̄′ 50) 2.0))
	332	(sqrt (+ 20 (expt (- L̄′ 50) 2.0))))))
	333	(Sc (+ 1 (* C̄′ 0.045)))
	334	(Sh (+ 1 (* 0.015 C̄′ T)))
	335	(Rt (- (* (sin (* Δθ 2)) Rc))))
67d43a1d G	336	(sqrt (+ (expt (/ ΔL′ (* Sl kL)) 2.0)
	337	(expt (/ ΔC′ (* Sc kC)) 2.0)
	338	(expt (/ ΔH′ (* Sh kH)) 2.0)
aa7c6dbe	339	(* Rt (/ ΔC′ (* Sc kC)) (/ ΔH′ (* Sh kH)))))))
ef6a2907	340
6725d21a JD	341	(defun color-clamp (value)
	342	"Make sure VALUE is a number between 0.0 and 1.0 inclusive."
	343	(min 1.0 (max 0.0 value)))
	344
	345	(defun color-saturate-hsl (H S L percent)
d8788e1e GM	346	"Make a color more saturated by a specified amount.
	347	Given a color defined in terms of hue, saturation, and luminance
	348	\(arguments H, S, and L), return a color that is PERCENT more
	349	saturated. Returns a list (HUE SATURATION LUMINANCE)."
6725d21a JD	350	(list H (color-clamp (+ S (/ percent 100.0))) L))
	351
	352	(defun color-saturate-name (name percent)
d8788e1e	353	"Make a color with a specified NAME more saturated by PERCENT.
6725d21a JD	354	See `color-saturate-hsl'."
	355	(apply 'color-rgb-to-hex
	356	(apply 'color-hsl-to-rgb
	357	(apply 'color-saturate-hsl
	358	(append
	359	(apply 'color-rgb-to-hsl
	360	(color-name-to-rgb name))
	361	(list percent))))))
	362
	363	(defun color-desaturate-hsl (H S L percent)
d8788e1e GM	364	"Make a color less saturated by a specified amount.
	365	Given a color defined in terms of hue, saturation, and luminance
	366	\(arguments H, S, and L), return a color that is PERCENT less
	367	saturated. Returns a list (HUE SATURATION LUMINANCE)."
6725d21a JD	368	(color-saturate-hsl H S L (- percent)))
	369
	370	(defun color-desaturate-name (name percent)
d8788e1e	371	"Make a color with a specified NAME less saturated by PERCENT.
6725d21a JD	372	See `color-desaturate-hsl'."
	373	(color-saturate-name name (- percent)))
	374
	375	(defun color-lighten-hsl (H S L percent)
d8788e1e GM	376	"Make a color lighter by a specified amount.
	377	Given a color defined in terms of hue, saturation, and luminance
	378	\(arguments H, S, and L), return a color that is PERCENT lighter.
	379	Returns a list (HUE SATURATION LUMINANCE)."
6725d21a JD	380	(list H S (color-clamp (+ L (/ percent 100.0)))))
	381
	382	(defun color-lighten-name (name percent)
d8788e1e	383	"Make a color with a specified NAME lighter by PERCENT.
6725d21a JD	384	See `color-lighten-hsl'."
	385	(apply 'color-rgb-to-hex
	386	(apply 'color-hsl-to-rgb
0a0a3573	387	(apply 'color-lighten-hsl
6725d21a JD	388	(append
	389	(apply 'color-rgb-to-hsl
	390	(color-name-to-rgb name))
	391	(list percent))))))
	392
	393	(defun color-darken-hsl (H S L percent)
d8788e1e GM	394	"Make a color darker by a specified amount.
	395	Given a color defined in terms of hue, saturation, and luminance
	396	\(arguments H, S, and L), return a color that is PERCENT darker.
	397	Returns a list (HUE SATURATION LUMINANCE)."
6725d21a JD	398	(color-lighten-hsl H S L (- percent)))
	399
	400	(defun color-darken-name (name percent)
d8788e1e	401	"Make a color with a specified NAME darker by PERCENT.
6725d21a JD	402	See `color-darken-hsl'."
	403	(color-lighten-name name (- percent)))
	404
fd042993	405	(provide 'color)
463bcf11	406
fd042993	407	;;; color.el ends here