X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/67ab0163d67fbfeb41c37c8a259f27eeef965520..ac5392dcfda42b26767ae966a8b290142c00bff7:/lisp/facemenu.el diff --git a/lisp/facemenu.el b/lisp/facemenu.el index e76e920a9f..88b9ddc7f5 100644 --- a/lisp/facemenu.el +++ b/lisp/facemenu.el @@ -1,6 +1,6 @@ ;;; facemenu.el --- create a face menu for interactively adding fonts to text -;; Copyright (C) 1994-1996, 2001-2011 Free Software Foundation, Inc. +;; Copyright (C) 1994-1996, 2001-2012 Free Software Foundation, Inc. ;; Author: Boris Goldowsky ;; Keywords: faces @@ -127,15 +127,6 @@ just before \"Other\" at the end." :type 'boolean :group 'facemenu) -(defvar facemenu-unlisted-faces - `(modeline region secondary-selection highlight scratch-face - ,(purecopy "^font-lock-") ,(purecopy "^gnus-") ,(purecopy "^message-") - ,(purecopy "^ediff-") ,(purecopy "^term-") ,(purecopy "^vc-") - ,(purecopy "^widget-") ,(purecopy "^custom-") ,(purecopy "^vm-")) - "*List of faces that are of no interest to the user.") -(make-obsolete-variable 'facemenu-unlisted-faces 'facemenu-listed-faces - "22.1,\n and has no effect on the Face menu") - (defcustom facemenu-listed-faces nil "List of faces to include in the Face menu. Each element should be a symbol, the name of a face. @@ -241,10 +232,12 @@ it will remove any faces not explicitly in the list." (define-key map [df] (cons (purecopy "Display Faces") 'list-faces-display)) (define-key map [dp] (cons (purecopy "Describe Properties") 'describe-text-properties)) - (define-key map [ra] (cons (purecopy "Remove Text Properties") - 'facemenu-remove-all)) - (define-key map [rm] (cons (purecopy "Remove Face Properties") - 'facemenu-remove-face-props)) + (define-key map [ra] (list 'menu-item (purecopy "Remove Text Properties") + 'facemenu-remove-all + :enable 'mark-active)) + (define-key map [rm] (list 'menu-item (purecopy "Remove Face Properties") + 'facemenu-remove-face-props + :enable 'mark-active)) (define-key map [s1] (list (purecopy "--")))) (let ((map facemenu-menu)) (define-key map [in] (cons (purecopy "Indentation") @@ -463,25 +456,6 @@ These special properties include `invisible', `intangible' and `read-only'." (defalias 'facemenu-read-color 'read-color) -(defun color-rgb-to-hsv (r g b) - "For R, G, B color components return a list of hue, saturation, value. -R, G, B input values should be in [0..65535] range. -Output values for hue are integers in [0..360] range. -Output values for saturation and value are integers in [0..100] range." - (let* ((r (/ r 65535.0)) - (g (/ g 65535.0)) - (b (/ b 65535.0)) - (max (max r g b)) - (min (min r g b)) - (h (cond ((= max min) 0) - ((= max r) (mod (+ (* 60 (/ (- g b) (- max min))) 360) 360)) - ((= max g) (+ (* 60 (/ (- b r) (- max min))) 120)) - ((= max b) (+ (* 60 (/ (- r g) (- max min))) 240)))) - (s (cond ((= max 0) 0) - (t (- 1 (/ min max))))) - (v max)) - (list (round h) (round s 0.01) (round v 0.01)))) - (defcustom list-colors-sort nil "Color sort order for `list-colors-display'. `nil' means default implementation-dependent order (defined in `x-colors'). @@ -490,7 +464,8 @@ Output values for saturation and value are integers in [0..100] range." `(rgb-dist . COLOR)' sorts by the RGB distance to the specified color. `hsv' sorts by hue, saturation, value. `(hsv-dist . COLOR)' sorts by the HSV distance to the specified color -and excludes grayscale colors." +and excludes grayscale colors. +`luminance' sorts by relative luminance in the CIE XYZ color space." :type '(choice (const :tag "Unsorted" nil) (const :tag "Color Name" name) (const :tag "Red-Green-Blue" rgb) @@ -500,7 +475,8 @@ and excludes grayscale colors." (const :tag "Hue-Saturation-Value" hsv) (cons :tag "Distance on HSV cylinder" (const :tag "Distance from Color" hsv-dist) - (color :tag "Source Color Name"))) + (color :tag "Source Color Name")) + (const :tag "Luminance" luminance)) :group 'facemenu :version "24.1") @@ -508,6 +484,7 @@ and excludes grayscale colors." "Return a list of keys for sorting colors depending on `list-colors-sort'. COLOR is the name of the color. When return value is nil, filter out the color from the output." + (require 'color) (cond ((null list-colors-sort) color) ((eq list-colors-sort 'name) @@ -517,35 +494,37 @@ filter out the color from the output." ((eq (car-safe list-colors-sort) 'rgb-dist) (color-distance color (cdr list-colors-sort))) ((eq list-colors-sort 'hsv) - (apply 'color-rgb-to-hsv (color-values color))) + (apply 'color-rgb-to-hsv (color-name-to-rgb color))) ((eq (car-safe list-colors-sort) 'hsv-dist) - (let* ((c-rgb (color-values color)) + (let* ((c-rgb (color-name-to-rgb color)) (c-hsv (apply 'color-rgb-to-hsv c-rgb)) (o-hsv (apply 'color-rgb-to-hsv - (color-values (cdr list-colors-sort))))) + (color-name-to-rgb (cdr list-colors-sort))))) (unless (and (eq (nth 0 c-rgb) (nth 1 c-rgb)) ; exclude grayscale (eq (nth 1 c-rgb) (nth 2 c-rgb))) ;; 3D Euclidean distance (sqrt is not needed for sorting) (+ (expt (- 180 (abs (- 180 (abs (- (nth 0 c-hsv) ; wrap hue (nth 0 o-hsv)))))) 2) (expt (- (nth 1 c-hsv) (nth 1 o-hsv)) 2) - (expt (- (nth 2 c-hsv) (nth 2 o-hsv)) 2))))))) + (expt (- (nth 2 c-hsv) (nth 2 o-hsv)) 2))))) + ((eq list-colors-sort 'luminance) + (let ((c-rgb (color-name-to-rgb color))) + (+ (* (nth 0 c-rgb) 0.21266729) + (* (nth 1 c-rgb) 0.7151522) + (* (nth 2 c-rgb) 0.0721750)))))) (defun list-colors-display (&optional list buffer-name callback) "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 that the current display can handle. Customize +`list-colors-sort' to change the order in which colors are shown. -If the optional argument BUFFER-NAME is nil, it defaults to -*Colors*. +If the optional argument BUFFER-NAME is nil, it defaults to *Colors*. If the optional argument CALLBACK is non-nil, it should be a function to call each time the user types RET or clicks on a -color. The function should accept a single argument, the color -name. - -You can change the color sort order by customizing `list-colors-sort'." +color. The function should accept a single argument, the color name." (interactive) (when (and (null list) (> (display-color-cells) 0)) (setq list (list-colors-duplicates (defined-colors))) @@ -580,17 +559,17 @@ You can change the color sort order by customizing `list-colors-sort'." (let ((lc (nthcdr (1- (display-color-cells)) list))) (if lc (setcdr lc nil))))) - (let ((buf (get-buffer-create "*Colors*"))) - (with-current-buffer buf + (unless buffer-name + (setq buffer-name "*Colors*")) + (with-help-window buffer-name + (with-current-buffer standard-output (erase-buffer) - (setq truncate-lines t) - ;; Display buffer before generating content to allow - ;; `list-colors-print' to get the right window-width. - (pop-to-buffer buf) (list-colors-print list callback) - (set-buffer-modified-p nil))) - (if callback - (message "Click on a color to select it."))) + (set-buffer-modified-p nil) + (setq truncate-lines t))) + (when callback + (pop-to-buffer buffer-name) + (message "Click on a color to select it."))) (defun list-colors-print (list &optional callback) (let ((callback-fn @@ -607,30 +586,19 @@ You can change the color sort order by customizing `list-colors-sort'." (let* ((opoint (point)) (color-values (color-values (car color))) (light-p (>= (apply 'max color-values) - (* (car (color-values "white")) .5))) - (max-len (max (- (window-width) 33) 20))) + (* (car (color-values "white")) .5)))) (insert (car color)) (indent-to 22) (put-text-property opoint (point) 'face `(:background ,(car color))) (put-text-property (prog1 (point) (insert " ") - (if (cdr color) - ;; Insert as many color names as possible, fitting max-len. - (let ((names (list (car color))) - (others (cdr color)) - (len (length (car color))) - newlen) - (while (and others - (< (setq newlen (+ len 2 (length (car others)))) - max-len)) - (setq len newlen) - (push (pop others) names)) - (insert (mapconcat 'identity (nreverse names) ", "))) - (insert (car color)))) + ;; Insert all color names. + (insert (mapconcat 'identity color ","))) (point) 'face (list :foreground (car color))) - (indent-to (max (- (window-width) 8) 44)) + (insert (propertize " " 'display '(space :align-to (- right 9)))) + (insert " ") (insert (propertize (apply 'format "#%02x%02x%02x" (mapcar (lambda (c) (lsh c -8)) @@ -638,7 +606,7 @@ You can change the color sort order by customizing `list-colors-sort'." 'mouse-face 'highlight 'help-echo (let ((hsv (apply 'color-rgb-to-hsv - (color-values (car color))))) + (color-name-to-rgb (car color))))) (format "H:%d S:%d V:%d" (nth 0 hsv) (nth 1 hsv) (nth 2 hsv))))) (when callback @@ -666,8 +634,17 @@ a list of colors that the current display can handle." (l list)) (while (cdr l) (if (and (facemenu-color-equal (car (car l)) (car (car (cdr l)))) - (not (if (fboundp 'w32-default-color-map) - (not (assoc (car (car l)) (w32-default-color-map)))))) + ;; On MS-Windows, there are logical colors that might have + ;; the same value but 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. + ;; These system colors all have names prefixed with "System", + ;; which is hardcoded in w32fns.c (SYSTEM_COLOR_PREFIX). + ;; This makes them different to any other color. Bug#9722 + (not (and (eq system-type 'windows-nt) + (string-match-p "^System" (car (car l)))))) (progn (setcdr (car l) (cons (car (car (cdr l))) (cdr (car l)))) (setcdr l (cdr (cdr l)))) @@ -854,19 +831,13 @@ MENU should be `facemenu-foreground-menu' or `facemenu-background-menu'. Return the event type (a symbol) of the added menu entry. This is called whenever you use a new color." - (let (symbol docstring) + (let (symbol) (unless (color-defined-p color) (error "Color `%s' undefined" color)) (cond ((eq menu 'facemenu-foreground-menu) - (setq docstring - (format "Select foreground color %s for subsequent insertion." - color) - symbol (intern (concat "fg:" color)))) + (setq symbol (intern (concat "fg:" color)))) ((eq menu 'facemenu-background-menu) - (setq docstring - (format "Select background color %s for subsequent insertion." - color) - symbol (intern (concat "bg:" color)))) + (setq symbol (intern (concat "bg:" color)))) (t (error "MENU should be `facemenu-foreground-menu' or `facemenu-background-menu'"))) (unless (facemenu-iterate ; Check if color is already in the menu. (lambda (m) (and (listp m)