;;; 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, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, 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))

    (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)
	  (setq xpm-chars-per-pixel (string-to-int (match-string 4)))))

    (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))
  (if (featurep 'toolbar)
      (progn
	(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 (and (< (point) (point-max))
		  (< (+ (point) xpm-chars-per-pixel) (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))
    (if (featurep 'toolbar)
	(setq 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