X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/9a0115abd18f219f234d6dd460cf7f5ed3c0332f..3907e630a71d48e693062b350571990d7ba08bbb:/lisp/color.el

diff --git a/lisp/color.el b/lisp/color.el
index ff7f0eee4e..e1563ea474 100644
--- a/lisp/color.el
+++ b/lisp/color.el
@@ -1,4 +1,4 @@
-;;; color.el --- Color manipulation library -*- coding: utf-8; -*-
+;;; color.el --- Color manipulation library -*- coding: utf-8; lexical-binding:t -*-
 
 ;; Copyright (C) 2010-2012 Free Software Foundation, Inc.
 
@@ -33,9 +33,6 @@
 
 ;;; Code:
 
-(eval-when-compile
-  (require 'cl))
-
 ;; Emacs < 23.3
 (eval-and-compile
   (unless (boundp 'float-pi)
@@ -50,14 +47,17 @@ 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
+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."
-  (mapcar (lambda (x) (/ x 65535.0)) (color-values color frame)))
+  ;; `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 BLUE must be numbers between 0.0 and 1.0 inclusive."
+RED, GREEN, and BLUE should be numbers between 0.0 and 1.0, inclusive."
   (format "#%02x%02x%02x"
           (* red 255) (* green 255) (* blue 255)))
 
@@ -66,14 +66,14 @@ RED GREEN BLUE must be numbers between 0.0 and 1.0 inclusive."
 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)))))
+    (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
+color STOP.  It does not include the START and STOP color in the
 resulting list."
   (let* ((r (nth 0 start))
 	 (g (nth 1 start))
@@ -82,21 +82,46 @@ resulting list."
 	 (g-step (/ (- (nth 1 stop) g) (1+ step-number)))
 	 (b-step (/ (- (nth 2 stop) b) (1+ step-number)))
 	 result)
-    (dotimes (n step-number)
+    (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 RED, GREEN, and BLUE color components to HSV.
+  "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
+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))
@@ -124,13 +149,10 @@ inclusive."
        (/ max 255.0)))))
 
 (defun color-rgb-to-hsl (red green blue)
-  "Convert RED GREEN BLUE colors to their HSL representation.
+  "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 HUE is in radians
-and both SATURATION and LUMINANCE are between 0.0 and 1.0,
-inclusive."
+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)
@@ -138,27 +160,25 @@ inclusive."
          (min (min r g b))
          (delta (- max min))
          (l (/ (+ max min) 2.0)))
-    (list
-     (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))
-                   (t
-                    (+ (/ (- r g) delta) 4)))
-             6)))
-     (if (= max min)
-         0
-       (if (> l 0.5)
-           (/ delta (- 2 (+ max min)))
-         (/ delta (+ max min))))
-     l)))
+    (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, BLUE and GREEN must be between 0 and 1, inclusive."
+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)))
@@ -196,9 +216,9 @@ RED, BLUE and GREEN must be between 0 and 1, inclusive."
 (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))
+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-ε)
@@ -213,14 +233,14 @@ conversion. If omitted or nil, use `color-d65-xyz'."
         (list
          (- (* 116 fy) 16)                  ; L
          (* 500 (- fx fy))                  ; a
-         (* 200 (- fy fz))))))              ; b
+     (* 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'."
-  (destructuring-bind (Xr Yr Zr) (or white-point color-d65-xyz)
-      (let* ((fy (/ (+ L 16) 116.0))
+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-ε)
@@ -234,7 +254,7 @@ conversion. If omitted or nil, use `color-d65-xyz'."
                    (/ (- (* 116 fz) 16) color-cie-κ))))
         (list (* xr Xr)                 ; X
               (* yr Yr)                 ; Y
-              (* zr Zr)))))             ; Z
+          (* zr Zr))))                ; Z
 
 (defun color-srgb-to-lab (red green blue)
   "Convert RGB to CIE L*a*b*."
@@ -248,67 +268,136 @@ conversion. If omitted or nil, use `color-d65-xyz'."
   "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))
-             (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))))
+  (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)))))))))
+                 (* 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)