From 066a23af25db3836c7dcc4d7f43ee63a2bb9b1dc Mon Sep 17 00:00:00 2001 From: Juri Linkov Date: Tue, 11 Jan 2005 23:53:35 +0000 Subject: [PATCH] (list-colors-display): Add new arg buffer-name. Use it. Fix docstring. Replace code for identifying duplicate colors by the name with call to `list-colors-duplicates' which identifies duplicate colors by the value unless the color is one of special Windows colors. Set truncate-lines to t. Print sorted duplicate color names on each line. Indent to 22 \(the longest color name in rgb.txt) instead of 20. Optimize. (list-colors-duplicates): New function. (facemenu-color-name-equal): Delete function. --- lisp/ChangeLog | 12 ++++++ lisp/facemenu.el | 98 ++++++++++++++++++++++++------------------------ 2 files changed, 61 insertions(+), 49 deletions(-) diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 96d8bcc5b06..a4c4c0d030e 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,15 @@ +2005-01-12 Juri Linkov + + * facemenu.el (list-colors-display): Add new arg buffer-name. + Use it. Fix docstring. Replace code for identifying duplicate + colors by the name with call to `list-colors-duplicates' which + identifies duplicate colors by the value unless the color + is one of special Windows colors. Set truncate-lines to t. + Print sorted duplicate color names on each line. Indent to 22 + \(the longest color name in rgb.txt) instead of 20. Optimize. + (list-colors-duplicates): New function. + (facemenu-color-name-equal): Delete function. + 2005-01-12 Juri Linkov * isearch.el (search-highlight, isearch, isearch-lazy-highlight): diff --git a/lisp/facemenu.el b/lisp/facemenu.el index c6cce457fe6..7179523eec8 100644 --- a/lisp/facemenu.el +++ b/lisp/facemenu.el @@ -471,50 +471,66 @@ These special properties include `invisible', `intangible' and `read-only'." 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 @@ determine the correct answer." (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