Mercurial > emacs
comparison lisp/facemenu.el @ 59482:6b794a66a256
(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.
author | Juri Linkov <juri@jurta.org> |
---|---|
date | Tue, 11 Jan 2005 23:52:12 +0000 |
parents | 6257efe5587a |
children | c6ded43591fd |
comparison
equal
deleted
inserted
replaced
59481:41496a47e473 | 59482:6b794a66a256 |
---|---|
469 (if (equal "" col) | 469 (if (equal "" col) |
470 nil | 470 nil |
471 col))) | 471 col))) |
472 | 472 |
473 ;;;###autoload | 473 ;;;###autoload |
474 (defun list-colors-display (&optional list) | 474 (defun list-colors-display (&optional list buffer-name) |
475 "Display names of defined colors, and show what they look like. | 475 "Display names of defined colors, and show what they look like. |
476 If the optional argument LIST is non-nil, it should be a list of | 476 If the optional argument LIST is non-nil, it should be a list of |
477 colors to display. Otherwise, this command computes a list | 477 colors to display. Otherwise, this command computes a list of |
478 of colors that the current display can handle." | 478 colors that the current display can handle. If the optional |
479 argument BUFFER-NAME is nil, it defaults to *Colors*." | |
479 (interactive) | 480 (interactive) |
480 (when (and (null list) (> (display-color-cells) 0)) | 481 (when (and (null list) (> (display-color-cells) 0)) |
481 (setq list (defined-colors)) | 482 (setq list (list-colors-duplicates (defined-colors))) |
482 ;; Delete duplicate colors. | |
483 | |
484 ;; Identify duplicate colors by the name rather than the color | |
485 ;; value. For example, on MS-Windows, logical colors are added to | |
486 ;; the list that might have the same value but have different | |
487 ;; names and meanings. For example, `SystemMenuText' (the color | |
488 ;; w32 uses for the text in menu entries) and `SystemWindowText' | |
489 ;; (the default color w32 uses for the text in windows and | |
490 ;; dialogs) may be the same display color and be adjacent in the | |
491 ;; list. Detecting duplicates by name insures that both of these | |
492 ;; colors remain despite identical color values. | |
493 (let ((l list)) | |
494 (while (cdr l) | |
495 (if (facemenu-color-name-equal (car l) (car (cdr l))) | |
496 (setcdr l (cdr (cdr l))) | |
497 (setq l (cdr l))))) | |
498 (when (memq (display-visual-class) '(gray-scale pseudo-color direct-color)) | 483 (when (memq (display-visual-class) '(gray-scale pseudo-color direct-color)) |
499 ;; Don't show more than what the display can handle. | 484 ;; Don't show more than what the display can handle. |
500 (let ((lc (nthcdr (1- (display-color-cells)) list))) | 485 (let ((lc (nthcdr (1- (display-color-cells)) list))) |
501 (if lc | 486 (if lc |
502 (setcdr lc nil))))) | 487 (setcdr lc nil))))) |
503 (with-output-to-temp-buffer "*Colors*" | 488 (with-output-to-temp-buffer (or buffer-name "*Colors*") |
504 (save-excursion | 489 (save-excursion |
505 (set-buffer standard-output) | 490 (set-buffer standard-output) |
506 (let (s) | 491 (setq truncate-lines t) |
507 (while list | 492 (dolist (color list) |
508 (setq s (point)) | 493 (if (consp color) |
509 (insert (car list)) | 494 (if (cdr color) |
510 (indent-to 20) | 495 (setq color (sort color (lambda (a b) |
511 (put-text-property s (point) 'face | 496 (string< (downcase a) |
512 (cons 'background-color (car list))) | 497 (downcase b)))))) |
513 (setq s (point)) | 498 (setq color (list color))) |
514 (insert " " (car list) "\n") | 499 (put-text-property |
515 (put-text-property s (point) 'face | 500 (prog1 (point) |
516 (cons 'foreground-color (car list))) | 501 (insert (car color)) |
517 (setq list (cdr list))))))) | 502 (indent-to 22)) |
503 (point) | |
504 'face (cons 'background-color (car color))) | |
505 (put-text-property | |
506 (prog1 (point) | |
507 (insert " " (if (cdr color) | |
508 (mapconcat 'identity (cdr color) ", ") | |
509 (car color)) | |
510 "\n")) | |
511 (point) | |
512 'face (cons 'foreground-color (car color))))))) | |
513 | |
514 (defun list-colors-duplicates (&optional list) | |
515 "Return a list of colors with grouped duplicate colors. | |
516 If a color has no duplicates, then the element of the returned list | |
517 has the form '(COLOR-NAME). The element of the returned list with | |
518 duplicate colors has the form '(COLOR-NAME DUPLICATE-COLOR-NAME ...). | |
519 This function uses the predicate `facemenu-color-equal' to compare | |
520 color names. If the optional argument LIST is non-nil, it should | |
521 be a list of colors to display. Otherwise, this function uses | |
522 a list of colors that the current display can handle." | |
523 (let* ((list (mapcar 'list (or list (defined-colors)))) | |
524 (l list)) | |
525 (while (cdr l) | |
526 (if (and (facemenu-color-equal (car (car l)) (car (car (cdr l)))) | |
527 (not (and (boundp 'w32-default-color-map) | |
528 (not (assoc (car (car l)) w32-default-color-map))))) | |
529 (progn | |
530 (setcdr (car l) (cons (car (car (cdr l))) (cdr (car l)))) | |
531 (setcdr l (cdr (cdr l)))) | |
532 (setq l (cdr l)))) | |
533 list)) | |
518 | 534 |
519 (defun facemenu-color-equal (a b) | 535 (defun facemenu-color-equal (a b) |
520 "Return t if colors A and B are the same color. | 536 "Return t if colors A and B are the same color. |
521 A and B should be strings naming colors. | 537 A and B should be strings naming colors. |
522 This function queries the display system to find out what the color | 538 This function queries the display system to find out what the color |
523 names mean. It returns nil if the colors differ or if it can't | 539 names mean. It returns nil if the colors differ or if it can't |
524 determine the correct answer." | 540 determine the correct answer." |
525 (cond ((equal a b) t) | 541 (cond ((equal a b) t) |
526 ((equal (color-values a) (color-values b))))) | 542 ((equal (color-values a) (color-values b))))) |
527 | |
528 (defun facemenu-color-name-equal (a b) | |
529 "Return t if colors A and B are the same color. | |
530 A and B should be strings naming colors. These names are | |
531 downcased, stripped of spaces and the string `grey' is turned | |
532 into `gray'. This accommodates alternative spellings of colors | |
533 found commonly in the list. It returns nil if the colors differ." | |
534 (progn | |
535 (setq a (replace-regexp-in-string "grey" "gray" | |
536 (replace-regexp-in-string " " "" | |
537 (downcase a))) | |
538 b (replace-regexp-in-string "grey" "gray" | |
539 (replace-regexp-in-string " " "" | |
540 (downcase b)))) | |
541 | |
542 (equal a b))) | |
543 | 543 |
544 (defun facemenu-add-face (face &optional start end) | 544 (defun facemenu-add-face (face &optional start end) |
545 "Add FACE to text between START and END. | 545 "Add FACE to text between START and END. |
546 If START is nil or START to END is empty, add FACE to next typed character | 546 If START is nil or START to END is empty, add FACE to next typed character |
547 instead. For each section of that region that has a different face property, | 547 instead. For each section of that region that has a different face property, |