;;; facemenu.el --- create a face menu for interactively adding fonts to text
-;; Copyright (C) 1994, 1995, 1996, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1994-1996, 2001-2012 Free Software Foundation, Inc.
;; Author: Boris Goldowsky <boris@gnu.org>
;; Keywords: faces
(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")
typing a character to insert cancels the specification."
(interactive (list (progn
(barf-if-buffer-read-only)
- (facemenu-read-color "Foreground color: "))
+ (read-color "Foreground color: "))
(if (and mark-active (not current-prefix-arg))
(region-beginning))
(if (and mark-active (not current-prefix-arg))
typing a character to insert cancels the specification."
(interactive (list (progn
(barf-if-buffer-read-only)
- (facemenu-read-color "Background color: "))
+ (read-color "Background color: "))
(if (and mark-active (not current-prefix-arg))
(region-beginning))
(if (and mark-active (not current-prefix-arg))
(remove-text-properties
start end '(invisible nil intangible nil read-only nil))))
\f
-(defun facemenu-read-color (&optional prompt)
- "Read a color using the minibuffer."
- (let* ((completion-ignore-case t)
- (color-list (or facemenu-color-alist (defined-colors)))
- (completer
- (lambda (string pred all-completions)
- (if all-completions
- (or (all-completions string color-list pred)
- (if (color-defined-p string)
- (list string)))
- (or (try-completion string color-list pred)
- (if (color-defined-p string)
- string)))))
- (col (completing-read (or prompt "Color: ") completer nil t)))
- (if (equal "" col)
- nil
- col)))
-
-(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))))
+(defalias 'facemenu-read-color 'read-color)
(defcustom list-colors-sort nil
"Color sort order for `list-colors-display'.
"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)
((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)
"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)))
(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
(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))
'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
(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))))
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)
(provide 'facemenu)
-;; arch-tag: 85f6d02b-9085-420e-b651-0678f0e9c7eb
;;; facemenu.el ends here
HCoop / bpt / emacs.git / blobdiff