mirror/emacs
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/emacs.git synced 2024-11-22 07:09:54 +00:00
Code Issues Releases Activity

(list-colors-display): Add new arg buffer-name.

Browse Source 
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.
This commit is contained in:
Juri Linkov 2005-01-11 23:53:35 +00:00
parent 30cec4ee13
commit 066a23af25
2 changed files with 61 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
lisp/ChangeLog
View File

@ -1,3 +1,15 @@
2005-01-12 Juri Linkov <juri@jurta.org>
* 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 <juri@jurta.org>
* isearch.el (search-highlight, isearch, isearch-lazy-highlight):

98
lisp/facemenu.el
View File

@ -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