;;; 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 Free Software Foundation, Inc.
+;; Copyright (C) 1994-1996, 2001-2011 Free Software Foundation, Inc.
;; Author: Boris Goldowsky <boris@gnu.org>
;; Keywords: faces
+;; Package: emacs
;; This file is part of GNU Emacs.
:prefix "facemenu-")
(defcustom facemenu-keybindings
+ (mapcar 'purecopy
'((default . "d")
(bold . "b")
(italic . "i")
(bold-italic . "l") ; {bold} intersect {italic} = {l}
- (underline . "u"))
+ (underline . "u")))
"Alist of interesting faces and keybindings.
Each element is itself a list: the car is the name of the face,
the next element is the key to use as a keyboard equivalent of the menu item;
(defvar facemenu-face-menu
(let ((map (make-sparse-keymap "Face")))
- (define-key map "o" (cons "Other..." 'facemenu-set-face))
+ (define-key map "o" (cons (purecopy "Other...") 'facemenu-set-face))
map)
"Menu keymap for faces.")
(defalias 'facemenu-face-menu facemenu-face-menu)
(defvar facemenu-foreground-menu
(let ((map (make-sparse-keymap "Foreground Color")))
- (define-key map "o" (cons "Other..." 'facemenu-set-foreground))
+ (define-key map "o" (cons (purecopy "Other...") 'facemenu-set-foreground))
map)
"Menu keymap for foreground colors.")
(defalias 'facemenu-foreground-menu facemenu-foreground-menu)
(defvar facemenu-background-menu
(let ((map (make-sparse-keymap "Background Color")))
- (define-key map "o" (cons "Other..." 'facemenu-set-background))
+ (define-key map "o" (cons (purecopy "Other...") 'facemenu-set-background))
map)
"Menu keymap for background colors.")
(defalias 'facemenu-background-menu facemenu-background-menu)
;;; Condition for enabling menu items that set faces.
(defun facemenu-enable-faces-p ()
- (not (and font-lock-mode font-lock-defaults)))
+ ;; Enable the facemenu if facemenu-add-face-function is defined
+ ;; (e.g. in Tex-mode and SGML mode), or if font-lock is off.
+ (or (not (and font-lock-mode font-lock-defaults))
+ facemenu-add-face-function))
(defvar facemenu-special-menu
(let ((map (make-sparse-keymap "Special")))
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)
- (require-match (not (eq window-system 'ns)))
- (col (completing-read (or prompt "Color: ")
- (or facemenu-color-alist
- (defined-colors))
- nil require-match)))
- (if (equal "" col)
- nil
- col)))
-
-(defun list-colors-display (&optional list buffer-name)
+(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').
+`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."
+ :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")))
+ :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."
+ (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-values color)))
+ ((eq (car-safe list-colors-sort) 'hsv-dist)
+ (let* ((c-rgb (color-values color))
+ (c-hsv (apply 'color-rgb-to-hsv c-rgb))
+ (o-hsv (apply 'color-rgb-to-hsv
+ (color-values (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)))))))
+
+(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.
+
+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'."
(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*")
- (save-excursion
- (set-buffer standard-output)
+ (let ((buf (get-buffer-create "*Colors*")))
+ (with-current-buffer buf
+ (erase-buffer)
(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 () (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)))
+ ;; 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.")))
+
+(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)))
+ (max-len (max (- (window-width) 33) 20)))
+ (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))))
+ (point)
+ 'face (list :foreground (car color)))
+ (indent-to (max (- (window-width) 8) 44))
+ (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-values (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 (boundp 'w32-default-color-map)
- (not (assoc (car (car l)) w32-default-color-map)))))
+ (not (if (fboundp '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))))
(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")))
symbol (intern name)))
(setq menu 'facemenu-face-menu)
(setq docstring
- (format "Select face `%s' for subsequent insertion.
+ (purecopy (format "Select face `%s' for subsequent insertion.
If the mark is active and there is no prefix argument,
apply face `%s' to the region instead.
This command was defined by `facemenu-add-new-face'."
- name name))
+ name name)))
(cond ((facemenu-iterate ; check if equivalent face is already in the menu
(lambda (m) (and (listp m)
(symbolp (car m))
(provide 'facemenu)
-;; arch-tag: 85f6d02b-9085-420e-b651-0678f0e9c7eb
;;; facemenu.el ends here
HCoop / bpt / emacs.git / blobdiff