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

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

;; Copyright (C) 2010-2014 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:

;; 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 (nth 0 color))
          (- 1.0 (nth 1 color))
          (- 1.0 (nth 2 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 min)
      (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))))

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