master 68ae6fa: Improved light/dark colour predicate (bug#41544)

[Mattias Engdegård]

branch: master
commit 68ae6faa7f1b4c348740667f98fbf1d1ce5a7979
Author: Mattias Engdegård <mattiase@acm.org>
Commit: Mattias Engdegård <mattiase@acm.org>

    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.
---
 lisp/facemenu.el           | 11 +++++------
 lisp/faces.el              | 39 +++++++++++++++++++++++++++++----------
 lisp/textmodes/css-mode.el | 14 ++------------
 3 files changed, 36 insertions(+), 28 deletions(-)

diff --git a/lisp/facemenu.el b/lisp/facemenu.el
index b10d874..419b761 100644
--- 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 f4a9ded..5ecc256 100644
--- 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 0035c5e..2cd9978 100644
--- 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))