Subject: bug#5305: [patch] add defined-colors-with-face-attributes to faces.el

From: Jan Moringen <[email-masked]>
Date: Sun, 03 Jan 2010 22:02:31 +0100

Hi,

in an application I wrote, the user is prompted for a color using
`read-color'. The completion table used there presents color names.
However, based on color names alone, I often found it hard to choose a
color. Therefore I wrote `defined-colors-with-face-attributes' which
is
like `defined-colors' but adds text properties to the color names that
make them render with the color they name as background. I also
changed
`read-color' to call the new function when a color display is
available.

I have tested the new behavior on X displays and TTYs and it seems to
work. However, I could not test windows or other terminal types and/or
other color depths.

If this change is considered useful, I would like to contribute it. I
have done the copyright assignment for Emacs.

Kind regards,
Jan

# Bazaar merge directive format 2 (Bazaar 0.90)
# revision_id: [email-masked]\
#   xqgoilbu7snk983t
# target_branch: ../../trunk/
# testament_sha1: 03e05b71c38db0d0fe6939f26f5602047497d84b
# timestamp: 2010-01-01 19:08:52 +0100
# base_revision_id: [email-masked]
# 
# Begin patch
=== modified file 'lisp/ChangeLog'
--- lisp/ChangeLog	2009-12-28 07:29:24 +0000
+++ lisp/ChangeLog	2010-01-01 17:16:26 +0000
@@ -1,3 +1,13 @@
+2010-01-01
+
+	Display colored completion candidates in read-color.
+	* faces.el (defined-colors-with-face-attributes): new function;
+	like defined-colors but returned color names have suitable color
+	text properties
+	(read-color): use defined-colors-with-face-attributes when display
+	supports colors
+	Patch by Jan Moringen  <[email-masked]>
+
 2009-12-28  Juanma Barranquero  <[email-masked]>
 
 	Supersede color.diff settings in git log (bug#5211).

=== modified file 'lisp/faces.el'
--- lisp/faces.el	2009-11-13 22:19:45 +0000
+++ lisp/faces.el	2010-01-01 17:16:26 +0000
@@ -1647,6 +1647,32 @@
     (mapcar 'car (tty-color-alist frame))))
 (defalias 'x-defined-colors 'defined-colors)
 
+(defun defined-colors-with-face-attributes (&optional frame)
+  "Return a list of colors supported for a particular frame.
+See `defined-colors' for arguments and return value. In contrast
+to `define-colors' the elements of the returned list are color
+strings with text properties, that make the color names render
+with the color they represent as background color."
+  (mapcar
+   (lambda (color-name)
+     (let ((foreground (readable-foreground-color color-name))
+	   (color      (copy-sequence color-name)))
+       (propertize color 'face (list :foreground foreground
+				     :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")))
+
 (declare-function xw-color-defined-p "xfns.c" (color &optional frame))
 
 (defun color-defined-p (color &optional frame)
@@ -1737,7 +1763,9 @@
   (interactive "i\np\ni\np")    ; Always convert to RGB interactively.
   (let* ((completion-ignore-case t)
          (colors (append '("foreground at point" "background at point")
-			 (defined-colors)))
+			 (if (display-color-p)
+			     (defined-colors-with-face-attributes)
+			   (defined-colors))))
          (color (completing-read (or prompt "Color (name or #R+G+B+): ")
 				 colors))
          hex-string)

# Begin bundle
=== modified file 'lisp/ChangeLog'
--- lisp/ChangeLog	2009-12-28 07:29:24 +0000
+++ lisp/ChangeLog	2010-01-01 17:16:26 +0000
@@ -1,3 +1,13 @@
+2010-01-01
+
+	Display colored completion candidates in read-color.
+	* faces.el (defined-colors-with-face-attributes): new function;
+	like defined-colors but returned color names have suitable color
+	text properties
+	(read-color): use defined-colors-with-face-attributes when display
+	supports colors
+	Patch by Jan Moringen  <[email-masked]>
+
 2009-12-28  Juanma Barranquero  <[email-masked]>
 
 	Supersede color.diff settings in git log (bug#5211).

=== modified file 'lisp/faces.el'
--- lisp/faces.el	2009-11-13 22:19:45 +0000
+++ lisp/faces.el	2010-01-01 17:16:26 +0000
@@ -1647,6 +1647,32 @@
     (mapcar 'car (tty-color-alist frame))))
 (defalias 'x-defined-colors 'defined-colors)
 
+(defun defined-colors-with-face-attributes (&optional frame)
+  "Return a list of colors supported for a particular frame.
+See `defined-colors' for arguments and return value. In contrast
+to `define-colors' the elements of the returned list are color
+strings with text properties, that make the color names render
+with the color they represent as background color."
+  (mapcar
+   (lambda (color-name)
+     (let ((foreground (readable-foreground-color color-name))
+	   (color      (copy-sequence color-name)))
+       (propertize color 'face (list :foreground foreground
+				     :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")))
+
 (declare-function xw-color-defined-p "xfns.c" (color &optional frame))
 
 (defun color-defined-p (color &optional frame)
@@ -1737,7 +1763,9 @@
   (interactive "i\np\ni\np")    ; Always convert to RGB interactively.
   (let* ((completion-ignore-case t)
          (colors (append '("foreground at point" "background at point")
-			 (defined-colors)))
+			 (if (display-color-p)
+			     (defined-colors-with-face-attributes)
+			   (defined-colors))))
          (color (completing-read (or prompt "Color (name or #R+G+B+): ")
 				 colors))
          hex-string)