list-colors-display: display all color names

[Juri Linkov <juri@jurta.org>]

It's too bad that `list-colors-display' currently doesn't contain
all variants of color names with alternative spellings and spaces.
When I put a color name into the search ring in one buffer and then
isearch it with C-s C-s in the *Colors* buffer to see how the color
looks, often the search fails.  I need to edit the search string
to add spaces or change the spelling of color names and to try again.
This is very inconvenient.  The *Colors* buffer should contain all
color names, even duplicates with the same color values.

I understand that the reason to remove color names with the same
color value was to reduce the amount of lines in the *Colors* buffer.
So I propose the patch which displays all duplicate color names on the
same line.  When there is only one color name, it is displayed in both
background and foreground color examples.  When there are two duplicate
color names, one of them is displayed in background, and another in
foreground color.  When there are more than two color names, the first
of them is displayed in the background example, and all others are
separated by comma in the foreground color example.  For instance,

white                   white
black                   black
dark slate gray         DarkSlateGray, dark slate grey, DarkSlateGrey
dim gray                DimGray, dim grey, DimGrey
slate gray              SlateGray, slate grey, SlateGrey
light slate gray        LightSlateGray, light slate grey, LightSlateGrey
gray                    grey
light grey              LightGrey, light gray, LightGray
midnight blue           MidnightBlue
navy                    navy blue, NavyBlue

This eliminates the need to identify duplicate colors by the name.

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	26 Dec 2004 17:04:43 -0000
@@ -471,50 +471,59 @@
       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)))))))
+      (dolist (color list)
+	(or (consp color) (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 (reverse (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 (facemenu-color-equal (car (car l)) (car (car (cdr l))))
+	  (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 +534,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/