[PATCH] Re: About the :distant-foreground face attribute

[Daniel Colascione <dancol@dancol.org>]

[-- Attachment #1: Type: text/plain, Size: 1809 bytes --]

On 01/08/2014 09:43 AM, Eli Zaretskii wrote:
>> From: Chong Yidong <cyd@gnu.org>
>> Cc: jan.h.d@swipnet.se,  emacs-devel@gnu.org
>> Date: Wed, 08 Jan 2014 13:24:17 +0800
>>
>> Eli Zaretskii <eliz@gnu.org> writes:
>>
>>>> The feature does not fit well with the design of the rest of the
>>>> face-handling code.  We already have a mechanism for checking to see
>>>> when to use a particular face: the DISPLAY element in a face spec.  The
>>>> :distant-foreground face attribute, by its very existence, is redundant
>>>> with what the DISPLAY element was meant to do.  This adds extra
>>>> complexity to the design, for no good reason.

The attached patch might be another solution to the problem. It replaces 
:distant-foreground with :contrast-function, which punts the actual 
contrast logic to lisp by calling the named function during face 
realization. (Performance isn't a problem in practice because we cache 
face realizations.) In lisp, we implement four low-contrast-mitigation 
policies: do not adjust for contrast, adjust automatically (by adjusting 
CIE L*A*B color space L values), adjust automatically (by adjusting the 
V values in HSV color space), or just set the foreground to a specific 
color if the contrast dips below a certain point (the current 
:distant-foreground behavior). Both the policy and the parameters (well, 
the override color) are customizable on a per-face basis; when merging 
faces, the one with the highest priority sets the whole behavior.

The patch uses the CIE L*A*B colorspace algorithm by default. It 
produces surprisingly good results, at least in my tests, adapting 
automatically to light and dark backgrounds while preserving the hues of 
theme foreground colors.

(Changing themes nukes the face property right now, so you'll have to 
reset it each time.)

[-- Attachment #2: adaptive-face.patch --]
[-- Type: text/x-patch, Size: 18485 bytes --]

=== modified file 'lisp/color.el'
--- lisp/color.el	2014-01-01 07:43:34 +0000
+++ lisp/color.el	2014-01-13 12:18:53 +0000
@@ -114,6 +114,26 @@
        (color-hue-to-rgb m1 m2 H)
        (color-hue-to-rgb m1 m2 (mod (- H (/ 1.0 3)) 1))))))
 
+(defun color-hsv-to-rgb (H S V)
+  "Convert hue, saturation and value to their RGB representation.
+H, S, and V 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."
+  (let* ((V (float V))
+         (H (/ (* 3 H) float-pi))
+         (i (floor H))
+         (ff (- H i))
+         (P (* V (- 1.0 S)))
+         (Q (* V (- 1.0 (* S ff))))
+         (T (* V (- 1.0 (* S (- 1.0 ff))))))
+    (cond
+     ((= i 0) (list V T P))
+     ((= i 1) (list Q V P))
+     ((= i 2) (list P V T))
+     ((= i 3) (list P Q V))
+     ((= i 4) (list T P V))
+     (t       (list V P Q)))))
+
 (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)))

=== modified file 'lisp/cus-face.el'
--- lisp/cus-face.el	2014-01-01 07:43:34 +0000
+++ lisp/cus-face.el	2014-01-13 12:54:58 +0000
@@ -230,6 +230,32 @@
 		   :help-echo "Name of bitmap file."
 		   :must-match t)))
 
+    (:contrast-function
+     (choice :tag "Low contrast behavior"
+             :help-echo "How do we make colors legible?"
+             (const :tag "Do not adjust" nil)
+             (const :tag "Automatic (CIE)" face-contrast-automatic-cie)
+             (const :tag "Automatic (HSV)" face-contrast-automatic-hsv)
+             (color :tag "Override foreground"))
+     ;; filter to make value suitable for customize
+     (lambda (real-value)
+       (or
+        ;; We're loaded too early to use pcase
+        (and (eq (car-safe real-value) 'lambda)
+             (equal (car (cdr real-value)) '(fg bg))
+             (null (cdr (cdr (cdr real-value))))
+             (let ((form (car (cdr (cdr real-value)))))
+               (and (eq (car-safe form) 'face-contrast-fg-override-cie)
+                    (stringp (car (cdr form)))
+                    (car (cdr form)))))
+        real-value))
+     ;; filter to make customized-value suitable for storing
+     (lambda (cus-value)
+       (if (stringp cus-value)
+           `(lambda (fg bg)
+              (face-contrast-fg-override-cie ,cus-value fg bg))
+         cus-value)))
+
     (:inherit
      (repeat :tag "Inherit"
 	     :help-echo "List of faces to inherit attributes from."

=== modified file 'lisp/faces.el'
--- lisp/faces.el	2014-01-01 07:43:34 +0000
+++ lisp/faces.el	2014-01-13 12:57:49 +0000
@@ -274,8 +274,6 @@
     (:weight (".attributeWeight" . "Face.AttributeWeight"))
     (:slant (".attributeSlant" . "Face.AttributeSlant"))
     (:foreground (".attributeForeground" . "Face.AttributeForeground"))
-    (:distant-foreground
-     (".attributeDistantForeground" . "Face.AttributeDistantForeground"))
     (:background (".attributeBackground" . "Face.AttributeBackground"))
     (:overline (".attributeOverline" . "Face.AttributeOverline"))
     (:strike-through (".attributeStrikeThrough" . "Face.AttributeStrikeThrough"))
@@ -288,7 +286,9 @@
     (:bold (".attributeBold" . "Face.AttributeBold"))
     (:italic (".attributeItalic" . "Face.AttributeItalic"))
     (:font (".attributeFont" . "Face.AttributeFont"))
-    (:inherit (".attributeInherit" . "Face.AttributeInherit"))))
+    (:inherit (".attributeInherit" . "Face.AttributeInherit"))
+    (:contrast-function (".attributeContrastFunction" .
+                         "Face.ContrastFunction"))))
   "List of X resources and classes for face attributes.
 Each element has the form (ATTRIBUTE ENTRY1 ENTRY2...) where ATTRIBUTE is
 the name of a face attribute, and each ENTRY is a cons of the form
@@ -1070,7 +1070,8 @@
     (:foreground . "foreground color")
     (:background . "background color")
     (:stipple . "background stipple")
-    (:inherit . "inheritance"))
+    (:inherit . "inheritance")
+    (:contrast-function "contrast function"))
   "An alist of descriptive names for face attributes.
 Each element has the form (ATTRIBUTE-NAME . DESCRIPTION) where
 ATTRIBUTE-NAME is a face attribute name (a keyword symbol), and
@@ -1351,7 +1352,6 @@
 		  (:weight . "Weight")
 		  (:slant . "Slant")
 		  (:foreground . "Foreground")
-		  (:distant-foreground . "DistantForeground")
 		  (:background . "Background")
 		  (:underline . "Underline")
 		  (:overline . "Overline")
@@ -1361,7 +1361,8 @@
 		  (:stipple . "Stipple")
 		  (:font . "Font")
 		  (:fontset . "Fontset")
-		  (:inherit . "Inherit")))
+		  (:inherit . "Inherit")
+                  (:contrast-function . "Contrast-function")))
 	(max-width (apply #'max (mapcar #'(lambda (x) (length (cdr x)))
 					attrs))))
     (help-setup-xref (list #'describe-face face)
@@ -1919,6 +1920,93 @@
 		 ((memq ':background face) (cadr (memq ':background face)))))
 	  (t nil))))			; Invalid face value.
 
+(defcustom face-contrast-minimum-de2000 20.0
+  "Threshold to activate low-contrast behavior in face rendering.
+Units are as reported by `color-cie-de2000'."
+  :group 'faces
+  :type 'float
+  :version "24.4")
+
+(defcustom face-contrast-minimum-color-distance 30000
+  "Threshold to activate low-contrast behavior in face rendering.
+Units are as reported by `color-distance'."
+  :group 'faces
+  :type 'integer
+  :version "24.4")
+
+(defun face-xcolor-to-rgb (color)
+  "Convert an XColor triplet to a float RGB triplet."
+  (let ((maxv (float (car (color-values "#ffffff")))))
+    (mapcar (lambda (x) (/ x maxv)) color)))
+
+(defun face-contrast-fg-override-cie (color fg bg)
+  "Override a face foreground in low contrast situations."
+  (when (require 'color nil t)
+    (when (< (color-cie-de2000
+              (apply #'color-srgb-to-lab
+                     (face-xcolor-to-rgb fg))
+              (apply #'color-srgb-to-lab
+                     (face-xcolor-to-rgb bg)))
+             face-contrast-minimum-de2000)
+      (cons color nil))))
+
+(defun face-contrast-automatic-cie (fg bg)
+  "If colors differ by too much, make contrasting colors.
+Adjust the value component of FG until it achieves a minimum
+contrast against BG. Against dark backgrounds, prefer light
+colors and vice versa."
+  (when (require 'color nil t)
+    (let* ((fg-rgb (face-xcolor-to-rgb fg))
+           (fg-lab (apply #'color-srgb-to-lab fg-rgb))
+           (bg-lab (apply #'color-srgb-to-lab
+                          (face-xcolor-to-rgb bg))))
+      (when (< (color-cie-de2000 fg-lab bg-lab) face-contrast-minimum-de2000)
+        (let ((step (if (< (car bg-lab) 50.0) +2 -2)))
+          (while (and (setf (car fg-lab) (+ step (car fg-lab)))
+                      (<= 0 (car fg-lab) 100)
+                      (< (color-cie-de2000 fg-lab bg-lab)
+                         face-contrast-minimum-de2000))))
+        (when (< (car fg-lab) 0)
+          (setf (car fg-lab) 0))
+        (when (> (car fg-lab) 100)
+          (setf (car fg-lab) 100))
+        (cons
+         (apply #'color-rgb-to-hex
+                (mapcar #'color-clamp
+                        (apply #'color-lab-to-srgb fg-lab)))
+         nil)))))
+
+(defun face-contrast-fg-override-hsv (color fg bg)
+  "Override a face foreground in low contrast situations."
+  (when (< (color-distance fg bg) face-contrast-minimum-color-distance)
+    (cons color nil)))
+
+(defun face-contrast-automatic-hsv (fg bg)
+  "If colors differ by too much, make contrasting colors.
+Adjust the value component of FG until it achieves a minimum
+contrast against BG. Against dark backgrounds, prefer light
+colors and vice versa."
+  (when (and (< (color-distance fg bg) face-contrast-minimum-color-distance)
+             (require 'color nil t))
+    (let* ((fg-rgb (face-xcolor-to-rgb fg))
+           (fg-hsv (apply #'color-rgb-to-hsv fg-rgb))
+           (bg-hsv (apply #'color-rgb-to-hsv
+                          (face-xcolor-to-rgb bg))))
+      (let ((step (if (< (car (cdr (cdr bg-hsv))) 0.5) +0.1 -0.1))
+            (h (car fg-hsv))
+            (s (car (cdr fg-hsv)))
+            (v (car (cdr (cdr fg-hsv))))
+            (new-fg))
+        (while (and (setf v (+ v step))
+                    (<= 0 v 1.0)
+                    (setf new-fg
+                          (apply #'color-rgb-to-hex
+                                 (mapcar #'color-clamp
+                                         (color-hsv-to-rgb h s v))))
+                    (< (color-distance new-fg bg)
+                       face-contrast-minimum-color-distance)))
+        (cons (or new-fg fg) nil)))))
+
 \f
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; Frame creation.
@@ -2256,19 +2344,22 @@
 ;; if background is light.
 (defface region
   '((((class color) (min-colors 88) (background dark))
-     :background "blue3")
+     :background "blue3"
+     :contrast-function face-contrast-automatic-cie)
     (((class color) (min-colors 88) (background light) (type gtk))
-     :distant-foreground "gtk_selection_fg_color"
-     :background "gtk_selection_bg_color")
+     :background "gtk_selection_bg_color"
+     :contrast-function face-contrast-automatic-cie)
     (((class color) (min-colors 88) (background light) (type ns))
-     :distant-foreground "ns_selection_fg_color"
-     :background "ns_selection_bg_color")
+     :background "ns_selection_bg_color"
+     :contrast-function face-contrast-automatic-cie)
     (((class color) (min-colors 88) (background light))
-     :background "lightgoldenrod2")
+     :background "lightgoldenrod2"
+     :contrast-function face-contrast-automatic-cie)
     (((class color) (min-colors 16) (background dark))
      :background "blue3")
     (((class color) (min-colors 16) (background light))
-     :background "lightgoldenrod2")
+     :background "lightgoldenrod2"
+     :contrast-function face-contrast-automatic-cie)
     (((class color) (min-colors 8))
      :background "blue" :foreground "white")
     (((type tty) (class mono))

=== modified file 'src/dispextern.h'
--- src/dispextern.h	2014-01-01 07:43:34 +0000
+++ src/dispextern.h	2014-01-13 08:13:06 +0000
@@ -1556,7 +1556,7 @@
   LFACE_FONT_INDEX,
   LFACE_INHERIT_INDEX,
   LFACE_FONTSET_INDEX,
-  LFACE_DISTANT_FOREGROUND_INDEX,
+  LFACE_CONTRAST_FUNCTION_INDEX,
   LFACE_VECTOR_SIZE
 };
 

=== modified file 'src/xfaces.c'
--- src/xfaces.c	2014-01-01 07:43:34 +0000
+++ src/xfaces.c	2014-01-13 09:26:17 +0000
@@ -292,7 +292,7 @@
 static Lisp_Object QCfont, QCbold, QCitalic;
 static Lisp_Object QCreverse_video;
 static Lisp_Object QCoverline, QCstrike_through, QCbox, QCinherit;
-static Lisp_Object QCfontset, QCdistant_foreground;
+static Lisp_Object QCfontset, QCcontrast_function;
 
 /* Symbols used for attribute values.  */
 
@@ -1263,8 +1263,6 @@
 
 #ifdef HAVE_WINDOW_SYSTEM
 
-#define NEAR_SAME_COLOR_THRESHOLD 30000
-
 /* Load colors for face FACE which is used on frame F.  Colors are
    specified by slots LFACE_BACKGROUND_INDEX and LFACE_FOREGROUND_INDEX
    of ATTRS.  If the background color specified is not supported on F,
@@ -1276,6 +1274,8 @@
 {
   Lisp_Object fg, bg, dfg;
   XColor xfg, xbg;
+  Lisp_Object contrast_function;
+  Lisp_Object adj_cons;
 
   bg = attrs[LFACE_BACKGROUND_INDEX];
   fg = attrs[LFACE_FOREGROUND_INDEX];
@@ -1303,14 +1303,30 @@
   face->background = load_color2 (f, face, bg, LFACE_BACKGROUND_INDEX, &xbg);
   face->foreground = load_color2 (f, face, fg, LFACE_FOREGROUND_INDEX, &xfg);
 
-  dfg = attrs[LFACE_DISTANT_FOREGROUND_INDEX];
-  if (!NILP (dfg) && !UNSPECIFIEDP (dfg)
-      && color_distance (&xbg, &xfg) < NEAR_SAME_COLOR_THRESHOLD)
+  contrast_function = attrs[LFACE_CONTRAST_FUNCTION_INDEX];
+  if (!NILP (contrast_function) && !UNSPECIFIEDP (contrast_function))
     {
-      if (EQ (attrs[LFACE_INVERSE_INDEX], Qt))
-        face->background = load_color (f, face, dfg, LFACE_BACKGROUND_INDEX);
-      else
-        face->foreground = load_color (f, face, dfg, LFACE_FOREGROUND_INDEX);
+      /* Give lisp a chance to adjust the generated colors.  */
+      adj_cons = safe_call2 (contrast_function,
+                             list3 (make_number (xfg.red),
+                                    make_number (xfg.green),
+                                    make_number (xfg.blue)),
+                             list3 (make_number (xbg.red),
+                                    make_number (xbg.green),
+                                    make_number (xbg.blue)));
+
+      if (CONSP (adj_cons))
+        {
+          if (STRINGP (XCAR (adj_cons)))
+              face->foreground =
+              load_color2 (f, face, XCAR (adj_cons),
+                           LFACE_FOREGROUND_INDEX, &xfg);
+
+          if (STRINGP (XCDR (adj_cons)))
+            face->background =
+              load_color2 (f, face, XCDR (adj_cons),
+                         LFACE_BACKGROUND_INDEX, &xbg);
+        }
     }
 }
 
@@ -1742,8 +1758,8 @@
 #define LFACE_FONT(LFACE)	    AREF ((LFACE), LFACE_FONT_INDEX)
 #define LFACE_INHERIT(LFACE)	    AREF ((LFACE), LFACE_INHERIT_INDEX)
 #define LFACE_FONTSET(LFACE)	    AREF ((LFACE), LFACE_FONTSET_INDEX)
-#define LFACE_DISTANT_FOREGROUND(LFACE) \
-  AREF ((LFACE), LFACE_DISTANT_FOREGROUND_INDEX)
+#define LFACE_CONTRAST_FUNCTION(LFACE) \
+  AREF ((LFACE), LFACE_CONTRAST_FUNCTION_INDEX)
 
 /* Non-zero if LFACE is a Lisp face.  A Lisp face is a vector of size
    LFACE_VECTOR_SIZE which has the symbol `face' in slot 0.  */
@@ -1806,9 +1822,6 @@
   eassert (UNSPECIFIEDP (attrs[LFACE_FOREGROUND_INDEX])
 	   || IGNORE_DEFFACE_P (attrs[LFACE_FOREGROUND_INDEX])
 	   || STRINGP (attrs[LFACE_FOREGROUND_INDEX]));
-  eassert (UNSPECIFIEDP (attrs[LFACE_DISTANT_FOREGROUND_INDEX])
-	   || IGNORE_DEFFACE_P (attrs[LFACE_DISTANT_FOREGROUND_INDEX])
-	   || STRINGP (attrs[LFACE_DISTANT_FOREGROUND_INDEX]));
   eassert (UNSPECIFIEDP (attrs[LFACE_BACKGROUND_INDEX])
 	   || IGNORE_DEFFACE_P (attrs[LFACE_BACKGROUND_INDEX])
 	   || STRINGP (attrs[LFACE_BACKGROUND_INDEX]));
@@ -1817,6 +1830,10 @@
 	   || NILP (attrs[LFACE_INHERIT_INDEX])
 	   || SYMBOLP (attrs[LFACE_INHERIT_INDEX])
 	   || CONSP (attrs[LFACE_INHERIT_INDEX]));
+  eassert (UNSPECIFIEDP (attrs[LFACE_CONTRAST_FUNCTION_INDEX])
+	   || IGNORE_DEFFACE_P (attrs[LFACE_CONTRAST_FUNCTION_INDEX])
+	   || NILP (attrs[LFACE_CONTRAST_FUNCTION_INDEX])
+	   || FUNCTIONP (attrs[LFACE_CONTRAST_FUNCTION_INDEX]));
 #ifdef HAVE_WINDOW_SYSTEM
   eassert (UNSPECIFIEDP (attrs[LFACE_STIPPLE_INDEX])
 	   || IGNORE_DEFFACE_P (attrs[LFACE_STIPPLE_INDEX])
@@ -2074,8 +2091,8 @@
   int i;
 
   for (i = 1; i < LFACE_VECTOR_SIZE; ++i)
-    if (i != LFACE_FONT_INDEX && i != LFACE_INHERIT_INDEX
-        && i != LFACE_DISTANT_FOREGROUND_INDEX)
+    if (i != LFACE_FONT_INDEX && i != LFACE_INHERIT_INDEX &&
+        i != LFACE_CONTRAST_FUNCTION_INDEX)
       if ((UNSPECIFIEDP (attrs[i]) || IGNORE_DEFFACE_P (attrs[i])))
 	break;
 
@@ -2476,13 +2493,6 @@
 		  else
 		    err = 1;
 		}
-	      else if (EQ (keyword, QCdistant_foreground))
-		{
-		  if (STRINGP (value))
-		    to[LFACE_DISTANT_FOREGROUND_INDEX] = value;
-		  else
-		    err = 1;
-		}
 	      else if (EQ (keyword, QCbackground))
 		{
 		  if (STRINGP (value))
@@ -2525,6 +2535,13 @@
 					err_msgs, named_merge_points))
 		    err = 1;
 		}
+              else if (EQ (keyword, QCcontrast_function))
+                {
+                  if (NILP (value) || FUNCTIONP (value))
+                    to[LFACE_CONTRAST_FUNCTION_INDEX] = value;
+                  else
+                    err = 1;
+                }
 	      else
 		err = 1;
 
@@ -3039,23 +3056,6 @@
       old_value = LFACE_FOREGROUND (lface);
       ASET (lface, LFACE_FOREGROUND_INDEX, value);
     }
-  else if (EQ (attr, QCdistant_foreground))
-    {
-      /* Compatibility with 20.x.  */
-      if (NILP (value))
-	value = Qunspecified;
-      if (!UNSPECIFIEDP (value) && !IGNORE_DEFFACE_P (value))
-	{
-	  /* Don't check for valid color names here because it depends
-	     on the frame (display) whether the color will be valid
-	     when the face is realized.  */
-	  CHECK_STRING (value);
-	  if (SCHARS (value) == 0)
-	    signal_error ("Empty distant-foreground color value", value);
-	}
-      old_value = LFACE_DISTANT_FOREGROUND (lface);
-      ASET (lface, LFACE_DISTANT_FOREGROUND_INDEX, value);
-    }
   else if (EQ (attr, QCbackground))
     {
       /* Compatibility with 20.x.  */
@@ -3073,6 +3073,15 @@
       old_value = LFACE_BACKGROUND (lface);
       ASET (lface, LFACE_BACKGROUND_INDEX, value);
     }
+  else if (EQ (attr, QCcontrast_function))
+    {
+      if (!UNSPECIFIEDP (value) && !IGNORE_DEFFACE_P (value)
+          && !FUNCTIONP (value) && !NILP (value))
+        signal_error ("Invalid contrast function", value);
+
+      old_value = LFACE_CONTRAST_FUNCTION (lface);
+      ASET (lface, LFACE_CONTRAST_FUNCTION_INDEX, value);
+    }
   else if (EQ (attr, QCstipple))
     {
 #if defined (HAVE_WINDOW_SYSTEM)
@@ -3700,8 +3709,6 @@
     value = LFACE_INVERSE (lface);
   else if (EQ (keyword, QCforeground))
     value = LFACE_FOREGROUND (lface);
-  else if (EQ (keyword, QCdistant_foreground))
-    value = LFACE_DISTANT_FOREGROUND (lface);
   else if (EQ (keyword, QCbackground))
     value = LFACE_BACKGROUND (lface);
   else if (EQ (keyword, QCstipple))
@@ -3714,6 +3721,8 @@
     value = LFACE_FONT (lface);
   else if (EQ (keyword, QCfontset))
     value = LFACE_FONTSET (lface);
+  else if (EQ (keyword, QCcontrast_function))
+    value = LFACE_CONTRAST_FUNCTION (lface);
   else
     signal_error ("Invalid face attribute name", keyword);
 
@@ -4741,9 +4750,6 @@
       || (!UNSPECIFIEDP (attrs[LFACE_FOREGROUND_INDEX])
 	  && face_attr_equal_p (attrs[LFACE_FOREGROUND_INDEX],
 				def_attrs[LFACE_FOREGROUND_INDEX]))
-      || (!UNSPECIFIEDP (attrs[LFACE_DISTANT_FOREGROUND_INDEX])
-	  && face_attr_equal_p (attrs[LFACE_DISTANT_FOREGROUND_INDEX],
-				def_attrs[LFACE_DISTANT_FOREGROUND_INDEX]))
       || (!UNSPECIFIEDP (attrs[LFACE_BACKGROUND_INDEX])
 	  && face_attr_equal_p (attrs[LFACE_BACKGROUND_INDEX],
 				def_attrs[LFACE_BACKGROUND_INDEX]))
@@ -6406,7 +6412,7 @@
   DEFSYM (QCwidth, ":width");
   DEFSYM (QCfont, ":font");
   DEFSYM (QCfontset, ":fontset");
-  DEFSYM (QCdistant_foreground, ":distant-foreground");
+  DEFSYM (QCcontrast_function, ":contrast-function");
   DEFSYM (QCbold, ":bold");
   DEFSYM (QCitalic, ":italic");
   DEFSYM (QCoverline, ":overline");