Improved light/dark colour predicate (bug#41544)

Add a predicate, color-dark-p, for deciding whether a colour is more
readable with black or white as contrast.  It has experimentally been
shown to be more accurate and robust than the various methods
currently employed.

The new predicate compares the relative luminance of the colour to an
empirically determined cut-off value, and it seems to get it right in
almost all cases, with no value leading to outright bad results.

* lisp/faces.el (readable-foreground-color): Use color-dark-p.
(color-dark-p): New function.
* lisp/facemenu.el (list-colors-print): Use readable-foreground-color,
improving readability of list-colors-display.
* lisp/textmodes/css-mode.el (css--contrasty-color): Remove.
(css--fontify-region): Use readable-foreground-color.

diff --git a/lisp/facemenu.el b/lisp/facemenu.el
index b10d874b21b0628a29fd13436ba61698b13d190d..419b76101b5b2fbb5dc16396756c9af4fa92b6e2 100644 (file)
--- a/lisp/facemenu.el
+++ b/lisp/facemenu.el
@@ -621,12 +621,11 @@ color.  The function should accept a single argument, the color name."
                                                 (downcase b))))))
        (setq color (list color)))
       (let* ((opoint (point))
-            (color-values (color-values (car color)))
-            (light-p (>= (apply 'max color-values)
-                         (* (car (color-values "white")) .5))))
+             (fg (readable-foreground-color (car color))))
        (insert (car color))
        (indent-to 22)
-       (put-text-property opoint (point) 'face `(:background ,(car color)))
+       (put-text-property opoint (point) 'face `(:background ,(car color)
+                                                  :foreground ,fg))
        (put-text-property
         (prog1 (point)
           (insert " ")
@@ -639,7 +638,7 @@ color.  The function should accept a single argument, the color name."
        (insert (propertize
                 (apply 'format "#%02x%02x%02x"
                        (mapcar (lambda (c) (ash c -8))
-                               color-values))
+                               (color-values (car color))))
                 'mouse-face 'highlight
                 'help-echo
                 (let ((hsv (apply 'color-rgb-to-hsv
@@ -651,7 +650,7 @@ color.  The function should accept a single argument, the color name."
           opoint (point)
           'follow-link t
           'mouse-face (list :background (car color)
-                            :foreground (if light-p "black" "white"))
+                            :foreground fg)
           'color-name (car color)
           'action callback-fn)))
       (insert "\n"))

diff --git a/lisp/faces.el b/lisp/faces.el
index f4a9dedd79901e6c35b498249f7a41f5f278e585..5ecc256f07793963a0b27e82fb44da2126438dbd 100644 (file)
--- a/lisp/faces.el
+++ b/lisp/faces.el
@@ -1785,16 +1785,35 @@ with the color they represent as background color."
    (defined-colors frame)))
 
 (defun readable-foreground-color (color)
-  "Return a readable foreground color for background COLOR."
-  (let* ((rgb   (color-values color))
-        (max   (apply #'max rgb))
-        (black (car (color-values "black")))
-        (white (car (color-values "white"))))
-    ;; Select black or white depending on which one is less similar to
-    ;; the brightest component.
-    (if (> (abs (- max black)) (abs (- max white)))
-       "black"
-      "white")))
+  "Return a readable foreground color for background COLOR.
+The returned value is a string representing black or white, depending
+on which one provides better contrast with COLOR."
+  ;; We use #ffffff instead of "white", because the latter is sometimes
+  ;; less than white.  That way, we get the best contrast possible.
+  (if (color-dark-p (mapcar (lambda (c) (/ c 65535.0)) color))
+      "#ffffff" "black"))
+
+(defun color-dark-p (rgb)
+  "Whether RGB is more readable against white than black.
+RGB is a 3-element list (R G B), each component in the range [0,1].
+This predicate can be used both for determining a suitable (black or white)
+contrast colour with RGB as background and as foreground."
+  (unless (<= 0 (apply #'min rgb) (apply #'max rgb) 1)
+    (error "RGB components %S not in [0,1]" rgb))
+  ;; Compute the relative luminance after gamma-correcting (assuming sRGB),
+  ;; and compare to a cut-off value determined experimentally.
+  ;; See https://en.wikipedia.org/wiki/Relative_luminance for details.
+  (let* ((sr (nth 0 rgb))
+         (sg (nth 1 rgb))
+         (sb (nth 2 rgb))
+         ;; Gamma-correct the RGB components to linear values.
+         ;; Use the power 2.2 as an approximation to sRGB gamma;
+         ;; it should be good enough for the purpose of this function.
+         (r (expt sr 2.2))
+         (g (expt sg 2.2))
+         (b (expt sb 2.2))
+         (y (+ (* r 0.2126) (* g 0.7152) (* b 0.0722))))
+    (< y (eval-when-compile (expt 0.6 2.2)))))
 
 (declare-function xw-color-defined-p "xfns.c" (color &optional frame))
 

diff --git a/lisp/textmodes/css-mode.el b/lisp/textmodes/css-mode.el
index 0035c5e7b05a39bdd03efb96716afe3928ae601a..2cd99787e8a5e51007fa878183aa626d4be12c00 100644 (file)
--- a/lisp/textmodes/css-mode.el
+++ b/lisp/textmodes/css-mode.el
@@ -1149,17 +1149,6 @@ returns, point will be at the end of the recognized color."
    ;; Evaluate to the color if the name is found.
    ((css--named-color start-point match))))
 
-(defun css--contrasty-color (name)
-  "Return a color that contrasts with NAME.
-NAME is of any form accepted by `color-distance'.
-The returned color will be usable by Emacs and will contrast
-with NAME; in particular so that if NAME is used as a background
-color, the returned color can be used as the foreground and still
-be readable."
-  ;; See bug#25525 for a discussion of this.
-  (if (> (color-distance name "black") 292485)
-      "black" "white"))
-
 (defcustom css-fontify-colors t
   "Whether CSS colors should be fontified using the color as the background.
 When non-`nil', a text representing CSS color will be fontified
@@ -1199,7 +1188,8 @@ START and END are buffer positions."
                    (add-text-properties
                     start (point)
                     (list 'face (list :background color
-                                      :foreground (css--contrasty-color color)
+                                      :foreground (readable-foreground-color
+                                                    color)
                                       :box '(:line-width -1))))))))))))
     extended-region))