From: Jan Moringen <jan.moringen@uni-bielefeld.de>
To: emacs-devel@gnu.org
Subject: [PATCH] add defined-colors-with-face-attributes to faces.el
Date: Fri, 01 Jan 2010 19:21:46 +0100 [thread overview]
Message-ID: <28417_1262370107_ZZg0N5S7X6c9t.00_1262370106.3761.1186.camel@localhost.localdomain> (raw)
[-- Attachment #1: Type: text/plain, Size: 796 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)
next reply other threads:[~2010-01-01 18:21 UTC|newest]
Thread overview: 3+ messages / expand[flat|nested] mbox.gz Atom feed top
2010-01-01 18:21 Jan Moringen [this message]
2010-01-01 20:13 ` [PATCH] add defined-colors-with-face-attributes to faces.el Chong Yidong
2010-01-03 17:07 ` Jan Moringen
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://www.gnu.org/software/emacs/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=28417_1262370107_ZZg0N5S7X6c9t.00_1262370106.3761.1186.camel@localhost.localdomain \
--to=jan.moringen@uni-bielefeld.de \
--cc=emacs-devel@gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/emacs.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).