| 1 | ;;; facemenu.el --- create a face menu for interactively adding fonts to text |
| 2 | |
| 3 | ;; Copyright (C) 1994-1996, 2001-2014 Free Software Foundation, Inc. |
| 4 | |
| 5 | ;; Author: Boris Goldowsky <boris@gnu.org> |
| 6 | ;; Keywords: faces |
| 7 | ;; Package: emacs |
| 8 | |
| 9 | ;; This file is part of GNU Emacs. |
| 10 | |
| 11 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
| 12 | ;; it under the terms of the GNU General Public License as published by |
| 13 | ;; the Free Software Foundation, either version 3 of the License, or |
| 14 | ;; (at your option) any later version. |
| 15 | |
| 16 | ;; GNU Emacs is distributed in the hope that it will be useful, |
| 17 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 18 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 19 | ;; GNU General Public License for more details. |
| 20 | |
| 21 | ;; You should have received a copy of the GNU General Public License |
| 22 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
| 23 | |
| 24 | ;;; Commentary: |
| 25 | |
| 26 | ;; This file defines a menu of faces (bold, italic, etc) which allows you to |
| 27 | ;; set the face used for a region of the buffer. Some faces also have |
| 28 | ;; keybindings, which are shown in the menu. |
| 29 | ;; |
| 30 | ;; The menu also contains submenus for indentation and justification-changing |
| 31 | ;; commands. |
| 32 | |
| 33 | ;;; Usage: |
| 34 | ;; Selecting a face from the menu or typing the keyboard equivalent will |
| 35 | ;; change the region to use that face. If you use transient-mark-mode and the |
| 36 | ;; region is not active, the face will be remembered and used for the next |
| 37 | ;; insertion. It will be forgotten if you move point or make other |
| 38 | ;; modifications before inserting or typing anything. |
| 39 | ;; |
| 40 | ;; Faces can be selected from the keyboard as well. |
| 41 | ;; The standard keybindings are M-o (or ESC o) + letter: |
| 42 | ;; M-o i = "set italic", M-o b = "set bold", etc. |
| 43 | |
| 44 | ;;; Customization: |
| 45 | ;; An alternative set of keybindings that may be easier to type can be set up |
| 46 | ;; using "Alt" or "Hyper" keys. This requires that you either have or create |
| 47 | ;; an Alt or Hyper key on your keyboard. On my keyboard, there is a key |
| 48 | ;; labeled "Alt", but to make it act as an Alt key I have to put this command |
| 49 | ;; into my .xinitrc: |
| 50 | ;; xmodmap -e "add Mod3 = Alt_L" |
| 51 | ;; Or, I can make it into a Hyper key with this: |
| 52 | ;; xmodmap -e "keysym Alt_L = Hyper_L" -e "add Mod2 = Hyper_L" |
| 53 | ;; Check with local X-perts for how to do it on your system. |
| 54 | ;; Then you can define your keybindings with code like this in your .emacs: |
| 55 | ;; (setq facemenu-keybindings |
| 56 | ;; '((default . [?\H-d]) |
| 57 | ;; (bold . [?\H-b]) |
| 58 | ;; (italic . [?\H-i]) |
| 59 | ;; (bold-italic . [?\H-l]) |
| 60 | ;; (underline . [?\H-u]))) |
| 61 | ;; (facemenu-update) |
| 62 | ;; (setq facemenu-keymap global-map) |
| 63 | ;; (define-key global-map [?\H-c] 'facemenu-set-foreground) ; set fg color |
| 64 | ;; (define-key global-map [?\H-C] 'facemenu-set-background) ; set bg color |
| 65 | ;; |
| 66 | ;; The order of the faces that appear in the menu and their keybindings can be |
| 67 | ;; controlled by setting the variables `facemenu-keybindings' and |
| 68 | ;; `facemenu-new-faces-at-end'. List faces that you want to use in documents |
| 69 | ;; in `facemenu-listed-faces'. |
| 70 | |
| 71 | ;;; Known Problems: |
| 72 | ;; Bold and Italic do not combine to create bold-italic if you select them |
| 73 | ;; both, although most other combinations (eg bold + underline + some color) |
| 74 | ;; do the intuitive thing. |
| 75 | ;; |
| 76 | ;; There is at present no way to display what the faces look like in |
| 77 | ;; the menu itself. |
| 78 | ;; |
| 79 | ;; `list-faces-display' shows the faces in a different order than |
| 80 | ;; this menu, which could be confusing. I do /not/ sort the list |
| 81 | ;; alphabetically, because I like the default order: it puts the most |
| 82 | ;; basic, common fonts first. |
| 83 | ;; |
| 84 | ;; Please send me any other problems, comments or ideas. |
| 85 | |
| 86 | ;;; Code: |
| 87 | |
| 88 | (eval-when-compile |
| 89 | (require 'help) |
| 90 | (require 'button)) |
| 91 | |
| 92 | ;; Global bindings: |
| 93 | (define-key global-map [C-down-mouse-2] 'facemenu-menu) |
| 94 | (define-key global-map "\M-o" 'facemenu-keymap) |
| 95 | |
| 96 | (defgroup facemenu nil |
| 97 | "Create a face menu for interactively adding fonts to text." |
| 98 | :group 'faces |
| 99 | :prefix "facemenu-") |
| 100 | |
| 101 | (defcustom facemenu-keybindings |
| 102 | (mapcar 'purecopy |
| 103 | '((default . "d") |
| 104 | (bold . "b") |
| 105 | (italic . "i") |
| 106 | (bold-italic . "l") ; {bold} intersect {italic} = {l} |
| 107 | (underline . "u"))) |
| 108 | "Alist of interesting faces and keybindings. |
| 109 | Each element is itself a list: the car is the name of the face, |
| 110 | the next element is the key to use as a keyboard equivalent of the menu item; |
| 111 | the binding is made in `facemenu-keymap'. |
| 112 | |
| 113 | The faces specifically mentioned in this list are put at the top of |
| 114 | the menu, in the order specified. All other faces which are defined |
| 115 | in `facemenu-listed-faces' are listed after them, but get no |
| 116 | keyboard equivalents. |
| 117 | |
| 118 | If you change this variable after loading facemenu.el, you will need to call |
| 119 | `facemenu-update' to make it take effect." |
| 120 | :type '(repeat (cons face string)) |
| 121 | :group 'facemenu) |
| 122 | |
| 123 | (defcustom facemenu-new-faces-at-end t |
| 124 | "Where in the menu to insert newly-created faces. |
| 125 | This should be nil to put them at the top of the menu, or t to put them |
| 126 | just before \"Other\" at the end." |
| 127 | :type 'boolean |
| 128 | :group 'facemenu) |
| 129 | |
| 130 | (defcustom facemenu-listed-faces nil |
| 131 | "List of faces to include in the Face menu. |
| 132 | Each element should be a symbol, the name of a face. |
| 133 | The \"basic \" faces in `facemenu-keybindings' are automatically |
| 134 | added to the Face menu, and need not be in this list. |
| 135 | |
| 136 | This value takes effect when you load facemenu.el. If the |
| 137 | list includes symbols which are not defined as faces, they |
| 138 | are ignored; however, subsequently defining or creating |
| 139 | those faces adds them to the menu then. You can call |
| 140 | `facemenu-update' to recalculate the menu contents, such as |
| 141 | if you change the value of this variable, |
| 142 | |
| 143 | If this variable is t, all faces that you apply to text |
| 144 | using the face menu commands (even by name), and all faces |
| 145 | that you define or create, are added to the menu. You may |
| 146 | find it useful to set this variable to t temporarily while |
| 147 | you define some faces, so that they will be added. However, |
| 148 | if the value is no longer t and you call `facemenu-update', |
| 149 | it will remove any faces not explicitly in the list." |
| 150 | :type '(choice (const :tag "List all faces" t) |
| 151 | (const :tag "None" nil) |
| 152 | (repeat symbol)) |
| 153 | :group 'facemenu |
| 154 | :version "22.1") |
| 155 | |
| 156 | (defvar facemenu-face-menu |
| 157 | (let ((map (make-sparse-keymap "Face"))) |
| 158 | (define-key map "o" (cons (purecopy "Other...") 'facemenu-set-face)) |
| 159 | map) |
| 160 | "Menu keymap for faces.") |
| 161 | (defalias 'facemenu-face-menu facemenu-face-menu) |
| 162 | (put 'facemenu-face-menu 'menu-enable '(facemenu-enable-faces-p)) |
| 163 | |
| 164 | (defvar facemenu-foreground-menu |
| 165 | (let ((map (make-sparse-keymap "Foreground Color"))) |
| 166 | (define-key map "o" (cons (purecopy "Other...") 'facemenu-set-foreground)) |
| 167 | map) |
| 168 | "Menu keymap for foreground colors.") |
| 169 | (defalias 'facemenu-foreground-menu facemenu-foreground-menu) |
| 170 | (put 'facemenu-foreground-menu 'menu-enable '(facemenu-enable-faces-p)) |
| 171 | |
| 172 | (defvar facemenu-background-menu |
| 173 | (let ((map (make-sparse-keymap "Background Color"))) |
| 174 | (define-key map "o" (cons (purecopy "Other...") 'facemenu-set-background)) |
| 175 | map) |
| 176 | "Menu keymap for background colors.") |
| 177 | (defalias 'facemenu-background-menu facemenu-background-menu) |
| 178 | (put 'facemenu-background-menu 'menu-enable '(facemenu-enable-faces-p)) |
| 179 | |
| 180 | ;;; Condition for enabling menu items that set faces. |
| 181 | (defun facemenu-enable-faces-p () |
| 182 | ;; Enable the facemenu if facemenu-add-face-function is defined |
| 183 | ;; (e.g. in Tex-mode and SGML mode), or if font-lock is off. |
| 184 | (or (not (and font-lock-mode font-lock-defaults)) |
| 185 | facemenu-add-face-function)) |
| 186 | |
| 187 | (defvar facemenu-special-menu |
| 188 | (let ((map (make-sparse-keymap "Special"))) |
| 189 | (define-key map [?s] (cons (purecopy "Remove Special") |
| 190 | 'facemenu-remove-special)) |
| 191 | (define-key map [?t] (cons (purecopy "Intangible") |
| 192 | 'facemenu-set-intangible)) |
| 193 | (define-key map [?v] (cons (purecopy "Invisible") |
| 194 | 'facemenu-set-invisible)) |
| 195 | (define-key map [?r] (cons (purecopy "Read-Only") |
| 196 | 'facemenu-set-read-only)) |
| 197 | map) |
| 198 | "Menu keymap for non-face text-properties.") |
| 199 | (defalias 'facemenu-special-menu facemenu-special-menu) |
| 200 | |
| 201 | (defvar facemenu-justification-menu |
| 202 | (let ((map (make-sparse-keymap "Justification"))) |
| 203 | (define-key map [?c] (cons (purecopy "Center") 'set-justification-center)) |
| 204 | (define-key map [?b] (cons (purecopy "Full") 'set-justification-full)) |
| 205 | (define-key map [?r] (cons (purecopy "Right") 'set-justification-right)) |
| 206 | (define-key map [?l] (cons (purecopy "Left") 'set-justification-left)) |
| 207 | (define-key map [?u] (cons (purecopy "Unfilled") 'set-justification-none)) |
| 208 | map) |
| 209 | "Submenu for text justification commands.") |
| 210 | (defalias 'facemenu-justification-menu facemenu-justification-menu) |
| 211 | |
| 212 | (defvar facemenu-indentation-menu |
| 213 | (let ((map (make-sparse-keymap "Indentation"))) |
| 214 | (define-key map [decrease-right-margin] |
| 215 | (cons (purecopy "Indent Right Less") 'decrease-right-margin)) |
| 216 | (define-key map [increase-right-margin] |
| 217 | (cons (purecopy "Indent Right More") 'increase-right-margin)) |
| 218 | (define-key map [decrease-left-margin] |
| 219 | (cons (purecopy "Indent Less") 'decrease-left-margin)) |
| 220 | (define-key map [increase-left-margin] |
| 221 | (cons (purecopy "Indent More") 'increase-left-margin)) |
| 222 | map) |
| 223 | "Submenu for indentation commands.") |
| 224 | (defalias 'facemenu-indentation-menu facemenu-indentation-menu) |
| 225 | |
| 226 | ;; This is split up to avoid an overlong line in loaddefs.el. |
| 227 | (defvar facemenu-menu nil |
| 228 | "Facemenu top-level menu keymap.") |
| 229 | (setq facemenu-menu (make-sparse-keymap "Text Properties")) |
| 230 | (let ((map facemenu-menu)) |
| 231 | (define-key map [dc] (cons (purecopy "Display Colors") 'list-colors-display)) |
| 232 | (define-key map [df] (cons (purecopy "Display Faces") 'list-faces-display)) |
| 233 | (define-key map [dp] (cons (purecopy "Describe Properties") |
| 234 | 'describe-text-properties)) |
| 235 | (define-key map [ra] (list 'menu-item (purecopy "Remove Text Properties") |
| 236 | 'facemenu-remove-all |
| 237 | :enable 'mark-active)) |
| 238 | (define-key map [rm] (list 'menu-item (purecopy "Remove Face Properties") |
| 239 | 'facemenu-remove-face-props |
| 240 | :enable 'mark-active)) |
| 241 | (define-key map [s1] (list (purecopy "--")))) |
| 242 | (let ((map facemenu-menu)) |
| 243 | (define-key map [in] (cons (purecopy "Indentation") |
| 244 | 'facemenu-indentation-menu)) |
| 245 | (define-key map [ju] (cons (purecopy "Justification") |
| 246 | 'facemenu-justification-menu)) |
| 247 | (define-key map [s2] (list (purecopy "--"))) |
| 248 | (define-key map [sp] (cons (purecopy "Special Properties") |
| 249 | 'facemenu-special-menu)) |
| 250 | (define-key map [bg] (cons (purecopy "Background Color") |
| 251 | 'facemenu-background-menu)) |
| 252 | (define-key map [fg] (cons (purecopy "Foreground Color") |
| 253 | 'facemenu-foreground-menu)) |
| 254 | (define-key map [fc] (cons (purecopy "Face") |
| 255 | 'facemenu-face-menu))) |
| 256 | (defalias 'facemenu-menu facemenu-menu) |
| 257 | |
| 258 | (defvar facemenu-keymap |
| 259 | (let ((map (make-sparse-keymap "Set face"))) |
| 260 | (define-key map "o" (cons (purecopy "Other...") 'facemenu-set-face)) |
| 261 | (define-key map "\M-o" 'font-lock-fontify-block) |
| 262 | map) |
| 263 | "Keymap for face-changing commands. |
| 264 | `Facemenu-update' fills in the keymap according to the bindings |
| 265 | requested in `facemenu-keybindings'.") |
| 266 | (defalias 'facemenu-keymap facemenu-keymap) |
| 267 | |
| 268 | |
| 269 | (defcustom facemenu-add-face-function nil |
| 270 | "Function called at beginning of text to change or nil. |
| 271 | This function is passed the FACE to set and END of text to change, and must |
| 272 | return a string which is inserted. It may set `facemenu-end-add-face'." |
| 273 | :type '(choice (const :tag "None" nil) |
| 274 | function) |
| 275 | :group 'facemenu) |
| 276 | |
| 277 | (defcustom facemenu-end-add-face nil |
| 278 | "String to insert or function called at end of text to change or nil. |
| 279 | This function is passed the FACE to set, and must return a string which is |
| 280 | inserted." |
| 281 | :type '(choice (const :tag "None" nil) |
| 282 | string |
| 283 | function) |
| 284 | :group 'facemenu) |
| 285 | |
| 286 | (defcustom facemenu-remove-face-function nil |
| 287 | "When non-nil, this is a function called to remove faces. |
| 288 | This function is passed the START and END of text to change. |
| 289 | May also be t meaning to use `facemenu-add-face-function'." |
| 290 | :type '(choice (const :tag "None" nil) |
| 291 | (const :tag "Use add-face" t) |
| 292 | function) |
| 293 | :group 'facemenu) |
| 294 | |
| 295 | ;;; Internal Variables |
| 296 | |
| 297 | (defvar facemenu-color-alist nil |
| 298 | "Alist of colors, used for completion. |
| 299 | If this is nil, then the value of (defined-colors) is used.") |
| 300 | |
| 301 | (defun facemenu-update () |
| 302 | "Add or update the \"Face\" menu in the menu bar. |
| 303 | You can call this to update things if you change any of the menu configuration |
| 304 | variables." |
| 305 | (interactive) |
| 306 | |
| 307 | ;; Add each defined face to the menu. |
| 308 | (facemenu-iterate 'facemenu-add-new-face |
| 309 | (facemenu-complete-face-list facemenu-keybindings))) |
| 310 | |
| 311 | (defun facemenu-set-face (face &optional start end) |
| 312 | "Apply FACE to the region or next character typed. |
| 313 | |
| 314 | If the region is active (normally true except in Transient |
| 315 | Mark mode) and nonempty, and there is no prefix argument, |
| 316 | this command applies FACE to the region. Otherwise, it applies FACE |
| 317 | to the faces to use for the next character |
| 318 | inserted. (Moving point or switching buffers before typing |
| 319 | a character to insert cancels the specification.) |
| 320 | |
| 321 | If FACE is `default', to \"apply\" it means clearing |
| 322 | the list of faces to be used. For any other value of FACE, |
| 323 | to \"apply\" it means putting FACE at the front of the list |
| 324 | of faces to be used, and removing any faces further |
| 325 | along in the list that would be completely overridden by |
| 326 | preceding faces (including FACE). |
| 327 | |
| 328 | This command can also add FACE to the menu of faces, |
| 329 | if `facemenu-listed-faces' says to do that." |
| 330 | (interactive (list (progn |
| 331 | (barf-if-buffer-read-only) |
| 332 | (read-face-name "Use face" (face-at-point t))) |
| 333 | (if (and mark-active (not current-prefix-arg)) |
| 334 | (region-beginning)) |
| 335 | (if (and mark-active (not current-prefix-arg)) |
| 336 | (region-end)))) |
| 337 | (facemenu-add-new-face face) |
| 338 | (facemenu-add-face face start end)) |
| 339 | |
| 340 | (defun facemenu-set-foreground (color &optional start end) |
| 341 | "Set the foreground COLOR of the region or next character typed. |
| 342 | This command reads the color in the minibuffer. |
| 343 | |
| 344 | If the region is active (normally true except in Transient Mark mode) |
| 345 | and there is no prefix argument, this command sets the region to the |
| 346 | requested face. |
| 347 | |
| 348 | Otherwise, this command specifies the face for the next character |
| 349 | inserted. Moving point or switching buffers before |
| 350 | typing a character to insert cancels the specification." |
| 351 | (interactive (list (progn |
| 352 | (barf-if-buffer-read-only) |
| 353 | (read-color "Foreground color: ")) |
| 354 | (if (and mark-active (not current-prefix-arg)) |
| 355 | (region-beginning)) |
| 356 | (if (and mark-active (not current-prefix-arg)) |
| 357 | (region-end)))) |
| 358 | (facemenu-set-face-from-menu |
| 359 | (facemenu-add-new-color color 'facemenu-foreground-menu) |
| 360 | start end)) |
| 361 | |
| 362 | (defun facemenu-set-background (color &optional start end) |
| 363 | "Set the background COLOR of the region or next character typed. |
| 364 | This command reads the color in the minibuffer. |
| 365 | |
| 366 | If the region is active (normally true except in Transient Mark mode) |
| 367 | and there is no prefix argument, this command sets the region to the |
| 368 | requested face. |
| 369 | |
| 370 | Otherwise, this command specifies the face for the next character |
| 371 | inserted. Moving point or switching buffers before |
| 372 | typing a character to insert cancels the specification." |
| 373 | (interactive (list (progn |
| 374 | (barf-if-buffer-read-only) |
| 375 | (read-color "Background color: ")) |
| 376 | (if (and mark-active (not current-prefix-arg)) |
| 377 | (region-beginning)) |
| 378 | (if (and mark-active (not current-prefix-arg)) |
| 379 | (region-end)))) |
| 380 | (facemenu-set-face-from-menu |
| 381 | (facemenu-add-new-color color 'facemenu-background-menu) |
| 382 | start end)) |
| 383 | |
| 384 | (defun facemenu-set-face-from-menu (face start end) |
| 385 | "Set the FACE of the region or next character typed. |
| 386 | This function is designed to be called from a menu; FACE is determined |
| 387 | using the event type of the menu entry. If FACE is a symbol whose |
| 388 | name starts with \"fg:\" or \"bg:\", then this functions sets the |
| 389 | foreground or background to the color specified by the rest of the |
| 390 | symbol's name. Any other symbol is considered the name of a face. |
| 391 | |
| 392 | If the region is active (normally true except in Transient Mark mode) |
| 393 | and there is no prefix argument, this command sets the region to the |
| 394 | requested face. |
| 395 | |
| 396 | Otherwise, this command specifies the face for the next character |
| 397 | inserted. Moving point or switching buffers before typing a character |
| 398 | to insert cancels the specification." |
| 399 | (interactive (list last-command-event |
| 400 | (if (and mark-active (not current-prefix-arg)) |
| 401 | (region-beginning)) |
| 402 | (if (and mark-active (not current-prefix-arg)) |
| 403 | (region-end)))) |
| 404 | (barf-if-buffer-read-only) |
| 405 | (facemenu-add-face |
| 406 | (let ((fn (symbol-name face))) |
| 407 | (if (string-match "\\`\\([fb]\\)g:\\(.+\\)" fn) |
| 408 | (list (list (if (string= (match-string 1 fn) "f") |
| 409 | :foreground |
| 410 | :background) |
| 411 | (match-string 2 fn))) |
| 412 | face)) |
| 413 | start end)) |
| 414 | |
| 415 | (defun facemenu-set-invisible (start end) |
| 416 | "Make the region invisible. |
| 417 | This sets the `invisible' text property; it can be undone with |
| 418 | `facemenu-remove-special'." |
| 419 | (interactive "r") |
| 420 | (add-text-properties start end '(invisible t))) |
| 421 | |
| 422 | (defun facemenu-set-intangible (start end) |
| 423 | "Make the region intangible: disallow moving into it. |
| 424 | This sets the `intangible' text property; it can be undone with |
| 425 | `facemenu-remove-special'." |
| 426 | (interactive "r") |
| 427 | (add-text-properties start end '(intangible t))) |
| 428 | |
| 429 | (defun facemenu-set-read-only (start end) |
| 430 | "Make the region unmodifiable. |
| 431 | This sets the `read-only' text property; it can be undone with |
| 432 | `facemenu-remove-special'." |
| 433 | (interactive "r") |
| 434 | (add-text-properties start end '(read-only t))) |
| 435 | |
| 436 | (defun facemenu-remove-face-props (start end) |
| 437 | "Remove `face' and `mouse-face' text properties." |
| 438 | (interactive "*r") ; error if buffer is read-only despite the next line. |
| 439 | (let ((inhibit-read-only t)) |
| 440 | (remove-text-properties |
| 441 | start end '(face nil mouse-face nil)))) |
| 442 | |
| 443 | (defun facemenu-remove-all (start end) |
| 444 | "Remove all text properties from the region." |
| 445 | (interactive "*r") ; error if buffer is read-only despite the next line. |
| 446 | (let ((inhibit-read-only t)) |
| 447 | (set-text-properties start end nil))) |
| 448 | |
| 449 | (defun facemenu-remove-special (start end) |
| 450 | "Remove all the \"special\" text properties from the region. |
| 451 | These special properties include `invisible', `intangible' and `read-only'." |
| 452 | (interactive "*r") ; error if buffer is read-only despite the next line. |
| 453 | (let ((inhibit-read-only t)) |
| 454 | (remove-text-properties |
| 455 | start end '(invisible nil intangible nil read-only nil)))) |
| 456 | \f |
| 457 | (defalias 'facemenu-read-color 'read-color) |
| 458 | |
| 459 | (defcustom list-colors-sort nil |
| 460 | "Color sort order for `list-colors-display'. |
| 461 | `nil' means default implementation-dependent order (defined in `x-colors'). |
| 462 | `name' sorts by color name. |
| 463 | `rgb' sorts by red, green, blue components. |
| 464 | `(rgb-dist . COLOR)' sorts by the RGB distance to the specified color. |
| 465 | `hsv' sorts by hue, saturation, value. |
| 466 | `(hsv-dist . COLOR)' sorts by the HSV distance to the specified color |
| 467 | and excludes grayscale colors. |
| 468 | `luminance' sorts by relative luminance in the CIE XYZ color space." |
| 469 | :type '(choice (const :tag "Unsorted" nil) |
| 470 | (const :tag "Color Name" name) |
| 471 | (const :tag "Red-Green-Blue" rgb) |
| 472 | (cons :tag "Distance on RGB cube" |
| 473 | (const :tag "Distance from Color" rgb-dist) |
| 474 | (color :tag "Source Color Name")) |
| 475 | (const :tag "Hue-Saturation-Value" hsv) |
| 476 | (cons :tag "Distance on HSV cylinder" |
| 477 | (const :tag "Distance from Color" hsv-dist) |
| 478 | (color :tag "Source Color Name")) |
| 479 | (const :tag "Luminance" luminance)) |
| 480 | :group 'facemenu |
| 481 | :version "24.1") |
| 482 | |
| 483 | (defun list-colors-sort-key (color) |
| 484 | "Return a list of keys for sorting colors depending on `list-colors-sort'. |
| 485 | COLOR is the name of the color. When return value is nil, |
| 486 | filter out the color from the output." |
| 487 | (require 'color) |
| 488 | (cond |
| 489 | ((null list-colors-sort) color) |
| 490 | ((eq list-colors-sort 'name) |
| 491 | (downcase color)) |
| 492 | ((eq list-colors-sort 'rgb) |
| 493 | (color-values color)) |
| 494 | ((eq (car-safe list-colors-sort) 'rgb-dist) |
| 495 | (color-distance color (cdr list-colors-sort))) |
| 496 | ((eq list-colors-sort 'hsv) |
| 497 | (apply 'color-rgb-to-hsv (color-name-to-rgb color))) |
| 498 | ((eq (car-safe list-colors-sort) 'hsv-dist) |
| 499 | (let* ((c-rgb (color-name-to-rgb color)) |
| 500 | (c-hsv (apply 'color-rgb-to-hsv c-rgb)) |
| 501 | (o-hsv (apply 'color-rgb-to-hsv |
| 502 | (color-name-to-rgb (cdr list-colors-sort))))) |
| 503 | (unless (and (eq (nth 0 c-rgb) (nth 1 c-rgb)) ; exclude grayscale |
| 504 | (eq (nth 1 c-rgb) (nth 2 c-rgb))) |
| 505 | ;; 3D Euclidean distance (sqrt is not needed for sorting) |
| 506 | (+ (expt (- 180 (abs (- 180 (abs (- (nth 0 c-hsv) ; wrap hue |
| 507 | (nth 0 o-hsv)))))) 2) |
| 508 | (expt (- (nth 1 c-hsv) (nth 1 o-hsv)) 2) |
| 509 | (expt (- (nth 2 c-hsv) (nth 2 o-hsv)) 2))))) |
| 510 | ((eq list-colors-sort 'luminance) |
| 511 | (let ((c-rgb (color-name-to-rgb color))) |
| 512 | (+ (* (nth 0 c-rgb) 0.21266729) |
| 513 | (* (nth 1 c-rgb) 0.7151522) |
| 514 | (* (nth 2 c-rgb) 0.0721750)))))) |
| 515 | |
| 516 | (defvar list-colors-callback nil |
| 517 | "Value of CALLBACK arg passed to `list-colors-display'; internal use.") |
| 518 | |
| 519 | (defun list-colors-redisplay (_ignore-auto _noconfirm) |
| 520 | "Redisplay the colors using `list-colors-sort'. |
| 521 | |
| 522 | This is installed as a `revert-buffer-function' in the *Colors* buffer." |
| 523 | (list-colors-display nil (buffer-name) list-colors-callback)) |
| 524 | |
| 525 | (defun list-colors-display (&optional list buffer-name callback) |
| 526 | "Display names of defined colors, and show what they look like. |
| 527 | If the optional argument LIST is non-nil, it should be a list of |
| 528 | colors to display. Otherwise, this command computes a list of |
| 529 | colors that the current display can handle. Customize |
| 530 | `list-colors-sort' to change the order in which colors are shown. |
| 531 | Type `g' or \\[revert-buffer] after customizing `list-colors-sort' |
| 532 | to redisplay colors in the new order. |
| 533 | |
| 534 | If the optional argument BUFFER-NAME is nil, it defaults to *Colors*. |
| 535 | |
| 536 | If the optional argument CALLBACK is non-nil, it should be a |
| 537 | function to call each time the user types RET or clicks on a |
| 538 | color. The function should accept a single argument, the color name." |
| 539 | (interactive) |
| 540 | (when (and (null list) (> (display-color-cells) 0)) |
| 541 | (setq list (list-colors-duplicates (defined-colors))) |
| 542 | (when list-colors-sort |
| 543 | ;; Schwartzian transform with `(color key1 key2 key3 ...)'. |
| 544 | (setq list (mapcar |
| 545 | 'car |
| 546 | (sort (delq nil (mapcar |
| 547 | (lambda (c) |
| 548 | (let ((key (list-colors-sort-key |
| 549 | (car c)))) |
| 550 | (when key |
| 551 | (cons c (if (consp key) key |
| 552 | (list key)))))) |
| 553 | list)) |
| 554 | (lambda (a b) |
| 555 | (let* ((a-keys (cdr a)) |
| 556 | (b-keys (cdr b)) |
| 557 | (a-key (car a-keys)) |
| 558 | (b-key (car b-keys))) |
| 559 | ;; Skip common keys at the beginning of key lists. |
| 560 | (while (and a-key b-key (equal a-key b-key)) |
| 561 | (setq a-keys (cdr a-keys) a-key (car a-keys) |
| 562 | b-keys (cdr b-keys) b-key (car b-keys))) |
| 563 | (cond |
| 564 | ((and (numberp a-key) (numberp b-key)) |
| 565 | (< a-key b-key)) |
| 566 | ((and (stringp a-key) (stringp b-key)) |
| 567 | (string< a-key b-key))))))))) |
| 568 | (when (memq (display-visual-class) '(gray-scale pseudo-color direct-color)) |
| 569 | ;; Don't show more than what the display can handle. |
| 570 | (let ((lc (nthcdr (1- (display-color-cells)) list))) |
| 571 | (if lc |
| 572 | (setcdr lc nil))))) |
| 573 | (unless buffer-name |
| 574 | (setq buffer-name "*Colors*")) |
| 575 | (with-help-window buffer-name |
| 576 | (with-current-buffer standard-output |
| 577 | (erase-buffer) |
| 578 | (list-colors-print list callback) |
| 579 | (set-buffer-modified-p nil) |
| 580 | (setq truncate-lines t) |
| 581 | (setq-local list-colors-callback callback) |
| 582 | (setq revert-buffer-function 'list-colors-redisplay))) |
| 583 | (when callback |
| 584 | (pop-to-buffer buffer-name) |
| 585 | (message "Click on a color to select it."))) |
| 586 | |
| 587 | (defun list-colors-print (list &optional callback) |
| 588 | (let ((callback-fn |
| 589 | (if callback |
| 590 | `(lambda (button) |
| 591 | (funcall ,callback (button-get button 'color-name)))))) |
| 592 | (dolist (color list) |
| 593 | (if (consp color) |
| 594 | (if (cdr color) |
| 595 | (setq color (sort color (lambda (a b) |
| 596 | (string< (downcase a) |
| 597 | (downcase b)))))) |
| 598 | (setq color (list color))) |
| 599 | (let* ((opoint (point)) |
| 600 | (color-values (color-values (car color))) |
| 601 | (light-p (>= (apply 'max color-values) |
| 602 | (* (car (color-values "white")) .5)))) |
| 603 | (insert (car color)) |
| 604 | (indent-to 22) |
| 605 | (put-text-property opoint (point) 'face `(:background ,(car color))) |
| 606 | (put-text-property |
| 607 | (prog1 (point) |
| 608 | (insert " ") |
| 609 | ;; Insert all color names. |
| 610 | (insert (mapconcat 'identity color ","))) |
| 611 | (point) |
| 612 | 'face (list :foreground (car color))) |
| 613 | (insert (propertize " " 'display '(space :align-to (- right 9)))) |
| 614 | (insert " ") |
| 615 | (insert (propertize |
| 616 | (apply 'format "#%02x%02x%02x" |
| 617 | (mapcar (lambda (c) (lsh c -8)) |
| 618 | color-values)) |
| 619 | 'mouse-face 'highlight |
| 620 | 'help-echo |
| 621 | (let ((hsv (apply 'color-rgb-to-hsv |
| 622 | (color-name-to-rgb (car color))))) |
| 623 | (format "H:%d S:%d V:%d" |
| 624 | (nth 0 hsv) (nth 1 hsv) (nth 2 hsv))))) |
| 625 | (when callback |
| 626 | (make-text-button |
| 627 | opoint (point) |
| 628 | 'follow-link t |
| 629 | 'mouse-face (list :background (car color) |
| 630 | :foreground (if light-p "black" "white")) |
| 631 | 'color-name (car color) |
| 632 | 'action callback-fn))) |
| 633 | (insert "\n")) |
| 634 | (goto-char (point-min)))) |
| 635 | |
| 636 | |
| 637 | (defun list-colors-duplicates (&optional list) |
| 638 | "Return a list of colors with grouped duplicate colors. |
| 639 | If a color has no duplicates, then the element of the returned list |
| 640 | has the form '(COLOR-NAME). The element of the returned list with |
| 641 | duplicate colors has the form '(COLOR-NAME DUPLICATE-COLOR-NAME ...). |
| 642 | This function uses the predicate `facemenu-color-equal' to compare |
| 643 | color names. If the optional argument LIST is non-nil, it should |
| 644 | be a list of colors to display. Otherwise, this function uses |
| 645 | a list of colors that the current display can handle." |
| 646 | (let* ((list (mapcar 'list (or list (defined-colors)))) |
| 647 | (l list)) |
| 648 | (while (cdr l) |
| 649 | (if (and (facemenu-color-equal (car (car l)) (car (car (cdr l)))) |
| 650 | ;; On MS-Windows, there are logical colors that might have |
| 651 | ;; the same value but different names and meanings. For |
| 652 | ;; example, `SystemMenuText' (the color w32 uses for the |
| 653 | ;; text in menu entries) and `SystemWindowText' (the default |
| 654 | ;; color w32 uses for the text in windows and dialogs) may |
| 655 | ;; be the same display color and be adjacent in the list. |
| 656 | ;; These system colors all have names prefixed with "System", |
| 657 | ;; which is hardcoded in w32fns.c (SYSTEM_COLOR_PREFIX). |
| 658 | ;; This makes them different to any other color. Bug#9722 |
| 659 | (not (and (eq system-type 'windows-nt) |
| 660 | (string-match-p "^System" (car (car l)))))) |
| 661 | (progn |
| 662 | (setcdr (car l) (cons (car (car (cdr l))) (cdr (car l)))) |
| 663 | (setcdr l (cdr (cdr l)))) |
| 664 | (setq l (cdr l)))) |
| 665 | list)) |
| 666 | |
| 667 | (defun facemenu-color-equal (a b) |
| 668 | "Return t if colors A and B are the same color. |
| 669 | A and B should be strings naming colors. |
| 670 | This function queries the display system to find out what the color |
| 671 | names mean. It returns nil if the colors differ or if it can't |
| 672 | determine the correct answer." |
| 673 | (cond ((equal a b) t) |
| 674 | ((equal (color-values a) (color-values b))))) |
| 675 | |
| 676 | |
| 677 | (defvar facemenu-self-insert-data nil) |
| 678 | |
| 679 | (defun facemenu-post-self-insert-function () |
| 680 | (when (and (car facemenu-self-insert-data) |
| 681 | (eq last-command (cdr facemenu-self-insert-data))) |
| 682 | (put-text-property (1- (point)) (point) |
| 683 | 'face (car facemenu-self-insert-data)) |
| 684 | (setq facemenu-self-insert-data nil)) |
| 685 | (remove-hook 'post-self-insert-hook 'facemenu-post-self-insert-function)) |
| 686 | |
| 687 | (defun facemenu-set-self-insert-face (face) |
| 688 | "Arrange for the next self-inserted char to have face `face'." |
| 689 | (setq facemenu-self-insert-data (cons face this-command)) |
| 690 | (add-hook 'post-self-insert-hook 'facemenu-post-self-insert-function)) |
| 691 | |
| 692 | (defun facemenu-add-face (face &optional start end) |
| 693 | "Add FACE to text between START and END. |
| 694 | If START is nil or START to END is empty, add FACE to next typed character |
| 695 | instead. For each section of that region that has a different face property, |
| 696 | FACE will be consed onto it, and other faces that are completely hidden by |
| 697 | that will be removed from the list. |
| 698 | If `facemenu-add-face-function' and maybe `facemenu-end-add-face' are non-nil, |
| 699 | they are used to set the face information. |
| 700 | |
| 701 | As a special case, if FACE is `default', then the region is left with NO face |
| 702 | text property. Otherwise, selecting the default face would not have any |
| 703 | effect. See `facemenu-remove-face-function'." |
| 704 | (interactive "*xFace: \nr") |
| 705 | (cond |
| 706 | ((and (eq face 'default) |
| 707 | (not (eq facemenu-remove-face-function t))) |
| 708 | (if facemenu-remove-face-function |
| 709 | (funcall facemenu-remove-face-function start end) |
| 710 | (if (and start (< start end)) |
| 711 | (remove-text-properties start end '(face default)) |
| 712 | (facemenu-set-self-insert-face 'default)))) |
| 713 | (facemenu-add-face-function |
| 714 | (save-excursion |
| 715 | (if end (goto-char end)) |
| 716 | (save-excursion |
| 717 | (if start (goto-char start)) |
| 718 | (insert-before-markers |
| 719 | (funcall facemenu-add-face-function face end))) |
| 720 | (if facemenu-end-add-face |
| 721 | (insert (if (stringp facemenu-end-add-face) |
| 722 | facemenu-end-add-face |
| 723 | (funcall facemenu-end-add-face face)))))) |
| 724 | ((and start (< start end)) |
| 725 | (let ((part-start start) part-end) |
| 726 | (while (not (= part-start end)) |
| 727 | (setq part-end (next-single-property-change part-start 'face |
| 728 | nil end)) |
| 729 | (let ((prev (get-text-property part-start 'face))) |
| 730 | (put-text-property part-start part-end 'face |
| 731 | (if (null prev) |
| 732 | face |
| 733 | (facemenu-active-faces |
| 734 | (cons face |
| 735 | (if (listp prev) |
| 736 | prev |
| 737 | (list prev))) |
| 738 | ;; Specify the selected frame |
| 739 | ;; because nil would mean to use |
| 740 | ;; the new-frame default settings, |
| 741 | ;; and those are usually nil. |
| 742 | (selected-frame))))) |
| 743 | (setq part-start part-end)))) |
| 744 | (t |
| 745 | (facemenu-set-self-insert-face |
| 746 | (if (eq last-command (cdr facemenu-self-insert-data)) |
| 747 | (cons face (if (listp (car facemenu-self-insert-data)) |
| 748 | (car facemenu-self-insert-data) |
| 749 | (list (car facemenu-self-insert-data)))) |
| 750 | face)))) |
| 751 | (unless (facemenu-enable-faces-p) |
| 752 | (message "Font-lock mode will override any faces you set in this buffer"))) |
| 753 | |
| 754 | (defun facemenu-active-faces (face-list &optional frame) |
| 755 | "Return from FACE-LIST those faces that would be used for display. |
| 756 | This means each face attribute is not specified in a face earlier in FACE-LIST |
| 757 | and such a face is therefore active when used to display text. |
| 758 | If the optional argument FRAME is given, use the faces in that frame; otherwise |
| 759 | use the selected frame. If t, then the global, non-frame faces are used." |
| 760 | (let* ((mask-atts (copy-sequence |
| 761 | (if (consp (car face-list)) |
| 762 | (face-attributes-as-vector (car face-list)) |
| 763 | (or (internal-lisp-face-p (car face-list) frame) |
| 764 | (check-face (car face-list)))))) |
| 765 | (active-list (list (car face-list))) |
| 766 | (face-list (cdr face-list)) |
| 767 | (mask-len (length mask-atts))) |
| 768 | (while face-list |
| 769 | (if (let ((face-atts |
| 770 | (if (consp (car face-list)) |
| 771 | (face-attributes-as-vector (car face-list)) |
| 772 | (or (internal-lisp-face-p (car face-list) frame) |
| 773 | (check-face (car face-list))))) |
| 774 | (i mask-len) |
| 775 | (useful nil)) |
| 776 | (while (>= (setq i (1- i)) 0) |
| 777 | (and (not (memq (aref face-atts i) '(nil unspecified))) |
| 778 | (memq (aref mask-atts i) '(nil unspecified)) |
| 779 | (aset mask-atts i (setq useful t)))) |
| 780 | useful) |
| 781 | (setq active-list (cons (car face-list) active-list))) |
| 782 | (setq face-list (cdr face-list))) |
| 783 | (nreverse active-list))) |
| 784 | |
| 785 | (defun facemenu-add-new-face (face) |
| 786 | "Add FACE (a face) to the Face menu if `facemenu-listed-faces' says so. |
| 787 | This is called whenever you create a new face, and at other times." |
| 788 | (let* (name |
| 789 | symbol |
| 790 | menu docstring |
| 791 | (key (cdr (assoc face facemenu-keybindings))) |
| 792 | function menu-val) |
| 793 | (if (symbolp face) |
| 794 | (setq name (symbol-name face) |
| 795 | symbol face) |
| 796 | (setq name face |
| 797 | symbol (intern name))) |
| 798 | (setq menu 'facemenu-face-menu) |
| 799 | (setq docstring |
| 800 | (purecopy (format "Select face `%s' for subsequent insertion. |
| 801 | If the mark is active and there is no prefix argument, |
| 802 | apply face `%s' to the region instead. |
| 803 | This command was defined by `facemenu-add-new-face'." |
| 804 | name name))) |
| 805 | (cond ((facemenu-iterate ; check if equivalent face is already in the menu |
| 806 | (lambda (m) (and (listp m) |
| 807 | (symbolp (car m)) |
| 808 | ;; Avoid error in face-equal |
| 809 | ;; when a non-face is erroneously present. |
| 810 | (facep (car m)) |
| 811 | (face-equal (car m) symbol))) |
| 812 | (cdr (symbol-function menu)))) |
| 813 | ;; Faces with a keyboard equivalent. These go at the front. |
| 814 | (key |
| 815 | (setq function (intern (concat "facemenu-set-" name))) |
| 816 | (fset function |
| 817 | `(lambda () |
| 818 | ,docstring |
| 819 | (interactive) |
| 820 | (facemenu-set-face |
| 821 | (quote ,symbol) |
| 822 | (if (and mark-active (not current-prefix-arg)) |
| 823 | (region-beginning)) |
| 824 | (if (and mark-active (not current-prefix-arg)) |
| 825 | (region-end))))) |
| 826 | (define-key 'facemenu-keymap key (cons name function)) |
| 827 | (define-key menu key (cons name function))) |
| 828 | ;; Faces with no keyboard equivalent. Figure out where to put it: |
| 829 | ((or (eq t facemenu-listed-faces) |
| 830 | (memq symbol facemenu-listed-faces)) |
| 831 | (setq key (vector symbol) |
| 832 | function 'facemenu-set-face-from-menu |
| 833 | menu-val (symbol-function menu)) |
| 834 | (if (and facemenu-new-faces-at-end |
| 835 | (> (length menu-val) 3)) |
| 836 | (define-key-after menu-val key (cons name function) |
| 837 | (car (nth (- (length menu-val) 3) menu-val))) |
| 838 | (define-key menu key (cons name function)))))) |
| 839 | nil) ; Return nil for facemenu-iterate |
| 840 | |
| 841 | (defun facemenu-add-new-color (color menu) |
| 842 | "Add COLOR (a color name string) to the appropriate Face menu. |
| 843 | MENU should be `facemenu-foreground-menu' or `facemenu-background-menu'. |
| 844 | Return the event type (a symbol) of the added menu entry. |
| 845 | |
| 846 | This is called whenever you use a new color." |
| 847 | (let (symbol) |
| 848 | (unless (color-defined-p color) |
| 849 | (error "Color `%s' undefined" color)) |
| 850 | (cond ((eq menu 'facemenu-foreground-menu) |
| 851 | (setq symbol (intern (concat "fg:" color)))) |
| 852 | ((eq menu 'facemenu-background-menu) |
| 853 | (setq symbol (intern (concat "bg:" color)))) |
| 854 | (t (error "MENU should be `facemenu-foreground-menu' or `facemenu-background-menu'"))) |
| 855 | (unless (facemenu-iterate ; Check if color is already in the menu. |
| 856 | (lambda (m) (and (listp m) |
| 857 | (eq (car m) symbol))) |
| 858 | (cdr (symbol-function menu))) |
| 859 | ;; Color is not in the menu. Figure out where to put it. |
| 860 | (let ((key (vector symbol)) |
| 861 | (function 'facemenu-set-face-from-menu) |
| 862 | (menu-val (symbol-function menu))) |
| 863 | (if (and facemenu-new-faces-at-end |
| 864 | (> (length menu-val) 3)) |
| 865 | (define-key-after menu-val key (cons color function) |
| 866 | (car (nth (- (length menu-val) 3) menu-val))) |
| 867 | (define-key menu key (cons color function))))) |
| 868 | symbol)) |
| 869 | |
| 870 | (defun facemenu-complete-face-list (&optional oldlist) |
| 871 | "Return list of all faces that look different. |
| 872 | Starts with given ALIST of faces, and adds elements only if they display |
| 873 | differently from any face already on the list. |
| 874 | The faces on ALIST will end up at the end of the returned list, in reverse |
| 875 | order." |
| 876 | (let ((list (nreverse (mapcar 'car oldlist)))) |
| 877 | (facemenu-iterate |
| 878 | (lambda (new-face) |
| 879 | (if (not (memq new-face list)) |
| 880 | (setq list (cons new-face list))) |
| 881 | nil) |
| 882 | (nreverse (face-list))) |
| 883 | list)) |
| 884 | |
| 885 | (defun facemenu-iterate (func list) |
| 886 | "Apply FUNC to each element of LIST until one returns non-nil. |
| 887 | Returns the non-nil value it found, or nil if all were nil." |
| 888 | (while (and list (not (funcall func (car list)))) |
| 889 | (setq list (cdr list))) |
| 890 | (car list)) |
| 891 | |
| 892 | (facemenu-update) |
| 893 | |
| 894 | (provide 'facemenu) |
| 895 | |
| 896 | ;;; facemenu.el ends here |