From mboxrd@z Thu Jan 1 00:00:00 1970 Path: main.gmane.org!not-for-mail From: Michael Mauger Newsgroups: gmane.emacs.devel Subject: Re: list-colors-display: filter same adjecent colors Date: Tue, 18 May 2004 14:13:15 -0700 (PDT) Sender: emacs-devel-bounces+emacs-devel=quimby.gnus.org@gnu.org Message-ID: <20040518211315.66216.qmail@web60310.mail.yahoo.com> NNTP-Posting-Host: deer.gmane.org Mime-Version: 1.0 Content-Type: text/plain; charset=us-ascii X-Trace: sea.gmane.org 1084917367 21655 80.91.224.253 (18 May 2004 21:56:07 GMT) X-Complaints-To: usenet@sea.gmane.org NNTP-Posting-Date: Tue, 18 May 2004 21:56:07 +0000 (UTC) Original-X-From: emacs-devel-bounces+emacs-devel=quimby.gnus.org@gnu.org Tue May 18 23:56:00 2004 Return-path: Original-Received: from quimby.gnus.org ([80.91.224.244]) by deer.gmane.org with esmtp (Exim 3.35 #1 (Debian)) id 1BQCZ6-0005XL-00 for ; Tue, 18 May 2004 23:56:00 +0200 Original-Received: from monty-python.gnu.org ([199.232.76.173]) by quimby.gnus.org with esmtp (Exim 3.35 #1 (Debian)) id 1BQCZ6-0006BH-00 for ; Tue, 18 May 2004 23:56:00 +0200 Original-Received: from localhost ([127.0.0.1] helo=monty-python.gnu.org) by monty-python.gnu.org with esmtp (Exim 4.34) id 1BQCSc-0005gQ-6O for emacs-devel@quimby.gnus.org; Tue, 18 May 2004 17:49:18 -0400 Original-Received: from list by monty-python.gnu.org with tmda-scanned (Exim 4.34) id 1BQCOb-0004og-Nc for emacs-devel@gnu.org; Tue, 18 May 2004 17:45:09 -0400 Original-Received: from mail by monty-python.gnu.org with spam-scanned (Exim 4.34) id 1BQCN9-0004PI-LO for emacs-devel@gnu.org; Tue, 18 May 2004 17:44:15 -0400 Original-Received: from [216.109.118.121] (helo=web60310.mail.yahoo.com) by monty-python.gnu.org with smtp (Exim 4.34) id 1BQBtk-00063u-It for emacs-devel@gnu.org; Tue, 18 May 2004 17:13:16 -0400 Original-Received: from [158.171.31.11] by web60310.mail.yahoo.com via HTTP; Tue, 18 May 2004 14:13:15 PDT Original-To: emacs-devel@gnu.org X-BeenThere: emacs-devel@gnu.org X-Mailman-Version: 2.1.4 Precedence: list List-Id: "Emacs development discussions." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: emacs-devel-bounces+emacs-devel=quimby.gnus.org@gnu.org Xref: main.gmane.org gmane.emacs.devel:23662 X-Report-Spam: http://spam.gmane.org/gmane.emacs.devel:23662 I think we had agreed on this one. Can it be committed? Index: emacs/lisp/facemenu.el =================================================================== RCS file: /cvsroot/emacs/emacs/lisp/facemenu.el,v retrieving revision 1.71 diff -u -r1.71 facemenu.el --- emacs/lisp/facemenu.el 1 Sep 2003 15:45:11 -0000 1.71 +++ emacs/lisp/facemenu.el 13 Mar 2004 21:59:20 -0000 @@ -480,9 +480,19 @@ (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. On w32, 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 similar color values. (let ((l list)) (while (cdr l) - (if (facemenu-color-equal (car l) (car (cdr l))) + (if (facemenu-color-name-equal (car l) (car (cdr l))) (setcdr l (cdr (cdr l))) (setq l (cdr l))))) (when (memq (display-visual-class) '(gray-scale pseudo-color direct-color)) @@ -514,6 +524,22 @@ 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.