[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
Re: list-colors-display: display all color names
From: |
Juri Linkov |
Subject: |
Re: list-colors-display: display all color names |
Date: |
Wed, 29 Dec 2004 21:02:54 +0200 |
User-agent: |
Gnus/5.110002 (No Gnus v0.2) Emacs/21.3.50 (gnu/linux) |
Michael Mauger <address@hidden> writes:
> Does matching on the name rather than the color value result in a different
> output with your other changes? Should we match on color value unless the
> name
> starts with the string "System"?
The problem is that "SystemMenuText" and "SystemText" are not color names,
but rather color settings. Matching them by name is not a reliable solution.
There is a likelihood of non-Windows color names starting with the string
"System", or Windows colors having name without the string "System".
I looked a little at Windows-related Emacs files, and see that the
variable `w32-default-color-map' does not contain Window theme colors.
I think it could be used to match Window theme color by a condition like
(not (and (boundp 'w32-default-color-map)
(not (assoc (car (car l)) w32-default-color-map))))
I don't use Windows, so I can't check it. Could you see if all names are
displayed correctly? Then do you have any objections to the following patch?
Index: lisp/facemenu.el
===================================================================
RCS file: /cvsroot/emacs/emacs/lisp/facemenu.el,v
retrieving revision 1.73
diff -u -r1.73 facemenu.el
--- lisp/facemenu.el 4 Sep 2004 19:11:18 -0000 1.73
+++ lisp/facemenu.el 29 Dec 2004 19:02:09 -0000
@@ -471,50 +471,66 @@
col)))
;;;###autoload
-(defun list-colors-display (&optional list)
+(defun list-colors-display (&optional list buffer-name)
"Display names of defined colors, and show what they look like.
If the optional argument LIST is non-nil, it should be a list of
-colors to display. Otherwise, this command computes a list
-of colors that the current display can handle."
+colors to display. Otherwise, this command computes a list of
+colors that the current display can handle. If the optional
+argument BUFFER-NAME is nil, it defaults to *Colors*."
(interactive)
(when (and (null list) (> (display-color-cells) 0))
- (setq list (defined-colors))
- ;; Delete duplicate colors.
-
- ;; Identify duplicate colors by the name rather than the color
- ;; value. For example, on MS-Windows, logical colors are added to
- ;; the list that might have the same value but have different
- ;; names and meanings. For example, `SystemMenuText' (the color
- ;; w32 uses for the text in menu entries) and `SystemWindowText'
- ;; (the default color w32 uses for the text in windows and
- ;; dialogs) may be the same display color and be adjacent in the
- ;; list. Detecting duplicates by name insures that both of these
- ;; colors remain despite identical color values.
- (let ((l list))
- (while (cdr l)
- (if (facemenu-color-name-equal (car l) (car (cdr l)))
- (setcdr l (cdr (cdr l)))
- (setq l (cdr l)))))
+ (setq list (list-colors-duplicates (defined-colors)))
(when (memq (display-visual-class) '(gray-scale pseudo-color direct-color))
;; Don't show more than what the display can handle.
(let ((lc (nthcdr (1- (display-color-cells)) list)))
(if lc
(setcdr lc nil)))))
- (with-output-to-temp-buffer "*Colors*"
+ (with-output-to-temp-buffer (or buffer-name "*Colors*")
(save-excursion
(set-buffer standard-output)
- (let (s)
- (while list
- (setq s (point))
- (insert (car list))
- (indent-to 20)
- (put-text-property s (point) 'face
- (cons 'background-color (car list)))
- (setq s (point))
- (insert " " (car list) "\n")
- (put-text-property s (point) 'face
- (cons 'foreground-color (car list)))
- (setq list (cdr list)))))))
+ (setq truncate-lines t)
+ (dolist (color list)
+ (if (consp color)
+ (if (cdr color)
+ (setq color (sort color (lambda (a b)
+ (string< (downcase a)
+ (downcase b))))))
+ (setq color (list color)))
+ (put-text-property
+ (prog1 (point)
+ (insert (car color))
+ (indent-to 22))
+ (point)
+ 'face (cons 'background-color (car color)))
+ (put-text-property
+ (prog1 (point)
+ (insert " " (if (cdr color)
+ (mapconcat 'identity (cdr color) ", ")
+ (car color))
+ "\n"))
+ (point)
+ 'face (cons 'foreground-color (car color)))))))
+
+(defun list-colors-duplicates (&optional list)
+ "Return a list of colors with grouped duplicate colors.
+If a color has no duplicates, then the element of the returned list
+has the form '(COLOR-NAME). The element of the returned list with
+duplicate colors has the form '(COLOR-NAME DUPLICATE-COLOR-NAME ...).
+This function uses the predicate `facemenu-color-equal' to compare
+color names. If the optional argument LIST is non-nil, it should
+be a list of colors to display. Otherwise, this function uses
+a list of colors that the current display can handle."
+ (let* ((list (mapcar 'list (or list (defined-colors))))
+ (l list))
+ (while (cdr l)
+ (if (and (facemenu-color-equal (car (car l)) (car (car (cdr l))))
+ (not (and (boundp 'w32-default-color-map)
+ (not (assoc (car (car l)) w32-default-color-map)))))
+ (progn
+ (setcdr (car l) (cons (car (car (cdr l))) (cdr (car l))))
+ (setcdr l (cdr (cdr l))))
+ (setq l (cdr l))))
+ list))
(defun facemenu-color-equal (a b)
"Return t if colors A and B are the same color.
@@ -525,22 +541,6 @@
(cond ((equal a b) t)
((equal (color-values a) (color-values b)))))
-(defun facemenu-color-name-equal (a b)
- "Return t if colors A and B are the same color.
-A and B should be strings naming colors. These names are
-downcased, stripped of spaces and the string `grey' is turned
-into `gray'. This accommodates alternative spellings of colors
-found commonly in the list. It returns nil if the colors differ."
- (progn
- (setq a (replace-regexp-in-string "grey" "gray"
- (replace-regexp-in-string " " ""
- (downcase a)))
- b (replace-regexp-in-string "grey" "gray"
- (replace-regexp-in-string " " ""
- (downcase b))))
-
- (equal a b)))
-
(defun facemenu-add-face (face &optional start end)
"Add FACE to text between START and END.
If START is nil or START to END is empty, add FACE to next typed character
--
Juri Linkov
http://www.jurta.org/emacs/