From 00c9176cc26853e1314f95bfb540753273740807 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Mattias=20Engdeg=C3=A5rd?= <mattiase@acm.org>
Date: Sun, 31 May 2020 21:12:46 +0200
Subject: [PATCH] Improved light/dark colour predicate (bug#41544)

Add a single predicate, color-dark-p, for deciding whether a colour
is more readable against black or white.  Previously this was done in
different ways in several places, and with worse results.

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

* lisp/facemenu.el (list-colors-print): Use readable-foreground-color.
(color-dark-p): New function.
* lisp/term/pc-win.el: Update comment.
* lisp/term/rxvt.el (rxvt-set-background-mode):
* lisp/term/w32console.el (terminal-init-w32console):
* lisp/term/xterm.el (xterm-maybe-set-dark-background-mode):
* lisp/faces.el (readable-foreground-color):
* lisp/frame.el (frame-set-background-mode): Use color-dark-p.
* lisp/textmodes/css-mode.el (css--contrasty-color): Remove.
(css--fontify-region): Use color-dark-p.
---
 lisp/facemenu.el           | 11 +++++------
 lisp/faces.el              | 29 ++++++++++++++++++++---------
 lisp/frame.el              | 16 +++++++++-------
 lisp/term/pc-win.el        |  8 +++-----
 lisp/term/rxvt.el          | 12 +++++-------
 lisp/term/w32console.el    |  6 +++---
 lisp/term/xterm.el         |  5 ++---
 lisp/textmodes/css-mode.el | 14 ++------------
 8 files changed, 49 insertions(+), 52 deletions(-)

diff --git a/lisp/facemenu.el b/lisp/facemenu.el
index b10d874b21..419b76101b 100644
--- a/lisp/facemenu.el
+++ b/lisp/facemenu.el
@@ -621,12 +621,11 @@ list-colors-print
 						 (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 @@ list-colors-print
 	(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 @@ list-colors-print
 	   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 f4a9dedd79..d68eb82de6 100644
--- a/lisp/faces.el
+++ b/lisp/faces.el
@@ -1786,15 +1786,26 @@ defined-colors-with-face-attributes
 
 (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")))
+  (if (color-dark-p (color-name-to-rgb color)) "white" "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]."
+  (unless (<= 0 (apply #'min rgb) (apply #'max rgb) 1)
+    (error "RGB components %S not in [0,1]" rgb))
+  (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))
+         ;; Compute the relative luminance.
+         (y (+ (* r 0.2126) (* g 0.7152) (* b 0.0722))))
+    ;; Compare it to a cut-off value determined experimentally; see bug#41544.
+    (< y (eval-when-compile (expt 0.6 2.2)))))
 
 (declare-function xw-color-defined-p "xfns.c" (color &optional frame))
 
diff --git a/lisp/frame.el b/lisp/frame.el
index 6c2f774709..b46ba3686f 100644
--- a/lisp/frame.el
+++ b/lisp/frame.el
@@ -1156,6 +1156,12 @@ frame-background-mode
 
 (defvar inhibit-frame-set-background-mode nil)
 
+(defun frame--color-name-to-rgb (color frame)
+  "Convert the COLOR string to a list of normalised RGB components.
+Like `color-name-to-rgb', but works even when the display has not yet
+been initialised."
+  (mapcar (lambda (x) (/ x 65535.0)) (color-values color frame)))
+
 (defun frame-set-background-mode (frame &optional keep-face-specs)
   "Set up display-dependent faces on FRAME.
 Display-dependent faces are those which have different definitions
@@ -1181,13 +1187,9 @@ frame-set-background-mode
 		   non-default-bg-mode)
 		  ((not (color-values bg-color frame))
 		   default-bg-mode)
-		  ((>= (apply '+ (color-values bg-color frame))
-		       ;; Just looking at the screen, colors whose
-		       ;; values add up to .6 of the white total
-		       ;; still look dark to me.
-		       (* (apply '+ (color-values "white" frame)) .6))
-		   'light)
-		  (t 'dark)))
+                  ((color-dark-p (frame--color-name-to-rgb bg-color frame))
+                   'dark)
+                  (t 'light)))
 	   (display-type
 	    (cond ((null (window-system frame))
 		   (if (tty-display-color-p frame) 'color 'mono))
diff --git a/lisp/term/pc-win.el b/lisp/term/pc-win.el
index 76a48a86c7..16eb660f00 100644
--- a/lisp/term/pc-win.el
+++ b/lisp/term/pc-win.el
@@ -54,11 +54,9 @@
 ;; DJGPP-compiled Emacs on the same PC.  The names of X colors used to
 ;; define the pixel values are shown as comments to each color below.
 ;;;
-;; If you want to change the RGB values, keep in mind that various pieces
-;; of Emacs think that a color whose RGB values add up to less than 0.6 of
-;; the values for WHITE (i.e. less than 117963) are ``dark'', otherwise the
-;; color is ``light''; see `frame-set-background-mode' in lisp/faces.el for
-;; an example.
+;; If you want to change the RGB values, consider the heuristics in
+;; `color-dark-p' which is used to select a suitably contrasting
+;; foreground or background colour.
 (defvar msdos-color-values
   '(("black"          0     0     0     0)
     ("blue"           1     0     0 52480) ; MediumBlue
diff --git a/lisp/term/rxvt.el b/lisp/term/rxvt.el
index 31e3d6ede4..5dc754c8e0 100644
--- a/lisp/term/rxvt.el
+++ b/lisp/term/rxvt.el
@@ -206,13 +206,11 @@ rxvt-set-background-mode
       ;; The next line assumes that rxvt-standard-colors are ordered
       ;; by the color index in the ascending order!
       (setq rgb (car (cddr (nth bg rxvt-standard-colors))))
-      ;; See the commentary in frame-set-background-mode about the
-      ;; computation below.
-      (if (< (apply '+ rgb)
-	     ;; The following line assumes that white is the 15th
-	     ;; color in rxvt-standard-colors.
-	     (* (apply '+ (car (cddr (nth 15 rxvt-standard-colors)))) 0.6))
-	  (set-terminal-parameter nil 'background-mode 'dark)))))
+      ;; The following line assumes that white is the 15th
+      ;; color in rxvt-standard-colors.
+      (let ((comp-max (float (caddr (nth 15 rxvt-standard-colors)))))
+        (when (color-dark-p (mapcar (lambda (c) (/ c comp-max)) rgb))
+	  (set-terminal-parameter nil 'background-mode 'dark))))))
 
 (provide 'term/rxvt)
 
diff --git a/lisp/term/w32console.el b/lisp/term/w32console.el
index 36e9d896c7..0e9d7c8b5c 100644
--- a/lisp/term/w32console.el
+++ b/lisp/term/w32console.el
@@ -86,9 +86,9 @@ terminal-init-w32console
     (setq r (nth 2 descr)
 	  g (nth 3 descr)
 	  b (nth 4 descr))
-    (if (< (+ r g b) (* .6 (+ 65535 65535 65535)))
-	(setq bg-mode 'dark)
-      (setq bg-mode 'light))
+    (setq bg-mode (if (color-dark-p
+                       (list (/ r 65535.0) (/ g 65535.0) (/ b 65535.0)))
+                      'dark 'light))
     (set-terminal-parameter nil 'background-mode bg-mode))
   (tty-set-up-initial-frame-faces)
   (run-hooks 'terminal-init-w32-hook))
diff --git a/lisp/term/xterm.el b/lisp/term/xterm.el
index 1a727e3933..bf9bcae526 100644
--- a/lisp/term/xterm.el
+++ b/lisp/term/xterm.el
@@ -1120,9 +1120,8 @@ xterm-register-default-colors
     (clear-face-cache)))
 
 (defun xterm-maybe-set-dark-background-mode (redc greenc bluec)
-  ;; Use the heuristic in `frame-set-background-mode' to decide if a
-  ;; frame is dark.
-  (when (< (+ redc greenc bluec) (* .6 (+ 65535 65535 65535)))
+  (when (color-dark-p (mapcar (lambda (c) (/ c 65535.0))
+                              (list redc greenc bluec)))
     (set-terminal-parameter nil 'background-mode 'dark)
     t))
 
diff --git a/lisp/textmodes/css-mode.el b/lisp/textmodes/css-mode.el
index 0035c5e7b0..2cd99787e8 100644
--- a/lisp/textmodes/css-mode.el
+++ b/lisp/textmodes/css-mode.el
@@ -1149,17 +1149,6 @@ css--compute-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 @@ css--fontify-region
 		    (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))
 
-- 
2.21.1 (Apple Git-122.3)

