--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lisp/modes/xpm-mode.el	Mon Aug 13 08:45:50 2007 +0200
@@ -0,0 +1,441 @@
+;;; xpm-mode.el	--- minor mode for editing XPM files
+
+;; Copyright (C) 1995 Joe Rumsey <ogre@netcom.com>
+;; Copyright (C) 1995 Rich Williams <rdw@hplb.hpl.hp.com>
+
+;; Authors: Joe Rumsey <ogre@netcom.com>
+;;	    Rich Williams <rdw@hplb.hpl.hp.com>
+;; Cleanup: Chuck Thompson <cthomp@cs.uiuc.edu>
+
+;; Version:  1.5
+;; Last Modified: Rich Williams <rdw@hplb.hpl.hp.com>, 13 July 1995
+;; Keywords: data tools
+
+;; 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, 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; see the file COPYING.  If not, write to the Free
+;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Synched up with: Not in FSF.
+
+;;
+;; xpm mode:  Display xpm files in color
+;;
+;; thanks to Rich Williams for mods to do this without font-lock-mode,
+;; resulting in much improved performance and a better display
+;; (headers don't get colored strangely). Also for the palette toolbar.
+;;
+;; Non-standard minor mode in that it starts picture-mode automatically.
+;;
+;; To get this turned on automatically for .xpms, add an entry
+;;       ("\\.xpm" . xpm-mode)
+;; to your auto-mode-alist.  For example, my .emacs has this: (abbreviated)
+;; (setq auto-mode-alist (mapcar 'purecopy
+;;                               '(("\\.c$" . c-mode)
+;;                                ("\\.h$" . c-mode)
+;;                                ("\\.el$" . emacs-lisp-mode)
+;;				  ("\\.emacs$" . emacs-lisp-mode)
+;;                                ("\\.a$" . c-mode)
+;;				  ("\\.xpm" . xpm-mode))))
+;; (autoload 'xpm-mode "xpm-mode")
+;;
+;; I am a lisp newbie, practically everything in here I had to look up
+;; in the manual.  It probably shows, suggestions for coding
+;; improvements are welcomed.
+;;
+;; May fail on some xpm's.  Seems to be fine with files generated by
+;; xpaint and ppmtoxpm anyway.  Will definitely fail on xpm's with
+;; more than one character per pixel.  Not that hard to fix, but I've
+;; never seen one like that.
+;;
+;; If your default font is proportional, this will not be very useful.
+;;
+
+(require 'annotations)
+
+(defvar xpm-pixel-values nil)
+(defvar xpm-glyph nil)
+(defvar xpm-anno nil)
+(defvar xpm-paint-string nil)
+(defvar xpm-chars-per-pixel 1)
+(defvar xpm-palette nil)
+(defvar xpm-always-update-image nil
+  "If non-nil, update actual-size image after every click or drag movement.
+Otherwise, only update on button releases or when asked to.  This is slow.")
+
+(make-variable-buffer-local 'xpm-palette)
+(make-variable-buffer-local 'xpm-chars-per-pixel)
+(make-variable-buffer-local 'xpm-paint-string)
+(make-variable-buffer-local 'xpm-glyph)
+(make-variable-buffer-local 'xpm-anno)
+(make-variable-buffer-local 'xpm-pixel-values)
+;(make-variable-buffer-local 'xpm-faces-used)
+
+(defun xpm-make-face (name)
+  "Makes a face with name xpm-NAME, and colour NAME."
+  (let ((face (make-face (intern (concat "xpm-" name))
+			 "Temporary xpm-mode face" t)))
+    (set-face-background face name)
+    (set-face-foreground face "black")
+    face))
+
+(defun xpm-init ()
+  "Treat the current buffer as an xpm file and colorize it."
+  (interactive)
+  (require 'picture)
+
+  (setq xpm-pixel-values nil)
+  (xpm-clear-extents)
+  (setq xpm-palette nil)
+
+  (message "Finding number of colors...")
+  (save-excursion
+    (goto-char (point-min))
+    (beginning-of-line)
+    (next-line 1)
+    (while (not (looking-at "\\s-*\""))
+      (next-line 1))
+    (next-line 1)
+    (while (not (looking-at "\\s-*\""))
+      (next-line 1))
+    (let ((co 0))
+      (while (< co (xpm-num-colors))
+	(progn
+	  (xpm-parse-color)
+	  (setq co (1+ co))
+	  (next-line 1)
+	  (beginning-of-line)))))
+  (if (not (eq major-mode 'picture-mode))
+      (picture-mode))
+  (set-specifier left-toolbar-width (cons (selected-frame) 16))
+  (set-specifier left-toolbar (cons (current-buffer) xpm-palette))
+  (message "Parsing body...")
+  (xpm-color-data)
+  (message "Parsing body...done")
+  (xpm-show-image))
+
+(defun xpm-clear-extents ()
+  (let (cur-extent
+	next-extent)
+    (setq cur-extent (next-extent (current-buffer)))
+    (setq next-extent (next-extent cur-extent))
+    (while cur-extent
+      (delete-extent cur-extent)
+      (setq cur-extent next-extent)
+      (setq next-extent (next-extent cur-extent)))))
+
+(defun xpm-color-data ()
+  (interactive)
+  (save-excursion
+    (xpm-goto-body-line 0)
+    (let (ext
+	  pixel-chars
+	  pixel-color)
+      (while (< (point) (point-max))
+	(setq pixel-chars
+	      (buffer-substring (point) (+ (point) xpm-chars-per-pixel))
+	      pixel-color (assoc pixel-chars xpm-pixel-values)
+	      ext (make-extent (point) (+ (point) xpm-chars-per-pixel)))
+	(if pixel-color
+	    (progn
+	      (set-extent-face ext (cdr pixel-color)))
+	  (set-extent-face ext 'default))
+	(forward-char xpm-chars-per-pixel)))))
+
+(defun xpm-num-colors ()
+  (save-excursion
+    (goto-char (point-min))
+    (if (re-search-forward 
+	 "\"\\s-*\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-*"
+	 (point-max) t)
+	(string-to-int (match-string 3))
+      (error "Unable to parse xpm information"))))
+
+(defun xpm-make-solid-pixmap (colour width height)
+  (let ((x 0)
+	(y 0)
+	(line nil)
+	(total nil))
+    (setq line ",\n\"")
+    (while (< x width)
+      (setq line (concat line ".")
+	    x (+ x 1)))
+    (setq line (concat line "\"")
+	  total (format "/* XPM */\nstatic char * %s[] = {\n\"%d %d 1 1\",\n\". c %s\""
+			colour width height colour))
+    (while (< y height)
+      (setq total (concat total line)
+	    y (+ y 1)))
+    (make-glyph (concat total "};\n"))))
+
+(defun xpm-store-color (str color)
+  "Add STR to xpm-pixel-values with a new face set to background COLOR
+if STR already has an entry, the existing face will be used, with the
+new color replacing the old (on the display only, not in the xpm color
+defs!)"
+  (let (new-face)
+    (setq new-face (xpm-make-face color))
+    (set-face-background new-face color)
+    (let ((ccc (color-rgb-components (make-color-specifier color))))
+      (if (> (length ccc) 0)
+	  (if (or (or (> (elt ccc 0) 32767)
+		      (> (elt ccc 1) 32767))
+		  (> (elt ccc 2) 32767))
+	      (set-face-foreground new-face "black")
+	    (set-face-foreground new-face "white"))))
+    (setq xpm-pixel-values (cons (cons str new-face) xpm-pixel-values)
+	  xpm-palette
+	  (cons (vector 
+		 (list (xpm-make-solid-pixmap color 12 12))
+		 ;; Major cool things with quotes.....
+		 (` 
+		  (lambda (event)
+		    (interactive "e")
+		    (xpm-toolbar-select-colour event (, str))))
+		 t
+		 color) xpm-palette))
+    ))
+
+(defun xpm-parse-color ()
+  "Parse xpm color string from current line and set the color"
+  (interactive)
+  (let (end)
+    (save-excursion
+      (end-of-line)
+      (setq end (point))
+      (beginning-of-line)
+      (if (re-search-forward
+	   ;; Generate a regexp on the fly
+	   (concat "\"\\(" (make-string xpm-chars-per-pixel ?.) "\\)" ; chars
+		   "\\s-+\\([c]\\)"	; there are more classes than 'c'
+		   "\\s-+\\([^\"]+\\)\"")
+	   end t)
+	  (progn 
+	    (xpm-store-color (match-string 1) (match-string 3))
+	    (list (match-string 1) (match-string 3)))
+	(error "Unable to parse color")))))
+
+(defun xpm-add-color (str color)
+  "add a color to an xpm's list of color defs"
+  (interactive "sPixel character: 
+sPixel color (any valid X color string):")
+  (save-excursion
+    (goto-char (point-min))
+    (while (not (looking-at "\\s-*\""))
+      (next-line 1))
+    (next-line 1)
+    (while (not (looking-at "\\s-*\""))
+      (next-line 1))
+    (let ((co 0))
+      (while (< co (xpm-num-colors))
+	(next-line 1)
+	(setq co (1+ co))))
+    (insert (format "\"%s\tc %s\",\n" str color))
+    (previous-line 1)
+    (xpm-parse-color)
+
+    (goto-char (point-min))
+    (while (not (looking-at "\\s-*\""))
+      (next-line 1))
+    (let ((entry 0))
+      (while (or (= (char-after (point)) ? ) (= (char-after (point)) ?\"))
+	(forward-char 1))
+      (while (< entry 2)
+	(progn
+	  (if (eq (char-after (point)) ? )
+	      (progn
+		(setq entry (1+ entry))
+		(while (eq (char-after (point)) ? )
+		  (forward-char 1)))
+	    (forward-char 1))))
+      (let ((old-colors (xpm-num-colors)))
+	(while (and (>= (char-after (point)) ?0) (<= (char-after (point)) ?9))
+	  (delete-char 1))
+      (insert (int-to-string (1+ old-colors)))))))
+
+
+(defun xpm-goto-color-def (def)
+  "move to color DEF in the xpm header"
+  (interactive "nColor number:")
+  (goto-char (point-min))
+  (while (not (looking-at "\\s-*\""))
+    (next-line 1))
+  (next-line 1)
+  (while (not (looking-at "\\s-*\""))
+    (next-line 1))
+  (next-line def))
+
+(defun xpm-goto-body-line (line)
+  "move to LINE lines down from the start of the body of an xpm"
+  (interactive "nBody line:")
+  (goto-char (point-min))
+  (xpm-goto-color-def (xpm-num-colors))
+  (next-line line))
+
+(defun xpm-show-image ()
+  "Display the xpm in the current buffer at the end of the topmost line"
+  (interactive)
+  (save-excursion
+    (if (annotationp xpm-anno)
+	(delete-annotation xpm-anno))
+    (setq xpm-glyph (make-glyph 
+		     (vector 'xpm :data 
+			     (buffer-substring (point-min) (point-max)))))
+    (goto-char (point-min))
+    (end-of-line)
+    (setq xpm-anno (make-annotation xpm-glyph (point) 'text))))
+
+(defun xpm-hide-image ()
+  "Remove the image of the xpm from the buffer"
+  (interactive)
+  (if (annotationp xpm-anno)
+      (delete-annotation xpm-anno)))
+
+(defun xpm-in-body ()
+  (let ((p (point)))
+    (save-excursion
+      (xpm-goto-body-line 0)
+      (> p (point)))))
+
+(defvar xpm-mode nil)
+(make-variable-buffer-local 'xpm-mode)
+(add-minor-mode 'xpm-mode " XPM" nil)
+(defvar xpm-mode-map (make-keymap))
+
+(defun xpm-toolbar-select-colour (event chars)
+  "Toolbar button"
+  (let* ((button (event-toolbar-button event))
+	 (help (toolbar-button-help-string button)))
+    (message "Toolbar selected %s (%s)"  help chars)
+    (setq xpm-palette
+	  (mapcar #'(lambda (but)
+		      (aset but 2 (not (eq help (aref but 3))))
+		      but)
+		  xpm-palette)
+	  xpm-paint-string chars)
+    (set-specifier left-toolbar (cons (current-buffer) xpm-palette))))
+
+(defun xpm-mouse-paint (event)
+  (interactive "e")
+  (mouse-set-point event)
+  (if (xpm-in-body)
+      ;; in body, overwrite the paint string where the mouse is clicked
+      (progn
+	(insert xpm-paint-string)
+	(delete-char (length xpm-paint-string)))
+    ;; otherwise, select the color defined by the line where the mouse
+    ;; was clicked
+    (save-excursion
+      (beginning-of-line)
+      (forward-char 1)
+      (setq xpm-paint-string (buffer-substring (point) (1+ (point)))))))
+
+(defun xpm-mouse-down (event n)
+;  (interactive "ep")
+  (mouse-set-point event)
+  (if (xpm-in-body)
+      ;; in body, overwrite the paint string where the mouse is clicked
+      (progn
+	(insert xpm-paint-string)
+	(delete-char (length xpm-paint-string))
+	(if xpm-always-update-image
+	    (xpm-show-image))
+	(let ((ext (make-extent (1- (point))
+				(+ (1- (point)) xpm-chars-per-pixel)))
+	      (pixel-color (assoc xpm-paint-string xpm-pixel-values)))
+	  (if pixel-color
+	      (set-extent-face ext (cdr pixel-color))
+	    (set-extent-face ext 'default))))
+    ;; otherwise, select the color defined by the line where the mouse
+    ;; was clicked
+    (save-excursion
+      (beginning-of-line)
+      (forward-char 1)
+      (setq xpm-paint-string (buffer-substring (point) (1+ (point)))))))
+
+(defun xpm-mouse-drag (event n timeout)
+  (or timeout
+      (progn
+	(mouse-set-point event)
+	(if (xpm-in-body)
+	    ;; Much improved by not using font-lock-mode
+	    (or (string= xpm-paint-string
+			 (buffer-substring (point)
+					   (+ (length xpm-paint-string)
+					      (point))))
+		(progn
+		  (insert-char (string-to-char xpm-paint-string) 1)
+					;	  (insert xpm-paint-string)
+		  (delete-char (length xpm-paint-string))
+		  (if xpm-always-update-image
+		      (xpm-show-image))
+		  (let ((ext (make-extent
+			      (1- (point))
+			      (+ (1- (point)) xpm-chars-per-pixel)))
+			(pixel-color
+			 (assoc xpm-paint-string xpm-pixel-values)))
+		    (if pixel-color
+			(set-extent-face ext (cdr pixel-color))
+		      (set-extent-face ext 'default)))))))))
+
+(defun xpm-mouse-up (event n)
+  (xpm-show-image))
+
+;;;###autoload
+(defun xpm-mode (&optional arg)
+  "Treat the current buffer as an xpm file and colorize it.
+
+  Shift-button-1 lets you paint by dragging the mouse.  Shift-button-1 on a
+color definition line will change the current painting color to that line's
+value.
+
+  Characters inserted from the keyboard will NOT be colored properly yet.
+Use the mouse, or do xpm-init (\\[xpm-init]) after making changes.
+
+\\[xpm-add-color] Add a new color, prompting for character and value
+\\[xpm-show-image] show the current image at the top of the buffer
+\\[xpm-parse-color] parse the current line's color definition and add
+   it to the color table.  Provided as a means of changing colors.
+XPM minor mode bindings:
+\\{xpm-mode-map}"
+
+  (interactive "P")
+  (setq xpm-mode
+	(if (null arg) (not xpm-mode)
+	  (> (prefix-numeric-value arg) 0)))
+  (if xpm-mode
+      (progn
+	(xpm-init)
+	(make-local-variable 'mouse-track-down-hook)
+	(make-local-variable 'mouse-track-drag-hook)
+	(make-local-variable 'mouse-track-up-hook)
+	(make-local-variable 'mouse-track-drag-up-hook)
+	(make-local-variable 'mouse-track-click-hook)
+	(setq mouse-track-down-hook 'xpm-mouse-down)
+	(setq mouse-track-drag-hook 'xpm-mouse-drag)
+	(setq mouse-track-up-hook 'xpm-mouse-up)
+	(setq mouse-track-drag-up-hook 'xpm-mouse-up)
+	(setq mouse-track-click-hook nil)
+	(or (assq 'xpm-mode minor-mode-map-alist)
+	    (progn
+	      (define-key xpm-mode-map [(control c) r] 'xpm-show-image)
+	      (define-key xpm-mode-map [(shift button1)] 'mouse-track)
+	      (define-key xpm-mode-map [button1] 'mouse-track-default)
+	      (define-key xpm-mode-map [(control c) c] 'xpm-add-color)
+	      (define-key xpm-mode-map [(control c) p] 'xpm-parse-color)
+	      (setq minor-mode-map-alist (cons (cons 'xpm-mode xpm-mode-map)
+					       minor-mode-map-alist)))))))
+
+(provide 'xpm-mode)
+;;; xpm-mode.el ends here