--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lisp/packages/edit-faces.el	Mon Aug 13 08:45:50 2007 +0200
@@ -0,0 +1,354 @@
+;;; edit-faces.el -- interactive face editing mode
+
+;; Copyright (C) 1994, 1995 Tinker Systems and INS Engineering Corp.
+;; Copyright (C) 1996 Ben Wing.
+;; 
+;; This file is part of XEmacs.
+;; 
+;; XEmacs 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 2 of the License, or
+;; (at your option) any later version.
+;; 
+;; XEmacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+;; 
+;; You should have received a copy of the GNU General Public License
+;; along with XEmacs; if not, write to the Free Software
+;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Synched up with: Not in FSF.
+;;; #### FSF has facemenu.el.  Should merge with.
+
+;;; Original author: Stig <stig@hackvan.com>.
+;;; Significantly fixed up: Ben Wing <wing@666.com>.
+
+(defvar edit-faces-menu
+  '("Edit-Faces"
+    ["Copy other face..." ef-copy-other-face t]
+    ["Copy this face..." ef-copy-this-face t]
+    ["Make smaller"	ef-smaller	t]
+    ["Make larger"	ef-larger	t]
+    ["Toggle bold"	ef-bold		t]
+    ["Toggle italic"	ef-italic	t]
+    ["Toggle underline"	ef-underline	t]
+    ["Query true font"	ef-truefont	t]
+    ["Set font"		ef-font		t]
+    ["Set foreground"	ef-foreground	t]
+    ["Set background"	ef-background	t]
+    ["Set doc string"	ef-doc-string	t]
+    ["Quit"		ef-quit		t]
+    ))
+
+(or (find-face 'underline)
+    (progn (make-face 'underline)
+	   (set-face-underline-p 'underline t)))
+
+(define-derived-mode edit-faces-mode list-mode
+  "Edit-Faces"
+  "Major mode for `edit-faces' buffers.
+
+Editing commands:
+
+\\{edit-faces-mode-map}"
+  (setq truncate-lines t)
+  ;; auto-show-mode is too confusing in this mode
+  (setq auto-show-mode nil)
+  (setq	mode-popup-menu edit-faces-menu)
+  (if current-menubar
+      (progn
+	(set (make-local-variable 'current-menubar)
+	     (copy-sequence current-menubar))
+	(add-submenu nil edit-faces-menu))))
+
+(let ((map edit-faces-mode-map))
+  (define-key map "<" 'ef-smaller)
+  (define-key map ">" 'ef-larger)
+  (define-key map "c" 'ef-copy-other-face)
+  (define-key map "C" 'ef-copy-this-face)
+  (define-key map "s" 'ef-smaller)
+  (define-key map "l" 'ef-larger)
+  (define-key map "b" 'ef-bold)
+  (define-key map "i" 'ef-italic)
+  (define-key map "e" 'ef-font)
+  (define-key map "f" 'ef-font)
+  (define-key map "u" 'ef-underline)
+  (define-key map "t" 'ef-truefont)
+  (define-key map "F" 'ef-foreground)
+  (define-key map "B" 'ef-background)
+  (define-key map "D" 'ef-doc-string)
+  (define-key map "d" 'ef-delete)
+  (define-key map "n" 'ef-next)
+  (define-key map "p" 'ef-prev)
+  (define-key map " " 'ef-next)
+  (define-key map "\C-?" 'ef-prev)
+  (define-key map "g" 'edit-faces)	; refresh display
+  (define-key map "q" 'ef-quit)
+  (define-key map "\C-c\C-c" 'bury-buffer))
+
+;;;###autoload
+(defun edit-faces ()
+  "Alter face characteristics by editing a list of defined faces.
+Pops up a buffer containing a list of defined faces.
+
+Editing commands:
+
+\\{edit-faces-mode-map}"
+  (interactive)
+  (pop-to-buffer (get-buffer-create "*Edit Faces*"))
+  (reset-buffer (current-buffer))
+
+  ;; face-list returns faces in a random order so we sort
+  ;; alphabetically by the name in order to insert some logic into
+  ;; the ordering.
+  (let ((flist (sort (face-list)
+		     (function
+		      (lambda (x y)
+			(string-lessp (symbol-name x) (symbol-name y))))))
+	face)
+    (ef-update-face-description t)	; insert header line
+    (while (setq face (car flist))
+      (ef-update-face-description face)
+      (setq flist (cdr flist))
+      ))
+  (edit-faces-mode)
+)
+
+(defun ef-foreground-callback (event extent user-data)
+  (ef-foreground (ef-face-arg (extent-start-position extent)
+			      (extent-object extent))))
+  
+(defun ef-background-callback (event extent user-data)
+  (ef-background (ef-face-arg (extent-start-position extent)
+			      (extent-object extent))))
+
+(defun ef-font-callback (event extent user-data)
+  (ef-font (ef-face-arg (extent-start-position extent)
+			(extent-object extent))))
+
+(defun ef-doc-string-callback (event extent user-data)
+  (ef-doc-string (ef-face-arg (extent-start-position extent)
+			      (extent-object extent))))
+
+(defun ef-update-face-description (face &optional replace)
+  "Given a face, inserts a description of that face into the current buffer.
+Inserts a descriptive header if passed `t'."
+  (let ((face-name-fmt "%-25s")
+	(foreground-fmt "%-15s")
+	(background-fmt "%-15s")
+	(font-fmt "%s")
+	(buffer-read-only nil)
+	fg bg font)
+    (if (eq face t)
+	(insert-face (format (concat face-name-fmt " " foreground-fmt " "
+				     background-fmt " " font-fmt "\n")
+			     "Face" "Foreground" "Background" "Font Spec")
+		     'underline)
+      (or replace (setq replace face))
+      (goto-char (point-min)) 
+      (if (re-search-forward (concat "^" (symbol-name replace) " ") nil 0)
+	  (progn
+	    (beginning-of-line)
+	    (delete-region (point) (progn (forward-line 2) (point)))
+	    ))
+      (setq fg (face-foreground-instance face)
+	    bg (face-background-instance face)
+	    font (face-font-instance face))
+      (let ((st (point))
+	    (fn #'(lambda (str callback)
+		    (let ((st1 (point)))
+		      (insert str)
+		      (add-list-mode-item st1 (point) nil callback)))))
+	(funcall fn (format face-name-fmt (symbol-name face)) nil)
+	(insert " ")
+	(funcall fn (format foreground-fmt (color-instance-name fg))
+		 'ef-foreground-callback)
+	(insert " ")
+	(funcall fn (format background-fmt (color-instance-name bg))
+		 'ef-background-callback)
+	(insert " ")
+	(funcall fn (format font-fmt (font-instance-name font))
+		 'ef-font-callback)
+	(insert "\n  (")
+	(funcall fn (or (face-doc-string face) "")
+		 'ef-doc-string-callback)
+	(insert ")")
+	(add-nonduplicable-text-properties st (point)
+					   `(face ,face eface ,face
+						  start-open t))
+	(insert "\n")
+	)
+      (and replace (forward-line -1))
+      ))
+  )
+
+(defun ef-face-arg (&optional pos buffer)
+  (if (and (not pos) (not buffer))
+      (and current-mouse-event
+	   (mouse-event-p current-mouse-event)
+	   (mouse-set-point current-mouse-event)))
+  (or buffer (setq buffer (current-buffer)))
+  (or pos (setq pos (point buffer)))
+  (let ((face (or (get-char-property pos 'eface buffer)
+		  (and (> pos (point-min buffer))
+		       (get-char-property (1- pos) 'eface buffer)))))
+    (or face (error "There is no face to edit on this line."))
+    face))
+
+(defun ef-delete (arg)
+  "Delete the face on the current line from the *Edit Faces* buffer.
+The face is not altered.  The buffer can be regenerated again with
+M-x edit-faces."
+  (interactive "p") 
+  (and current-mouse-event (mouse-event-p current-mouse-event)
+       (mouse-set-point current-mouse-event))
+  (let ( ;; is this worth the bother? (fwd (> arg 0))
+	(count (abs arg))
+	(buffer-read-only nil)
+	ex)
+    (while (not (zerop (prog1 count (setq count (1- count)))))
+      (setq ex (text-property-bounds (point) 'eface nil 'at))
+      (or ex (error "There is no face to delete on this line."))
+      (delete-region (car ex) (cdr ex))
+      (delete-blank-lines))))
+  
+(defun ef-next (arg)
+  "Move forward ARG entries in the face table."
+  (interactive "p") 
+  (let ((bounds (next-text-property-bounds arg (point) 'eface)))
+    (if bounds (goto-char (car bounds))
+      (goto-char (if (> arg 0) (point-max) (point-min))))))
+
+(defun ef-prev (arg)
+  "Move forward ARG entries in the face table."
+  (interactive "p") 
+  (ef-next (- arg)))
+
+(defun ef-smaller (face)
+  (interactive (list (ef-face-arg)))
+  (make-face-smaller face)
+  (ef-update-face-description face))
+
+(defun ef-larger (face)
+  (interactive (list (ef-face-arg)))
+  (make-face-larger face)
+  (ef-update-face-description face))
+
+(defun ef-face-font-indirect (face)
+  (let ((font (face-font-instance face)))
+    (or font (face-font-instance 'default))))
+
+(defun ef-face-bold-p (face)
+  (let ((font (ef-face-font-indirect face)))
+    (not (not (string-match "-bold-" (font-instance-name font))))))
+
+(defun ef-face-italic-p (face)
+  (let ((font (ef-face-font-indirect face)))
+    (not (not (string-match "-[io]-" (font-instance-name font))))))
+
+(defun ef-bold (face)
+  (interactive (list (ef-face-arg)))
+  (if (ef-face-bold-p face)
+      (make-face-unbold face)
+    (make-face-bold face))
+  (ef-update-face-description face))
+
+(defun ef-italic (face)
+  (interactive (list (ef-face-arg)))
+  (if (ef-face-italic-p face)
+      (make-face-unitalic face)
+    (make-face-italic face))
+  (ef-update-face-description face))
+
+(defun ef-underline (face)
+  (interactive (list (ef-face-arg)))
+  (set-face-underline-p face (not (face-underline-p face)))
+  (ef-update-face-description face))
+
+(defun ef-truefont (face)
+  (interactive (list (ef-face-arg)))
+  (let ((font (face-font-instance face))
+	(name (symbol-name face)))
+    (if font
+	(message "True font for `%s': %s" name (font-instance-truename font))
+      (message "The face `%s' does not have its own font." name))))
+
+(defun ef-foreground (face)
+  (interactive
+   (list (ef-face-arg)))
+  (set-face-foreground
+   face
+   (read-color (format "Foreground color for `%s': " (symbol-name face))
+	       nil
+	       (color-instance-name (face-foreground-instance face))))
+  (ef-update-face-description face))
+
+(defun ef-background (face)
+  (interactive
+   (list (ef-face-arg)))
+  (set-face-background
+   face
+   (read-color (format "Background color for `%s': " (symbol-name face))
+	       nil
+	       (color-instance-name (face-background-instance face))))
+  (ef-update-face-description face))
+
+(defun ef-doc-string (face)
+  (interactive
+   (list (ef-face-arg)))
+  (set-face-doc-string
+   face
+   (read-string (format "Doc string for `%s': " (symbol-name face))
+		(face-doc-string face)))
+  (ef-update-face-description face))
+
+(defun ef-copy-other-face (src dst)
+  (interactive
+   (let* ((f (ef-face-arg))
+	  (name (symbol-name f)))
+     (list (read-face (format "Make `%s' a copy of what face?: " name) t) f)))
+  (copy-face src dst)
+  (ef-update-face-description dst dst))
+
+(defun ef-copy-this-face (src dst)
+  (interactive
+   (let* ((f (ef-face-arg))
+	  (name (symbol-name f)))
+       (list f (read-face (format "Copy `%s' onto what face?: " name)))))
+  (copy-face src dst)
+  (ef-update-face-description dst dst))
+
+(defun ef-font (face)
+  (interactive
+   (list (ef-face-arg)))
+  (let* ((ofont (face-font-instance face))
+	 (font (read-string (format "Font for `%s': " (symbol-name face))
+			    (font-instance-name (face-font-instance face))))
+	 others)
+    ;; you might think that this could be moved into the loop below, but I
+    ;; think that it's important to see the new font before asking if the
+    ;; change should be global. 
+    (set-face-font face (if (and (string= font "")
+				 (not (eq face 'default)))
+			    nil font))
+    (ef-update-face-description face)
+    (setq others (delq nil (mapcar (lambda (f)
+				     (and (equal (face-font-instance f) ofont)
+					  f))
+			       (face-list))))
+    (if (and others
+	     (y-or-n-p "Make the same font change for other faces? "))
+	(while others
+	  (setq face (car others)
+		others (cdr others))
+	  (set-face-font face font)
+	  (ef-update-face-description face)))
+    ))
+
+(defun ef-quit ()
+  (interactive)
+  (or (one-window-p t 0)
+      (delete-window))
+  (kill-buffer "*Edit Faces*"))