;;; 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, 2011, 2012 Free Software Foundation, Inc.
+;; Copyright (C) 1994-1996, 2001-2014 Free Software Foundation, Inc.
;; Author: Boris Goldowsky <boris@gnu.org>
;; Keywords: faces
+;; Package: emacs
;; This file is part of GNU Emacs.
: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.
(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")
if `facemenu-listed-faces' says to do that."
(interactive (list (progn
(barf-if-buffer-read-only)
- (read-face-name "Use face"))
+ (read-face-name "Use face" (face-at-point t)))
(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 "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 list-colors-display (&optional list buffer-name)
+(defalias 'facemenu-read-color 'read-color)
+
+(defcustom list-colors-sort nil
+ "Color sort order for `list-colors-display'.
+`nil' means default implementation-dependent order (defined in `x-colors').
+`name' sorts by color name.
+`rgb' sorts by red, green, blue components.
+`(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.
+`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)
+ (cons :tag "Distance on RGB cube"
+ (const :tag "Distance from Color" rgb-dist)
+ (color :tag "Source Color Name"))
+ (const :tag "Hue-Saturation-Value" hsv)
+ (cons :tag "Distance on HSV cylinder"
+ (const :tag "Distance from Color" hsv-dist)
+ (color :tag "Source Color Name"))
+ (const :tag "Luminance" luminance))
+ :group 'facemenu
+ :version "24.1")
+
+(defun list-colors-sort-key (color)
+ "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)
+ (downcase color))
+ ((eq list-colors-sort 'rgb)
+ (color-values color))
+ ((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-name-to-rgb color)))
+ ((eq (car-safe list-colors-sort) 'hsv-dist)
+ (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-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)))))
+ ((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))))))
+
+(defvar list-colors-callback nil
+ "Value of CALLBACK arg passed to `list-colors-display'; internal use.")
+
+(defun list-colors-redisplay (_ignore-auto _noconfirm)
+ "Redisplay the colors using `list-colors-sort'.
+
+This is installed as a `revert-buffer-function' in the *Colors* buffer."
+ (list-colors-display nil (buffer-name) list-colors-callback))
+
+(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. If the optional
-argument BUFFER-NAME is nil, it defaults to *Colors*."
+colors that the current display can handle. Customize
+`list-colors-sort' to change the order in which colors are shown.
+Type `g' or \\[revert-buffer] after customizing `list-colors-sort'
+to redisplay colors in the new order.
+
+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."
(interactive)
(when (and (null list) (> (display-color-cells) 0))
(setq list (list-colors-duplicates (defined-colors)))
+ (when list-colors-sort
+ ;; Schwartzian transform with `(color key1 key2 key3 ...)'.
+ (setq list (mapcar
+ 'car
+ (sort (delq nil (mapcar
+ (lambda (c)
+ (let ((key (list-colors-sort-key
+ (car c))))
+ (when key
+ (cons c (if (consp key) key
+ (list key))))))
+ list))
+ (lambda (a b)
+ (let* ((a-keys (cdr a))
+ (b-keys (cdr b))
+ (a-key (car a-keys))
+ (b-key (car b-keys)))
+ ;; Skip common keys at the beginning of key lists.
+ (while (and a-key b-key (equal a-key b-key))
+ (setq a-keys (cdr a-keys) a-key (car a-keys)
+ b-keys (cdr b-keys) b-key (car b-keys)))
+ (cond
+ ((and (numberp a-key) (numberp b-key))
+ (< a-key b-key))
+ ((and (stringp a-key) (stringp b-key))
+ (string< a-key b-key)))))))))
(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-help-window (or buffer-name "*Colors*")
+ (unless buffer-name
+ (setq buffer-name "*Colors*"))
+ (with-help-window buffer-name
(with-current-buffer standard-output
+ (erase-buffer)
+ (list-colors-print list callback)
+ (set-buffer-modified-p nil)
(setq truncate-lines t)
- (if temp-buffer-show-function
- (list-colors-print list)
- ;; Call list-colors-print from temp-buffer-show-hook
- ;; to get the right value of window-width in list-colors-print
- ;; after the buffer is displayed.
- (add-hook 'temp-buffer-show-hook
- (lambda ()
- (set-buffer-modified-p
- (prog1 (buffer-modified-p)
- (list-colors-print list))))
- nil t)))))
-
-(defun list-colors-print (list)
- (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 (list ':background (car color)))
- (put-text-property
- (prog1 (point)
- (insert " " (if (cdr color)
- (mapconcat 'identity (cdr color) ", ")
- (car color))))
- (point)
- 'face (list ':foreground (car color)))
- (indent-to (max (- (window-width) 8) 44))
- (insert (apply 'format "#%02x%02x%02x"
- (mapcar (lambda (c) (lsh c -8))
- (color-values (car color)))))
-
- (insert "\n"))
- (goto-char (point-min)))
+ (setq-local list-colors-callback callback)
+ (setq revert-buffer-function 'list-colors-redisplay)))
+ (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
+ (if callback
+ `(lambda (button)
+ (funcall ,callback (button-get button 'color-name))))))
+ (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)))
+ (let* ((opoint (point))
+ (color-values (color-values (car color)))
+ (light-p (>= (apply 'max color-values)
+ (* (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 " ")
+ ;; Insert all color names.
+ (insert (mapconcat 'identity color ",")))
+ (point)
+ 'face (list :foreground (car color)))
+ (insert (propertize " " 'display '(space :align-to (- right 9))))
+ (insert " ")
+ (insert (propertize
+ (apply 'format "#%02x%02x%02x"
+ (mapcar (lambda (c) (lsh c -8))
+ color-values))
+ 'mouse-face 'highlight
+ 'help-echo
+ (let ((hsv (apply 'color-rgb-to-hsv
+ (color-name-to-rgb (car color)))))
+ (format "H:%d S:%d V:%d"
+ (nth 0 hsv) (nth 1 hsv) (nth 2 hsv)))))
+ (when callback
+ (make-text-button
+ opoint (point)
+ 'follow-link t
+ 'mouse-face (list :background (car color)
+ :foreground (if light-p "black" "white"))
+ 'color-name (car color)
+ 'action callback-fn)))
+ (insert "\n"))
+ (goto-char (point-min))))
+
(defun list-colors-duplicates (&optional list)
"Return a list of colors with grouped duplicate colors.
(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))))
(cond ((equal a b) t)
((equal (color-values a) (color-values b)))))
+
+(defvar facemenu-self-insert-data nil)
+
+(defun facemenu-post-self-insert-function ()
+ (when (and (car facemenu-self-insert-data)
+ (eq last-command (cdr facemenu-self-insert-data)))
+ (put-text-property (1- (point)) (point)
+ 'face (car facemenu-self-insert-data))
+ (setq facemenu-self-insert-data nil))
+ (remove-hook 'post-self-insert-hook 'facemenu-post-self-insert-function))
+
+(defun facemenu-set-self-insert-face (face)
+ "Arrange for the next self-inserted char to have face `face'."
+ (setq facemenu-self-insert-data (cons face this-command))
+ (add-hook 'post-self-insert-hook 'facemenu-post-self-insert-function))
+
(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
text property. Otherwise, selecting the default face would not have any
effect. See `facemenu-remove-face-function'."
(interactive "*xFace: \nr")
- (if (and (eq face 'default)
- (not (eq facemenu-remove-face-function t)))
- (if facemenu-remove-face-function
- (funcall facemenu-remove-face-function start end)
- (if (and start (< start end))
- (remove-text-properties start end '(face default))
- (setq self-insert-face 'default
- self-insert-face-command this-command)))
- (if facemenu-add-face-function
- (save-excursion
- (if end (goto-char end))
- (save-excursion
- (if start (goto-char start))
- (insert-before-markers
- (funcall facemenu-add-face-function face end)))
- (if facemenu-end-add-face
- (insert (if (stringp facemenu-end-add-face)
- facemenu-end-add-face
- (funcall facemenu-end-add-face face)))))
+ (cond
+ ((and (eq face 'default)
+ (not (eq facemenu-remove-face-function t)))
+ (if facemenu-remove-face-function
+ (funcall facemenu-remove-face-function start end)
(if (and start (< start end))
- (let ((part-start start) part-end)
- (while (not (= part-start end))
- (setq part-end (next-single-property-change part-start 'face
- nil end))
- (let ((prev (get-text-property part-start 'face)))
- (put-text-property part-start part-end 'face
- (if (null prev)
- face
- (facemenu-active-faces
- (cons face
- (if (listp prev)
- prev
- (list prev)))
- ;; Specify the selected frame
- ;; because nil would mean to use
- ;; the new-frame default settings,
- ;; and those are usually nil.
- (selected-frame)))))
- (setq part-start part-end)))
- (setq self-insert-face (if (eq last-command self-insert-face-command)
- (cons face (if (listp self-insert-face)
- self-insert-face
- (list self-insert-face)))
- face)
- self-insert-face-command this-command))))
+ (remove-text-properties start end '(face default))
+ (facemenu-set-self-insert-face 'default))))
+ (facemenu-add-face-function
+ (save-excursion
+ (if end (goto-char end))
+ (save-excursion
+ (if start (goto-char start))
+ (insert-before-markers
+ (funcall facemenu-add-face-function face end)))
+ (if facemenu-end-add-face
+ (insert (if (stringp facemenu-end-add-face)
+ facemenu-end-add-face
+ (funcall facemenu-end-add-face face))))))
+ ((and start (< start end))
+ (let ((part-start start) part-end)
+ (while (not (= part-start end))
+ (setq part-end (next-single-property-change part-start 'face
+ nil end))
+ (let ((prev (get-text-property part-start 'face)))
+ (put-text-property part-start part-end 'face
+ (if (null prev)
+ face
+ (facemenu-active-faces
+ (cons face
+ (if (listp prev)
+ prev
+ (list prev)))
+ ;; Specify the selected frame
+ ;; because nil would mean to use
+ ;; the new-frame default settings,
+ ;; and those are usually nil.
+ (selected-frame)))))
+ (setq part-start part-end))))
+ (t
+ (facemenu-set-self-insert-face
+ (if (eq last-command (cdr facemenu-self-insert-data))
+ (cons face (if (listp (car facemenu-self-insert-data))
+ (car facemenu-self-insert-data)
+ (list (car facemenu-self-insert-data))))
+ face))))
(unless (facemenu-enable-faces-p)
(message "Font-lock mode will override any faces you set in this buffer")))
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