X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/f23d76bdefbd4c06e14d69e99e50d35ce91c8226..fea9cabd275c3d5809b824a6e4a1446441a6793e:/lisp/facemenu.el

diff --git a/lisp/facemenu.el b/lisp/facemenu.el
index 968a115c5d..20b86676ea 100644
--- a/lisp/facemenu.el
+++ b/lisp/facemenu.el
@@ -1,17 +1,17 @@
 ;;; facemenu.el --- create a face menu for interactively adding fonts to text
 
 ;; Copyright (C) 1994, 1995, 1996, 2001, 2002, 2003, 2004,
-;;   2005, 2006, 2007 Free Software Foundation, Inc.
+;;   2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
 
 ;; Author: Boris Goldowsky <boris@gnu.org>
 ;; Keywords: faces
 
 ;; This file is part of GNU Emacs.
 
-;; GNU Emacs is free software; you can redistribute it and/or modify
+;; GNU Emacs is free software: you can redistribute it and/or modify
 ;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 3, or (at your option)
-;; any later version.
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
 
 ;; GNU Emacs is distributed in the hope that it will be useful,
 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
@@ -19,9 +19,7 @@
 ;; GNU General Public License for more details.
 
 ;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING.  If not, write to the
-;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-;; Boston, MA 02110-1301, USA.
+;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
 
 ;;; Commentary:
 
@@ -91,10 +89,6 @@
   (require 'help)
   (require 'button))
 
-;;; Provide some binding for startup:
-;;;###autoload (define-key global-map "\M-o" 'facemenu-keymap)
-;;;###autoload (autoload 'facemenu-keymap "facemenu" "Keymap for face-changing commands." t 'keymap)
-
 ;; Global bindings:
 (define-key global-map [C-down-mouse-2] 'facemenu-menu)
 (define-key global-map "\M-o" 'facemenu-keymap)
@@ -105,11 +99,12 @@
   :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;
@@ -126,7 +121,7 @@ If you change this variable after loading facemenu.el, you will need to call
   :group 'facemenu)
 
 (defcustom facemenu-new-faces-at-end t
-  "*Where in the menu to insert newly-created faces.
+  "Where in the menu to insert newly-created faces.
 This should be nil to put them at the top of the menu, or t to put them
 just before \"Other\" at the end."
   :type 'boolean
@@ -139,10 +134,10 @@ just before \"Other\" at the end."
     ,(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
-			"since 22.1,\nand has no effect on the Face menu")
+			"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.
+  "List of faces to include in the Face menu.
 Each element should be a symbol, the name of a face.
 The \"basic \" faces in `facemenu-keybindings' are automatically
 added to the Face menu, and need not be in this list.
@@ -167,41 +162,37 @@ it will remove any faces not explicitly in the list."
   :group 'facemenu
   :version "22.1")
 
-;;;###autoload
 (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.")
-;;;###autoload
 (defalias 'facemenu-face-menu facemenu-face-menu)
 (put 'facemenu-face-menu 'menu-enable '(facemenu-enable-faces-p))
 
-;;;###autoload
 (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.")
-;;;###autoload
 (defalias 'facemenu-foreground-menu facemenu-foreground-menu)
 (put 'facemenu-foreground-menu 'menu-enable '(facemenu-enable-faces-p))
 
-;;;###autoload
 (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.")
-;;;###autoload
 (defalias 'facemenu-background-menu facemenu-background-menu)
 (put 'facemenu-background-menu 'menu-enable '(facemenu-enable-faces-p))
 
 ;;; 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))
 
-;;;###autoload
 (defvar facemenu-special-menu
   (let ((map (make-sparse-keymap "Special")))
     (define-key map [?s] (cons (purecopy "Remove Special")
@@ -214,10 +205,8 @@ it will remove any faces not explicitly in the list."
 			       'facemenu-set-read-only))
     map)
   "Menu keymap for non-face text-properties.")
-;;;###autoload
 (defalias 'facemenu-special-menu facemenu-special-menu)
 
-;;;###autoload
 (defvar facemenu-justification-menu
   (let ((map (make-sparse-keymap "Justification")))
     (define-key map [?c] (cons (purecopy "Center") 'set-justification-center))
@@ -227,10 +216,8 @@ it will remove any faces not explicitly in the list."
     (define-key map [?u] (cons (purecopy "Unfilled") 'set-justification-none))
     map)
   "Submenu for text justification commands.")
-;;;###autoload
 (defalias 'facemenu-justification-menu facemenu-justification-menu)
 
-;;;###autoload
 (defvar facemenu-indentation-menu
   (let ((map (make-sparse-keymap "Indentation")))
     (define-key map [decrease-right-margin]
@@ -243,16 +230,12 @@ it will remove any faces not explicitly in the list."
       (cons (purecopy "Indent More") 'increase-left-margin))
     map)
   "Submenu for indentation commands.")
-;;;###autoload
 (defalias 'facemenu-indentation-menu facemenu-indentation-menu)
 
 ;; This is split up to avoid an overlong line in loaddefs.el.
-;;;###autoload
 (defvar facemenu-menu nil
   "Facemenu top-level menu keymap.")
-;;;###autoload
 (setq facemenu-menu (make-sparse-keymap "Text Properties"))
-;;;###autoload
 (let ((map facemenu-menu))
   (define-key map [dc] (cons (purecopy "Display Colors") 'list-colors-display))
   (define-key map [df] (cons (purecopy "Display Faces") 'list-faces-display))
@@ -263,7 +246,6 @@ it will remove any faces not explicitly in the list."
   (define-key map [rm] (cons (purecopy "Remove Face Properties")
 			     'facemenu-remove-face-props))
   (define-key map [s1] (list (purecopy "--"))))
-;;;###autoload
 (let ((map facemenu-menu))
   (define-key map [in] (cons (purecopy "Indentation")
 			     'facemenu-indentation-menu))
@@ -278,12 +260,12 @@ it will remove any faces not explicitly in the list."
 			     'facemenu-foreground-menu))
   (define-key map [fc] (cons (purecopy "Face")
 			     'facemenu-face-menu)))
-;;;###autoload
 (defalias 'facemenu-menu facemenu-menu)
 
 (defvar facemenu-keymap
   (let ((map (make-sparse-keymap "Set face")))
     (define-key map "o" (cons (purecopy "Other...") 'facemenu-set-face))
+    (define-key map "\M-o" 'font-lock-fontify-block)
     map)
   "Keymap for face-changing commands.
 `Facemenu-update' fills in the keymap according to the bindings
@@ -333,7 +315,6 @@ variables."
   (facemenu-iterate 'facemenu-add-new-face
 		    (facemenu-complete-face-list facemenu-keybindings)))
 
-;;;###autoload
 (defun facemenu-set-face (face &optional start end)
   "Apply FACE to the region or next character typed.
 
@@ -363,7 +344,6 @@ if `facemenu-listed-faces' says to do that."
   (facemenu-add-new-face face)
   (facemenu-add-face face start end))
 
-;;;###autoload
 (defun facemenu-set-foreground (color &optional start end)
   "Set the foreground COLOR of the region or next character typed.
 This command reads the color in the minibuffer.
@@ -386,7 +366,6 @@ typing a character to insert cancels the specification."
    (facemenu-add-new-color color 'facemenu-foreground-menu)
    start end))
 
-;;;###autoload
 (defun facemenu-set-background (color &optional start end)
   "Set the background COLOR of the region or next character typed.
 This command reads the color in the minibuffer.
@@ -409,7 +388,6 @@ typing a character to insert cancels the specification."
    (facemenu-add-new-color color 'facemenu-background-menu)
    start end))
 
-;;;###autoload
 (defun facemenu-set-face-from-menu (face start end)
   "Set the FACE of the region or next character typed.
 This function is designed to be called from a menu; FACE is determined
@@ -441,7 +419,6 @@ to insert cancels the specification."
        face))
    start end))
 
-;;;###autoload
 (defun facemenu-set-invisible (start end)
   "Make the region invisible.
 This sets the `invisible' text property; it can be undone with
@@ -449,7 +426,6 @@ This sets the `invisible' text property; it can be undone with
   (interactive "r")
   (add-text-properties start end '(invisible t)))
 
-;;;###autoload
 (defun facemenu-set-intangible (start end)
   "Make the region intangible: disallow moving into it.
 This sets the `intangible' text property; it can be undone with
@@ -457,7 +433,6 @@ This sets the `intangible' text property; it can be undone with
   (interactive "r")
   (add-text-properties start end '(intangible t)))
 
-;;;###autoload
 (defun facemenu-set-read-only (start end)
   "Make the region unmodifiable.
 This sets the `read-only' text property; it can be undone with
@@ -465,7 +440,6 @@ This sets the `read-only' text property; it can be undone with
   (interactive "r")
   (add-text-properties start end '(read-only t)))
 
-;;;###autoload
 (defun facemenu-remove-face-props (start end)
   "Remove `face' and `mouse-face' text properties."
   (interactive "*r") ; error if buffer is read-only despite the next line.
@@ -473,14 +447,12 @@ This sets the `read-only' text property; it can be undone with
     (remove-text-properties
      start end '(face nil mouse-face nil))))
 
-;;;###autoload
 (defun facemenu-remove-all (start end)
   "Remove all text properties from the region."
   (interactive "*r") ; error if buffer is read-only despite the next line.
   (let ((inhibit-read-only t))
     (set-text-properties start end nil)))
 
-;;;###autoload
 (defun facemenu-remove-special (start end)
   "Remove all the \"special\" text properties from the region.
 These special properties include `invisible', `intangible' and `read-only'."
@@ -489,73 +461,213 @@ These special properties include `invisible', `intangible' and `read-only'."
     (remove-text-properties
      start end '(invisible nil intangible nil read-only nil))))
 
-;;;###autoload
 (defun facemenu-read-color (&optional prompt)
   "Read a color using the minibuffer."
   (let* ((completion-ignore-case t)
-	 (col (completing-read (or prompt "Color: ")
-			       (or facemenu-color-alist
-				   (defined-colors))
-			       nil 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)))
 
-;;;###autoload
-(defun list-colors-display (&optional list buffer-name)
+(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 (cons 'background-color (car color)))
-    (put-text-property
-     (prog1 (point)
-       (insert " " (if (cdr color)
-		       (mapconcat 'identity (cdr color) ", ")
-		     (car color))))
-     (point)
-     'face (cons 'foreground-color (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.
@@ -570,8 +682,8 @@ 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 (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))))
@@ -694,11 +806,11 @@ This is called whenever you create a new face, and at other times."
 	    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))
@@ -796,5 +908,5 @@ Returns the non-nil value it found, or nil if all were nil."
 
 (provide 'facemenu)
 
-;;; arch-tag: 85f6d02b-9085-420e-b651-0678f0e9c7eb
+;; arch-tag: 85f6d02b-9085-420e-b651-0678f0e9c7eb
 ;;; facemenu.el ends here