=== 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))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; 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");