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

[Jan Moringen <jan.moringen@uni-bielefeld.de>]

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

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


[-- Attachment #2: read-color-99203-merge-directive.txt --]
[-- Type: text/plain, Size: 5242 bytes --]

# Bazaar merge directive format 2 (Bazaar 0.90)
# revision_id: jmoringe@techfak.uni-bielefeld.de-20100101171626-\
#   xqgoilbu7snk983t
# target_branch: ../../trunk/
# testament_sha1: 03e05b71c38db0d0fe6939f26f5602047497d84b
# timestamp: 2010-01-01 19:08:52 +0100
# base_revision_id: handa@m17n.org-20091228074829-kp7iv7vpr3xvibbn
# 
# 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  <jmoringe@techfak.uni-bielefeld.de>
+
 2009-12-28  Juanma Barranquero  <lekktu@gmail.com>
 
 	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
IyBCYXphYXIgcmV2aXNpb24gYnVuZGxlIHY0CiMKQlpoOTFBWSZTWaT0/q0AAv3fgHgwWff//142
2AD////wYAcdok+GB7HV2y6d7em29mVL0GSkaaGhpoNDJkPUNAAAAAACUQmJkaCYST00npqaBoMj
QBoAAEpE8p6Jqn6oaNNGgBoAAAAADQJEhNE0yo8TTEyZI9KeobU/VPEgNGajxQeoOYExNBhMmTJk
YTBNNMjEwBDAJJEyaamJhEZppMRTxPIpsU0AA0DEyqlUDVQYNtsR+EznaPPRSOHr6bOu0utkPCPL
d+RTfXSD5Zq2xg04WO+spJNkVnAEu4HPg46IWvd3qYrrSFNa3oc36z+UoasEz0g6DNbGTjB9NvPb
f5+Msn0ZC3XV3TKuXU954nQ221o8lonklEPZEG5kOZPfLlXC7A6tkjjxzy0vabb5txG+yXlWSyjJ
xWUXz1yurY5QQv2ssaVeSbG77OW1/9ZBYKzmp1FnMVnoqjfsufAlAni1a73VUgmT2rNwdelTstKE
cKMVs236nT41MtvSb8jp4y2HYFHwOxwg5QeGYjvYgmzufIdndCmw78kUf3r+74Sxb6PhIJeE5Izt
ddGysUh6PbwximJp1f6bTMbT7JBpAgDI9BHuDmyHsLxQ478OPqtai4TpDLBHp3gPlM+L8YYWiKkW
h65iOBWUW2HDZZeSQYtQmwcBR4pF/pBnoJARQRMah6gKDHtVRSaAhFIYpCAVmQ9oUSePLBQOb3nJ
yA5RKqNhr2brkSdESYFUMvdALqQZGNuFbkS9JC3hmN7tMwHpaRAYfsPKw0febVRLolCSng0yZpNe
SLG7EQ6FAaJWUmQsq1HDgcV7dYVY1AMaPEoUScsYIW+oHzcXHIZSVwhYKWxW8yq3dyGyR1MSQHfx
Sy1ScdCQOiZs2ERNHpoJjuBk0teNHmSYF2sTNrLLMpa3Y4E6tS8xymUdgYfwTiJVVtYBSltHvH5g
SUeW41scvlsJ0y74O8EYcvRMcskpaBOda1GsRS6gsytgUU5Z3C4LumHiBirH4WhXgoTeBEgxhQOI
6XXS11VUjKIp5O1kzFIi4ohAlEpo7QLOVpWdXQtHzK/O19rWXxZFM9rwi4GJNBTRTU3h8D3ngrDL
iVt6odo1G/5HKXZ7whIvGm345S3upI6/SRI8fOylSqNJpvHI9fseEDBl55Ge8eUi3g7f3b5h9K3L
Igkce1h3LOlmHhn6UWiPDTZ38gvnVtth7PQll0hpYTwalfOr8URVWMIr+smelBzAinX2GzTO4t6F
0SW4tEYw4jagyVT3lwDpo2idxSlT6lpx9PrO6rO4y65HwWfqaPi0e7mm+3RcIzVFRrHW8XAwhkRB
EJwNsbA5oUq5KtQ2xptOrGoQahHPx09hgRq2TCQNvMyCM6AsT5ONwjafPDBzOTA0otuXwirXLcJh
vRxYNvdsG6cMldKx2bWMSQgZoE0HkLrxKnfDcN22excTKyQjObWs55WMjBKbdOUhEarYuovo6mQa
PBhfLgY8mvF7pNZRaItBPFDkjTX3Ny+LisQuwEOfUopry3ceDMFOCV8o0Mlew35UdIGTHLFiIBEe
ISQ0uuix2iKAJi5LUZgKFaAOW4QYCpvndIpjn0a4RZyOC8haRGC/Jv7PErICNjg826XDhzJoEa7G
tobGfXME0MMvs/YC45NjVK+44JM4ixD7h5RpZHvh/T4CHC6axaBECuNfRMjNox6vmjydq9REYrIi
EunPMCoVJ19RsRQIxnNC0b+uE5jMk9M0CGgz7RY3HCHSZ6izKDEIhKCa2KjwKgQjoAVKS6UUWG8o
02GCMIDejo5r+SYFBFIGmEAtsSH44j6DRnORxEgrgE94Sq7EzubRQTm469KaNXV/4QexGJSgpQXH
JrYsxnBATAlAebgQgWogJN2S0lxCCJFZArAaqIt2agK9IrwIKwk1796wuF16JYn7mwoBvQIyUaT+
O26juR6vqFYmRJkKxDDxfeEhH0HqgFNRV+hBdiVc1XuYYG2ULXUFKfoZlDYuapkVcJmQvkBF9TDm
UDQ2NtiW2RemSRoW7RXLe8rInUCVEnc1HtcoBS6M5I750gnsrkZvhWG9BFCqqBxFlGprITpOcogu
lGmcFsENjQ0TnF71e0HgY5EQWr7X1ATRaYQQ3cjPcdku0xstg18Ik9hmqq1IMqXkQslQ5D/ARqlf
opYOmm5HDQk5KO2YYF+GVEMlxQ2IXoMYlSqoWWISQ3ibgNt/mVM5382/ixM0BwiCvRhWLK9P7F9o
sdSitSOxezpHJvIYy0IsE2wVYOAkl061Ru2ye+Ls3ne/UEP/F3JFOFCQpPT+rQ==

[-- Attachment #3: read-color-99203.patch --]
[-- Type: text/x-patch, Size: 2505 bytes --]

=== 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  <jmoringe@techfak.uni-bielefeld.de>
+
 2009-12-28  Juanma Barranquero  <lekktu@gmail.com>
 
 	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)