+ (remove-text-properties
+ start end '(invisible nil intangible nil read-only nil))))
+\f
+;;;###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)))
+ (if (equal "" col)
+ nil
+ col)))
+
+;;;###autoload
+(defun list-colors-display (&optional list buffer-name)
+ "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*."
+ (interactive)
+ (when (and (null list) (> (display-color-cells) 0))
+ (setq list (list-colors-duplicates (defined-colors)))
+ (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-output-to-temp-buffer (or buffer-name "*Colors*")
+ (save-excursion
+ (set-buffer standard-output)
+ (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)))
+
+(defun list-colors-duplicates (&optional list)
+ "Return a list of colors with grouped duplicate colors.
+If a color has no duplicates, then the element of the returned list
+has the form '(COLOR-NAME). The element of the returned list with
+duplicate colors has the form '(COLOR-NAME DUPLICATE-COLOR-NAME ...).
+This function uses the predicate `facemenu-color-equal' to compare
+color names. If the optional argument LIST is non-nil, it should
+be a list of colors to display. Otherwise, this function uses
+a list of colors that the current display can handle."
+ (let* ((list (mapcar 'list (or list (defined-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)))))
+ (progn
+ (setcdr (car l) (cons (car (car (cdr l))) (cdr (car l))))
+ (setcdr l (cdr (cdr l))))
+ (setq l (cdr l))))
+ list))
+
+(defun facemenu-color-equal (a b)
+ "Return t if colors A and B are the same color.
+A and B should be strings naming colors.
+This function queries the display system to find out what the color
+names mean. It returns nil if the colors differ or if it can't
+determine the correct answer."
+ (cond ((equal a b) t)
+ ((equal (color-values a) (color-values b)))))
+
+(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
+instead. For each section of that region that has a different face property,
+FACE will be consed onto it, and other faces that are completely hidden by
+that will be removed from the list.
+If `facemenu-add-face-function' and maybe `facemenu-end-add-face' are non-nil,
+they are used to set the face information.
+
+As a special case, if FACE is `default', then the region is left with NO face
+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)))))
+ (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)))))))
+ (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))))
+ (unless (facemenu-enable-faces-p)
+ (message "Font-lock mode will override any faces you set in this buffer")))
+
+(defun facemenu-active-faces (face-list &optional frame)
+ "Return from FACE-LIST those faces that would be used for display.
+This means each face attribute is not specified in a face earlier in FACE-LIST
+and such a face is therefore active when used to display text.
+If the optional argument FRAME is given, use the faces in that frame; otherwise
+use the selected frame. If t, then the global, non-frame faces are used."
+ (let* ((mask-atts (copy-sequence
+ (if (consp (car face-list))
+ (face-attributes-as-vector (car face-list))
+ (or (internal-lisp-face-p (car face-list) frame)
+ (check-face (car face-list))))))
+ (active-list (list (car face-list)))
+ (face-list (cdr face-list))
+ (mask-len (length mask-atts)))
+ (while face-list
+ (if (let ((face-atts
+ (if (consp (car face-list))
+ (face-attributes-as-vector (car face-list))
+ (or (internal-lisp-face-p (car face-list) frame)
+ (check-face (car face-list)))))
+ (i mask-len)
+ (useful nil))
+ (while (>= (setq i (1- i)) 0)
+ (and (not (memq (aref face-atts i) '(nil unspecified)))
+ (memq (aref mask-atts i) '(nil unspecified))
+ (aset mask-atts i (setq useful t))))
+ useful)
+ (setq active-list (cons (car face-list) active-list)))
+ (setq face-list (cdr face-list)))
+ (nreverse active-list)))
+
+(defun facemenu-add-new-face (face)
+ "Add FACE (a face) to the Face menu.
+
+This is called whenever you create a new face."
+ (let* (name
+ symbol
+ menu docstring
+ (key (cdr (assoc face facemenu-keybindings)))
+ function menu-val)
+ (if (symbolp face)
+ (setq name (symbol-name face)
+ symbol face)
+ (setq name face
+ symbol (intern name)))
+ (setq menu 'facemenu-face-menu)
+ (setq docstring
+ (format "Select face `%s' for subsequent insertion."
+ name))
+ (cond ((eq t facemenu-unlisted-faces))
+ ((memq symbol facemenu-unlisted-faces))
+ ;; test against regexps in facemenu-unlisted-faces
+ ((let ((unlisted facemenu-unlisted-faces)
+ (matched nil))
+ (while (and unlisted (not matched))
+ (if (and (stringp (car unlisted))
+ (string-match (car unlisted) name))
+ (setq matched t)
+ (setq unlisted (cdr unlisted))))
+ matched))
+ (key ; has a keyboard equivalent. These go at the front.
+ (setq function (intern (concat "facemenu-set-" name)))
+ (fset function
+ `(lambda ()
+ ,docstring
+ (interactive)
+ (facemenu-set-face
+ (quote ,symbol)
+ (if (and mark-active (not current-prefix-arg))
+ (region-beginning))
+ (if (and mark-active (not current-prefix-arg))
+ (region-end)))))
+ (define-key 'facemenu-keymap key (cons name function))
+ (define-key menu key (cons name function)))
+ ((facemenu-iterate ; check if equivalent face is already in the menu
+ (lambda (m) (and (listp m)
+ (symbolp (car m))
+ (face-equal (car m) symbol)))
+ (cdr (symbol-function menu))))
+ (t ; No keyboard equivalent. Figure out where to put it:
+ (setq key (vector symbol)
+ function 'facemenu-set-face-from-menu
+ menu-val (symbol-function menu))
+ (if (and facemenu-new-faces-at-end
+ (> (length menu-val) 3))
+ (define-key-after menu-val key (cons name function)
+ (car (nth (- (length menu-val) 3) menu-val)))
+ (define-key menu key (cons name function))))))
+ nil) ; Return nil for facemenu-iterate
+
+(defun facemenu-add-new-color (color menu)
+ "Add COLOR (a color name string) to the appropriate Face menu.
+MENU should be `facemenu-foreground-menu' or `facemenu-background-menu'.
+Return the event type (a symbol) of the added menu entry.
+
+This is called whenever you use a new color."
+ (let (symbol docstring)
+ (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))))
+ ((eq menu 'facemenu-background-menu)
+ (setq docstring
+ (format "Select background color %s for subsequent insertion."
+ color)
+ 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)
+ (eq (car m) symbol)))
+ (cdr (symbol-function menu)))
+ ;; Color is not in the menu. Figure out where to put it.
+ (let ((key (vector symbol))
+ (function 'facemenu-set-face-from-menu)
+ (menu-val (symbol-function menu)))
+ (if (and facemenu-new-faces-at-end
+ (> (length menu-val) 3))
+ (define-key-after menu-val key (cons color function)
+ (car (nth (- (length menu-val) 3) menu-val)))
+ (define-key menu key (cons color function)))))
+ symbol))