cgit.sxemacs.org Git - packages/blob - xemacs-packages/text-modes/xpm-mode.el

   1 ;;; xpm-mode.el --- minor mode for editing XPM files
   2
   3 ;; Copyright (C) 1995 Joe Rumsey <ogre@netcom.com>
   4 ;; Copyright (C) 1995 Rich Williams <rdw@hplb.hpl.hp.com>
   5 ;; Copyright (C) 2011 Byrel Mitchell <byrel.mitchell@gmail.com>
   6 ;; Copyright (C) 2011 Steve Mitchell <smitchel@bnin.net>
   7
   8 ;; Authors: Joe Rumsey <ogre@netcom.com>
   9 ;;          Rich Williams <rdw@hplb.hpl.hp.com>
  10 ;; Cleanup: Chuck Thompson <cthomp@cs.uiuc.edu>
  11 ;; New features and fixes:  Byrel Mitchell <byrel.mitchell@gmail.com>
  12 ;; New Features and fixes:  Steven Mitchell <smitchel@bnin.net>
  13
  14 ;; Version:  2.0
  15 ;; Modified: Rich Williams <rdw@hplb.hpl.hp.com>, 13 July 1995
  16 ;; Last Modified Byrel and Steve Mitchell, 9 July 2011
  17 ;; Keywords: data tools
  18
  19 ;; This file is part of XEmacs.
  20
  21 ;; XEmacs is free software; you can redistribute it and/or modify it
  22 ;; under the terms of the GNU General Public License as published by
  23 ;; the Free Software Foundation; either version 2, or (at your option)
  24 ;; any later version.
  25
  26 ;; XEmacs is distributed in the hope that it will be useful, but
  27 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  28 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  29 ;; General Public License for more details.
  30
  31 ;; You should have received a copy of the GNU General Public License
  32 ;; along with XEmacs; see the file COPYING.  If not, write to the
  33 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  34 ;; Boston, MA 02111-1307, USA.
  35
  36 ;;; Synched up with: Not in FSF.
  37
  38 ;;
  39 ;; xpm mode:  Display xpm files in color
  40 ;;
  41 ;; thanks to Rich Williams for mods to do this without font-lock-mode,
  42 ;; resulting in much improved performance and a better display
  43 ;; (headers don't get colored strangely). Also for the palette toolbar.
  44 ;;
  45 ;; Non-standard minor mode in that it starts picture-mode automatically.
  46 ;;
  47 ;; To get this turned on automatically for .xpms, add an entry
  48 ;;       ("\\.xpm" . xpm-mode)
  49 ;; to your auto-mode-alist.  For example, my .emacs has this: (abbreviated)
  50 ;; (setq auto-mode-alist (mapcar 'purecopy
  51 ;;                               '(("\\.c$" . c-mode)
  52 ;;                                ("\\.h$" . c-mode)
  53 ;;                                ("\\.el$" . emacs-lisp-mode)
  54 ;;                                ("\\.emacs$" . emacs-lisp-mode)
  55 ;;                                ("\\.a$" . c-mode)
  56 ;;                                ("\\.xpm" . xpm-mode))))
  57 ;; (autoload 'xpm-mode "xpm-mode")
  58 ;;
  59 ;; I am a lisp newbie, practically everything in here I had to look up
  60 ;; in the manual.  It probably shows, suggestions for coding
  61 ;; improvements are welcomed.
  62 ;;
  63 ;; May fail on some xpm's.  Seems to be fine with files generated by
  64 ;; xpaint and ppmtoxpm anyway.  Will definitely fail on xpm's with
  65 ;; more than one character per pixel.  Not that hard to fix, but I've
  66 ;; never seen one like that.
  67 ;;
  68 ;; If your default font is proportional, this will not be very useful.
  69 ;;
  70 ;; Changes 7/2011:
  71 ;; - added doc strings to existing functions
  72 ;; - changed several functions with eye toward speed of execution.
  73 ;; - fixed support for multi-byte colors in several functions,
  74 ;;        these occur when more than ~100 colors exist in an .xpm
  75 ;;        which are very common in xpm's used today.
  76 ;; - added support for Alpha layer, inplemented as an xpm extension
  77 ;; - added an xpm-mode toolbar with 16 new icons
  78 ;; - added function to create a new blank xpm, w/transparent background
  79 ;; - added functions to create several kinds of gradient backgrounds
  80 ;; - added feature to overlay one xpm onto another xpm, combining
  81 ;;         data, combining color maps into a new color map,
  82 ;;         fixing color name collisions, removing unused colors
  83 ;;         the 2nd file can be overlaid with x and/or y offsets.
  84 ;; - added functions to shift image up/down/left/right by pixel(s)
  85 ;; - added functions to rotate xpm 90 deg. cc and ccw
  86 ;; - added functions to mirror the xpm about horiz. and vert. axis'
  87 ;; - added cropping of xpm, updating 'colors' & 'values' sections to match.
  88 ;; - added function to enlarge an existing XPM in width and/or height
  89 ;; - added function to create a 3d "bevel" around outside of an xpm.
  90 ;; - in the colors section, displays the colors on the same line that
  91 ;;         defines them, useful for "seeing" RGB colors in hexedecimal.
  92 ;; - added function to show/hide the characters in the pixels section to
  93 ;;         make the image more like what the fiished xpm will look like.
  94 ;; - with all the new commands, added a menu button "xpm mode help" with
  95 ;;         a list of commands for reference, opens in new window.
  96 ;; - added functions to dim or brighten the image with the alpha channel.
  97 ;;         perhaps also useful for creating greyed-out disabled buttons.
  98 ;;
  99 ;;
 100 ;; Future Items still to do:
 101 ;;  1. on files with large number of colors, creating the color pallet
 102 ;;    icons on the side toolbar still takes inordinately long.
 103 ;;    a 128 x 128 image could have up to 16,384 colors, though commonly
 104 ;;    has 700-2000 colors per file
 105 ;;    Explore faster way to generate these.
 106 ;;    we stopped it generating them after the first 200 colors, as you
 107 ;;    cannot display more that (a 30" monitor = a column of 96 per side)
 108 ;;
 109 ;;  2. Rather than just attempting to load in a file and hoping it is
 110 ;;    formatted correctly, we should examine the file and make sure:
 111 ;;     -that it is an xpm file, no matter filename extension
 112 ;;     -that each of the 5 sections can be parsed and contain the right
 113 ;;       amount of data.
 114 ;;     -generate error codes that tell exactly what it cannot parse
 115 ;;       and which line number it fails at.
 116 ;;
 117 ;;  3. Since 2 characters wide is about square on most monitors, and it
 118 ;;     is a better representation of the graphic as a whole, maybe
 119 ;;     we should eliminate the displaying of single-byte colored files
 120 ;;     and display both single and 2-byte-color xpms as 2 chars wide in
 121 ;;     our display.  When saved, they would have been converted to 2-byte
 122 ;;     per color files, which is not a big deal--they get displayed on a
 123 ;;     computer the same...
 124 ;;
 125 ;; to run, load an xpm into XEmacs, or type M-x xpm-mode in the minibuffer.
 126 ;;
 127 ;;; Code:
 128
 129 (require 'annotations)
 130
 131
 132
 133 (defvar xpm-gradient-menu nil)
 134 (defvar xpm-menu nil)
 135 (defvar xpm-open-icon nil)
 136 (defvar xpm-save-icon nil)
 137 (defvar xpm-undo-icon nil)
 138 (defvar xpm-new-image-icon nil)
 139 (defvar xpm-sh-l-icon nil)
 140 (defvar xpm-sh-r-icon nil)
 141 (defvar xpm-sh-u-icon nil)
 142 (defvar xpm-sh-d-icon nil)
 143 (defvar xpm-r-cw-icon nil)
 144 (defvar xpm-r-ccw-icon nil)
 145 (defvar xpm-m-vert-icon nil)
 146 (defvar xpm-m-horiz-icon nil)
 147 (defvar xpm-crop-icon nil)
 148 (defvar xpm-enlarge-icon nil)
 149 (defvar xpm-show-chars-icon nil)
 150 (defvar xpm-hide-chars-icon nil)
 151 (defvar xpm-color-icon nil)
 152 (defvar xpm-chars-icon nil)
 153 (defvar xpm-black-color-icon-path nil)
 154 (defvar xpm-white-color-icon-path nil)
 155 (defvar xpm-help-icon nil)
 156 (defvar xpm-pencil-icon nil)
 157 (defvar xpm-eyedropper-image nil)
 158 (defvar xpm-pencil-image nil)
 159 (defvar xpm-select-image nil)
 160 (defvar xpm-tool 'xpm-eyedropper
 161   "Should be the name of a tool implemented in xpm mode.
 162 Currently, there are only three tools:
 163     'xpm-pencil
 164     'xpm-select
 165     'xpm-eyedropper")
 166 (defvar text-modes-toolbar-icon-directory nil)
 167 (defvar xpm-pixel-values nil)
 168 (defvar xpm-alpha-values nil)
 169 (defvar xpm-glyph nil)
 170 (defvar xpm-anno nil)
 171 (defvar xpm-paint-string nil)
 172 (defvar xpm-xsize 1)
 173 (defvar xpm-ysize 1)
 174 (defvar xpm-num-colors 1)
 175 (defvar xpm-chars-per-pixel 1)
 176 (defvar xpm-color-start 1)
 177 (defvar xpm-body-start 1)
 178 (defvar xpm-body-end 1)
 179 (defvar xpm-palette nil)
 180 (defvar xpm-image-cache nil)
 181 (defvar xpm-always-update-image nil
 182   "If non-nil, update actual-size image after every click or drag movement.
 183 Otherwise, only update on button releases or when asked to.  This is slow.")
 184 (defvar xpm-max-palette-size 200
 185   "Maximum number of colors loaded into pallete.
 186 You can set this higher if you want, but each color takes up about 15 pixels,
 187 so the default will still take the full screen height on nearly all displays. Setting
 188 s this too high will make loading xpms with large numbers of colors slow.")
 189 (defvar xpm-show-characters nil)
 190
 191 (defvar xpm-toolbar '([ xpm-open-icon       toolbar-open                     t "Open a file" ]
 192                       [ xpm-save-icon       toolbar-save                     t "Save a file" ]
 193                       [ xpm-undo-icon       toolbar-undo                     t "Undo Edit" ]
 194                       [ xpm-new-image-icon  xpm-new-transparent              t "Create New XPM file" ]
 195                       [ xpm-sh-l-icon       (lambda () (interactive) (xpm-shift-image-left 1))            t "Shift left 1 pixel" ]
 196                       [ xpm-sh-r-icon       (lambda () (interactive) (xpm-shift-image-right 1))            t "Shift right 1 pixel" ]
 197                       [ xpm-sh-u-icon       (lambda () (interactive) (xpm-shift-image-up 1))               t "Shift up 1 pixel" ]
 198                       [ xpm-sh-d-icon       (lambda () (interactive) (xpm-shift-image-down 1))             t "Shift down 1 pixel" ]
 199                       [ xpm-r-cw-icon       xpm-rotate-image-cw              t "Rotate Clockwise 90 degrees." ]
 200                       [ xpm-r-ccw-icon      xpm-rotate-image-ccw             t "Rotate Counter-Clockwise 90 degrees." ]
 201                       [ xpm-m-vert-icon     xpm-mirror-image-vertical-axis   t "Mirror about Vertical axis" ]
 202                       [ xpm-m-horiz-icon    xpm-mirror-image-horizontal-axis t "Mirror about Horizontal axis" ]
 203                       [ xpm-enlarge-icon    xpm-enlarge                      t "Enlarge XPM height and/or width" ]
 204                       [ xpm-chars-icon      xpm-toggle-chars                 t "Show/Hide characters in the graphic." ]
 205                       [ xpm-pencil-icon     xpm-pencil-tool                  t "Switch to the pencil tool" ]
 206                       [ xpm-color-icon      xpm-eyedropper-tool              t "switch to the set color tool" ]
 207                       [ xpm-crop-icon       xpm-crop                         t "Mark with mouse, crop tool" ]
 208                       nil
 209                       [ xpm-help-icon       xpm-help-display                 t "List commands for xpm-editor" ]))
 210
 211
 212 (defun xpm-make-face (name)
 213   "Makes a face with name xpm-NAME, and colour NAME."
 214   (let ((face (make-face (intern (concat "xpm-" name))
 215                          "Temporary xpm-mode face" t)))
 216     (set-face-background face name)
 217     face))
 218
 219
 220 (defun xpm-init ()
 221   "Treat the current buffer as an xpm file and colorize it."
 222   (interactive)
 223   (require 'picture)
 224   (setq xpm-alpha-values nil)
 225   (setq xpm-pixel-values nil)
 226   (xpm-clear-extents)
 227   (setq xpm-palette nil)
 228   (message "Mapping Buffer...")
 229   (xpm-map-buffer)
 230   (message "Finding number of colors...")
 231   (save-excursion
 232     (goto-char xpm-color-start)
 233     (loop repeat xpm-num-colors
 234       do
 235       (xpm-parse-color "c")
 236       (forward-line)))
 237   (save-excursion
 238     (goto-char (point-min))
 239     (when (search-forward-regexp "\"XPMEXT *xemacs_alpha_values" nil t)
 240       (forward-line)
 241       (loop until (search-forward "\"XPMENDEXT" (point-at-eol) t)
 242         do (xpm-parse-color "a")
 243         (forward-line))))
 244   (if (featurep 'toolbar)
 245       (progn
 246         ;; Use `current-buffer', not `selected-frame', here.
 247         ;; Fixes bug where switching to another buffer causes its
 248         ;; full-width left toolbar to be truncated to the xpm-mode
 249         ;; palette (16 pixels).  Causes "window bounce" if sharing a
 250         ;; frame with a window displaying a buffer with a full-width
 251         ;; toolbar (suggested workaround: don't reset toolbar width
 252         ;; for palette).
 253         (set-specifier left-toolbar-width (cons (current-buffer) 16))
 254         (set-specifier left-toolbar (cons (current-buffer) xpm-palette))))
 255   (message "Parsing body...")
 256   (xpm-color-colors)
 257   (xpm-color-data)
 258   (xpm-color-alpha-extension)
 259   (message "Parsing body...done")
 260   (xpm-show-image))
 261
 262 (defun xpm-clear-extents ()
 263   "Clears all extents in the current buffer."
 264   (loop for ext being the extents of (current-buffer)
 265     do (delete-extent ext)))
 266
 267 (defun xpm-color-data ()
 268   "Make extents and color them for each pixel in the xpm."
 269   (interactive)
 270   (save-excursion
 271     (xpm-goto-body-line 0)
 272     (let (ext
 273           pixel-chars
 274           pixel-color)
 275       (loop until (search-forward "\"XPMEXT" (point-at-eol) t)
 276         while (< (+ (point) xpm-chars-per-pixel) (point-max))
 277         do
 278         (if (string-match "\"" (buffer-substring (point) (+ (point) xpm-chars-per-pixel)))
 279                                         ;If there is a quote in our next chunk
 280             (progn
 281               (search-forward "\"")
 282               (unless (string-match "^\\s-*\"$" (buffer-substring (point-at-bol) (point)))
 283                                         ; unless nothing but whitespace before quote
 284                 (forward-line)))
 285           (setq pixel-chars (buffer-substring (point) (+ (point) xpm-chars-per-pixel))
 286                 pixel-color (assoc pixel-chars xpm-pixel-values)
 287                 ext (make-extent (point) (+ (point) xpm-chars-per-pixel)))
 288           (if pixel-color
 289               (progn
 290                 (set-extent-face ext (cdr pixel-color)))
 291             (set-extent-face ext 'default))
 292           (forward-char xpm-chars-per-pixel))))))
 293
 294 (defun xpm-color-colors ()
 295   "Make extents and color them for every color defined in xpm"
 296   (interactive)
 297   (save-excursion
 298     (xpm-goto-color-def 0)
 299     (loop for colornum from 1 to xpm-num-colors
 300       do (search-forward-regexp (concat "\"\\(" (make-string xpm-chars-per-pixel ?.) "\\)") nil t)
 301       (let* ((pixel-color (assoc (match-string 1) xpm-pixel-values))
 302              (ext (make-extent (match-beginning 1) (match-end 1))))
 303         (if pixel-color
 304             (progn
 305               (set-extent-face ext (cdr pixel-color)))
 306           (set-extent-face ext 'default)))
 307       (forward-line))))
 308
 309 (defun xpm-color-alpha-extension ()
 310   "Make extents and color them for every color defined in xpm"
 311   (interactive)
 312   (save-excursion
 313     (goto-char (point-min))
 314     (when (search-forward-regexp "\"XPMEXT *xemacs_alpha_values" nil t)
 315       (forward-line)
 316       (loop until (search-forward "\"XPMENDEXT" (point-at-eol) t)
 317         do (search-forward-regexp (concat "\"\\(" (make-string xpm-chars-per-pixel ?.) "\\)") nil t)
 318         (let* ((pixel-color (assoc (match-string 1) xpm-pixel-values))
 319                (ext (make-extent (match-beginning 1) (match-end 1))))
 320           (if pixel-color
 321               (progn
 322                 (set-extent-face ext (cdr pixel-color)))
 323             (set-extent-face ext 'default)))
 324         (forward-line)))))
 325
 326 (defun xpm-make-solid-image-strings (width height)
 327   "Makes a pair of strings, which can be used to make a solid color xpm image.
 328 The first string consists of the header section, the values section, and
 329 the first part of the color section.  The second string is rest of the
 330 color section, and the image body.
 331 concat with a color name in between for a complete xpm file.
 332 Image body will be `width' x `height' size, and will use ?\\. as the
 333 symbol for the color. The return value is a list of the two strings.
 334 So you can, for instance, make a green glyph of this image as follows:
 335 \(let \(strings \(xpm-make-solid-image-strings\)\)
 336   \(make-glyph \(concat \(car strings\) \"green\" \(cadr strings\)\)\)\)"
 337   (unless (and (eq (car xpm-image-cache) width)
 338                (eq (cadr xpm-image-cache) height))
 339     (setq xpm-image-cache
 340           (cons width
 341                 (cons height
 342                       (list (concat "/* XPM */\nstatic char * solid[] = {\n\"" (format "%d %d" width height) " 1 1\",\n\". \tc ")
 343                             (concat (loop repeat height concat "\",\n\""  concat (make-string width ?.)) "\"};\n"))))))
 344   (cddr xpm-image-cache))
 345
 346 (defun xpm-store-alpha (str alpha)
 347   "Add STR to xpm-alpha-values."
 348   (setq xpm-alpha-values (cons (cons str alpha) xpm-alpha-values)))
 349
 350
 351 (defun xpm-add-alpha-extension ()
 352   "Adds an alpha extension section to the current xpm."
 353   (interactive)
 354   (save-excursion
 355     (goto-char (point-min))
 356     (unless (search-forward-regexp "XPMEXT\\s-*xemacs_alpha_values" nil t)
 357       (let (transparent-colors)
 358         (goto-char xpm-color-start)
 359         (setq transparent-colors
 360               (loop repeat xpm-num-colors
 361                 while (search-forward-regexp (concat "\"\\(" (make-string xpm-chars-per-pixel ?.) "\\).*?c\\s-*\\(none\\)\\(\\s-\\|\"\\)" ) nil t)
 362                 collect (match-string 1)))
 363
 364         (goto-char xpm-body-end)
 365         (forward-line)
 366         (insert "\"XPMEXT xemacs_alpha_values\",\n"
 367                 (loop for symbol in transparent-colors
 368                   concat "\""
 369                   concat symbol
 370                   concat "\ta 0\",\n")
 371                 "\"XPMENDEXT\",")
 372         (unless (search-forward "};" nil t)
 373           (search-backward "\",")
 374           (replace-match "\"};"))
 375         (backward-char)
 376         (while (search-backward "\"};" nil t)
 377           (replace-match "\","))))))
 378
 379 (defun xpm-make-two-char (&optional more-than-two)
 380   "Makes the current buffer use two chars per pixel.
 381 Will return nil if buffer was two chars per pixel or greater, t otherwise.
 382 With prefix argument, skips check for two chars."
 383   (interactive "p")
 384   (if (and (> xpm-chars-per-pixel 1) (not more-than-two))
 385       nil
 386     (goto-char xpm-color-start)
 387     (loop repeat xpm-num-colors
 388       do (search-forward-regexp (concat "\"" (make-string xpm-chars-per-pixel ?.)) nil t)
 389       (insert " ")
 390       (forward-line))
 391     (goto-char xpm-body-start)
 392     (search-forward "\"")
 393     (loop repeat xpm-ysize
 394       do (loop repeat xpm-xsize
 395            do (forward-char xpm-chars-per-pixel)
 396            (insert " "))
 397       (forward-line)
 398       (search-forward "\"" nil t))
 399     (goto-char xpm-body-end)
 400     (when (search-forward-regexp "XPMEXT\\s-*xemacs_alpha_values" nil t)
 401       (forward-line)
 402       (loop until (search-forward "XPMENDEXT" (point-at-eol) t)
 403         do (search-forward-regexp (concat "\"" (make-string xpm-chars-per-pixel ?.)) nil t)
 404         (insert " ")
 405         (forward-line)))
 406     (setq xpm-chars-per-pixel (1+ xpm-chars-per-pixel))
 407     (goto-char (point-min))
 408     (search-forward-regexp "\"\\s-*\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)" nil t)
 409     (replace-match (number-to-string xpm-chars-per-pixel) nil nil nil 4)
 410     t))
 411
 412
 413 (defun xpm-darken-image (&optional strength buffer)
 414   "Darkens xpm image in current buffer by 5%
 415 If `buffer' is specified, uses that buffer instead.
 416 If `strength' is specified, it should be a floating point number
 417 between 0.0 and 1.0."
 418   (interactive)
 419   (unless strength
 420     (setq strength 0.05))
 421   (save-excursion
 422     (let* ((target-buffer (or buffer (current-buffer)))
 423            (filter-buffer (get-buffer-create "*Filter Buffer*"))
 424            (xsize xpm-xsize)
 425            (ysize xpm-ysize)
 426            (filter-list))
 427       (set-buffer filter-buffer)
 428       (erase-buffer)
 429       (setq filter-list (xpm-make-solid-image-strings xsize ysize))
 430       (insert (car filter-list) "#000000000000" (cadr filter-list))
 431       (xpm-map-buffer)
 432       (xpm-add-alpha-extension)
 433       (xpm-add-alpha "." (format "%i" (* 65535 strength)))
 434       (xpm-make-two-char)
 435       (xpm-overlay-buffer target-buffer filter-buffer 0 0))))
 436
 437
 438
 439 (defun xpm-lighten-image (&optional strength buffer)
 440   "Lightens xpm image in current buffer by 5%
 441 If `buffer' is specified, uses that buffer instead."
 442   (interactive)
 443   (unless strength
 444     (setq strength 0.05))
 445   (save-excursion
 446     (let* ((target-buffer (or buffer (current-buffer)))
 447            (filter-buffer (get-buffer-create "*Filter Buffer*"))
 448            (xsize xpm-xsize)
 449            (ysize xpm-ysize)
 450            (filter-list))
 451       (set-buffer filter-buffer)
 452       (erase-buffer)
 453       (setq filter-list (xpm-make-solid-image-strings xsize ysize))
 454       (insert (car filter-list) "#ffffffffffff" (cadr filter-list))
 455       (xpm-map-buffer)
 456       (xpm-add-alpha-extension)
 457       (xpm-add-alpha "." (format "%i" (* 65535 strength)))
 458       (xpm-make-two-char)
 459       (xpm-overlay-buffer target-buffer filter-buffer 0 0))))
 460
 461
 462 (defun xpm-add-bevel (bevel-width &optional strength buffer)
 463   "Adds a bevel `bevel-width' wide around the image
 464 If `buffer' is specified, use that instead of the current-buffer.
 465 If `strength' is specified, use that for the maximum
 466 dimming/brightening. This applies light from the top-left corner."
 467   (interactive "nWidth of bevel? (in pixels): ")
 468   (unless strength
 469     (setq strength 0.10))
 470   (save-excursion
 471     (let* ((target-buffer (or buffer (current-buffer)))
 472            (filter-buffer (get-buffer-create "*Filter Buffer*"))
 473            (xsize xpm-xsize)
 474            (ysize xpm-ysize)
 475            (filter-list))
 476       (set-buffer filter-buffer)
 477       (erase-buffer)
 478       (setq filter-list (xpm-make-solid-image-strings xsize ysize))
 479       (insert (car filter-list) "#00000000ffff" (cadr filter-list))
 480       (xpm-map-buffer)
 481       (xpm-add-alpha-extension)
 482       (xpm-add-alpha "." "0")
 483       (xpm-make-two-char)
 484       (loop for x from 1 to bevel-width
 485         do
 486         (xpm-add-color (concat "l" (format "%x" (- bevel-width x))) "#ffffffffffff")
 487         (xpm-add-alpha (concat "l" (format "%x" (- bevel-width x))) (format "%i" (/ (* x 65535 strength) bevel-width)))
 488         (xpm-add-color (concat "d" (format "%x" (- bevel-width x))) "#000000000000")
 489         (xpm-add-alpha (concat "d" (format "%x" (- bevel-width x))) (format "%i" (/ (* x 65535 strength) bevel-width))))
 490       (goto-char xpm-body-start)
 491       (search-forward "\"")
 492       (loop for x from 0 to (1- bevel-width) do
 493         (goto-char xpm-body-start)
 494         (forward-line x)
 495         (search-forward "\"")
 496         (forward-char (* xpm-chars-per-pixel x))
 497         (loop repeat (- xpm-ysize (* 2 x))
 498           do (delete-char xpm-chars-per-pixel)
 499           (insert (concat "l" (format "%x" x)))
 500           (next-line 1)
 501           (backward-char xpm-chars-per-pixel)))
 502       (goto-char xpm-body-start)
 503       (loop for x from 0 to (1- bevel-width) do
 504         (search-forward ".")
 505         (backward-char)
 506         (loop repeat (- xpm-xsize (* 2 x) 1) do
 507           (delete-char xpm-chars-per-pixel)
 508           (insert (concat "l" (format "%x" x))))
 509         (forward-line))
 510       (goto-char xpm-body-end)
 511       (goto-char (point-at-bol))
 512       (loop for x from 0 to (1- bevel-width) do
 513         (search-forward ".")
 514         (backward-char)
 515         (loop repeat (- xpm-xsize (* 2 x) 1) do
 516           (delete-char xpm-chars-per-pixel)
 517           (insert (concat "d" (format "%x" x))))
 518         (forward-line -1))
 519       (loop for x from 0 to (1- bevel-width) do
 520         (goto-char xpm-body-start)
 521         (forward-line (1+ x))
 522         (search-forward "\"")
 523         (search-forward "\"")
 524         (backward-char (+ 1 (* xpm-chars-per-pixel (1+ x))))
 525         (loop repeat (- xpm-ysize (* 2 x) 1)
 526           do (delete-char xpm-chars-per-pixel)
 527           (insert (concat "d" (format "%x" x)))
 528           (next-line 1)
 529           (backward-char xpm-chars-per-pixel))) ;Finished constructing the filter
 530       (xpm-overlay-buffer target-buffer filter-buffer 0 0))))
 531
 532 (defun xpm-new-solid-color ( width height color )
 533   "Creates a new xpm file with a solid background color."
 534   (interactive "nWidth:
 535 nHeight: ")
 536   (save-excursion
 537     (let ((new-buffer (create-file-buffer "Untitled.xpm"))
 538           new-list)
 539       (unless color (setq color (facemenu-read-color "Background color (tab for list): ")))
 540       (switch-to-buffer new-buffer)
 541       (setq new-list (xpm-make-solid-image-strings width height))
 542       (insert (car new-list) color (cadr new-list))
 543       (xpm-map-buffer)
 544       (xpm-add-color " " "None")
 545       (xpm-add-alpha-extension)
 546       (xpm-add-alpha " " "0")
 547       (xpm-make-two-char)
 548       (xpm-mode))))
 549
 550 (defun xpm-new-transparent ( width height )
 551   "Creates a new xpm file with a transparent background."
 552   (interactive "nWidth:
 553 nHeight: ")
 554   (save-excursion
 555     (let ((new-buffer (create-file-buffer "Untitled.xpm"))
 556           new-list)
 557       (switch-to-buffer new-buffer)
 558       (setq new-list (xpm-make-solid-image-strings width height))
 559       (insert (car new-list) "None" (cadr new-list))
 560       (xpm-map-buffer)
 561       (xpm-add-color " " "None")
 562       (xpm-add-alpha-extension)
 563       (xpm-make-two-char)
 564       (xpm-mode))))
 565
 566
 567 (defun xpm-new-vertical-gradient ( width height &optional topcolor bottomcolor )
 568   "Creates a new xpm file with a vetical gradient background."
 569   (interactive "nWidth:
 570 nHeight: ")
 571   (save-excursion
 572     (unless topcolor (setq topcolor (facemenu-read-color "Top color (tab for list): ")))
 573     (unless bottomcolor (setq bottomcolor (facemenu-read-color "Bottom color (tab for list): ")))
 574     (let  ((new-buffer (create-file-buffer "Untitled.xpm"))
 575            (topcc (color-rgb-components (make-color-specifier topcolor)))
 576            (bottomcc (color-rgb-components (make-color-specifier bottomcolor)))
 577            (newcc '(0 0 0))
 578            (color-list nil)
 579            new-str
 580            new-list)
 581       (switch-to-buffer new-buffer)
 582       (setq new-list (xpm-make-solid-image-strings width height))
 583       (insert (car new-list) "None" (cadr new-list))
 584       (xpm-init)
 585       (xpm-add-color " " "None")
 586       (xpm-add-alpha-extension)
 587       (xpm-make-two-char)
 588       (loop for x from 0 to (1- height) do
 589         (setq newcc (mapcar* (lambda (bottom top) (+ (/ (* x (- bottom top)) (1- height)) top)) topcc bottomcc))
 590         (setq new-str (xpm-generate-str))
 591         (xpm-add-color new-str (apply 'format "#%04x%04x%04x" newcc))
 592         (xpm-add-alpha new-str "65536")
 593         (push new-str color-list))
 594       (goto-char xpm-body-start)
 595       (loop for x from 0 to (1- height) do
 596         (search-forward "\"")
 597         (loop repeat width do
 598           (delete-char xpm-chars-per-pixel)
 599           (insert (nth x color-list)))
 600         (forward-line))
 601       (xpm-mode))))
 602
 603 (defun xpm-new-vertical-twosided-gradient (width height &optional endcolor centercolor)
 604   "Creates a new xpm file with a vertical gradient background."
 605   (interactive "nWidth:
 606 nHeight: ")
 607   (save-excursion
 608     (unless endcolor (setq endcolor (facemenu-read-color "End color (tab for list): ")))
 609     (unless centercolor (setq centercolor (facemenu-read-color "Center color (tab for list): ")))
 610     (let  ((new-buffer (create-file-buffer "Untitled.xpm"))
 611            (endcc (color-rgb-components (make-color-specifier endcolor)))
 612            (centercc (color-rgb-components (make-color-specifier centercolor)))
 613            (newcc '(0 0 0))
 614            (color-list nil)
 615            new-str
 616            new-list)
 617       (switch-to-buffer new-buffer)
 618       (setq new-list (xpm-make-solid-image-strings width height))
 619       (insert (car new-list) "None" (cadr new-list))
 620       (xpm-init)
 621       (xpm-add-color " " "None")
 622       (xpm-add-alpha-extension)
 623       (xpm-make-two-char)
 624       (loop for x from 0 to (1- (/ (1+ height) 2)) do
 625         (setq newcc (mapcar* (lambda (center end) (+ (/ (* x (- center end)) (1- (/ (1+ height) 2 ))) end)) endcc centercc))
 626         (setq new-str (xpm-generate-str))
 627         (xpm-add-color new-str (apply 'format "#%04x%04x%04x" newcc))
 628         (xpm-add-alpha new-str "65536")
 629         (push new-str color-list))
 630       (goto-char xpm-body-start)
 631       (loop for x from 0 to (1- (/ (1+ height) 2)) do
 632         (search-forward "\"")
 633         (loop repeat width do
 634           (delete-char xpm-chars-per-pixel)
 635           (insert (nth x color-list)))
 636         (forward-line))
 637       (if (oddp height)
 638           (forward-line -1))
 639       (loop for x from 0 to (1- (/ (1+ height) 2)) do
 640         (search-forward "\"")
 641         (loop repeat width do
 642           (delete-char xpm-chars-per-pixel)
 643           (insert (nth (- (1- (/ (1+ height) 2)) x ) color-list)))
 644         (forward-line))
 645       (xpm-mode))))
 646
 647 (defun xpm-new-diagonal-gradient ( &optional width height topcolor bottomcolor)
 648   "Creates a new xpm file with a diagonal gradient background."
 649   (interactive "nWidth:
 650 nHeight: ")
 651   (save-excursion
 652     (unless topcolor (setq topcolor (facemenu-read-color "Top left color (tab for list): ")))
 653     (unless bottomcolor (setq bottomcolor (facemenu-read-color "Bottom right color (tab for list): ")))
 654     (let  ((new-buffer (create-file-buffer "Untitled.xpm"))
 655            (topcc (color-rgb-components (make-color-specifier topcolor)))
 656            (bottomcc (color-rgb-components (make-color-specifier bottomcolor)))
 657            (newcc '(0 0 0))
 658            (color-list nil)
 659            (colors (+ height width -1))
 660            new-str
 661            new-list)
 662       (switch-to-buffer new-buffer)
 663       (setq new-list (xpm-make-solid-image-strings width height))
 664       (insert (car new-list) "None" (cadr new-list))
 665       (xpm-init)
 666       (xpm-add-color " " "None")
 667       (xpm-add-alpha-extension)
 668       (xpm-make-two-char)
 669       (loop for x from 0 to (1- colors) do
 670         (setq newcc (mapcar* (lambda (bottom top) (+ (/ (* x (- bottom top)) (1- colors)) top)) topcc bottomcc))
 671         (setq new-str (xpm-generate-str))
 672         (xpm-add-color new-str (apply 'format "#%04x%04x%04x" newcc))
 673         (xpm-add-alpha new-str "65536")
 674         (push new-str color-list))
 675       (goto-char xpm-body-start)
 676       (search-forward "\"")
 677       (loop for x from 0 to (1- colors) do
 678         (loop do (delete-char xpm-chars-per-pixel)
 679           (insert (nth x color-list))
 680           until (eq (line-number) (line-number xpm-body-start))
 681           until (eq (char-after) ?\")
 682           do (previous-line 1))
 683         (loop do (next-line 1)
 684           (backward-char xpm-chars-per-pixel)
 685           until (eq (line-number) (line-number xpm-body-end))
 686           until (eq (char-before) ?\")))
 687       (xpm-mode))))
 688
 689
 690 (defun xpm-pythag (x y)
 691   "Calculates the square root of the sum of the squares of x and y"
 692   (sqrt (+ (* x x) (* y y))))
 693
 694
 695 (defun xpm-new-circles-gradient (&optional width height centercolor edgecolor centerx centery)
 696   "Creates a new xpm file with a circular gradient about centerx and centery."
 697   (interactive "nWidth:
 698 nHeight:
 699 nCenter X:
 700 nCenter Y: ")
 701   (unless centercolor (setq centercolor (facemenu-read-color "Center color (tab for list): ")))
 702   (unless edgecolor (setq edgecolor (facemenu-read-color "Edge color (tab for list): ")))
 703   (save-excursion
 704     (let ((new-buffer (create-file-buffer "Untitled.xpm"))
 705           (edgecc (color-rgb-components (make-color-specifier edgecolor)))
 706           (centercc (color-rgb-components (make-color-specifier centercolor)))
 707           (newcc '(0 0 0))
 708           (color-list nil)
 709           (colors (ceiling (* 2 (max (xpm-pythag (- width centerx) (- height centery))
 710                                      (xpm-pythag (- 0 centerx) (- height centery))
 711                                      (xpm-pythag (- width centerx) (- 0 centery))
 712                                      (xpm-pythag (- 0 centerx) (- 0 centery))))))
 713           new-str
 714           new-list)
 715       (switch-to-buffer new-buffer)
 716       (setq new-list (xpm-make-solid-image-strings width height))
 717       (insert (car new-list) "None" (cadr new-list))
 718       (xpm-init)
 719       (xpm-add-color " " "None")
 720       (xpm-add-alpha-extension)
 721       (xpm-make-two-char)
 722       (loop for x from 0 to colors      do
 723         (setq newcc (mapcar* (lambda (edge center) (+ (/ (* x (- center edge)) colors) edge)) edgecc centercc))
 724         (setq new-str (xpm-generate-str))
 725         (xpm-add-color new-str (apply 'format "#%04x%04x%04x" newcc))
 726         (xpm-add-alpha new-str "65536")
 727         (push new-str color-list))
 728       (goto-char xpm-body-start)
 729       (search-forward "\"")
 730       (loop for y from 0 to (1- height) do
 731         (loop for x from 0 to (1- width) do
 732           (delete-char xpm-chars-per-pixel)
 733           (insert (nth (round (* 2 (xpm-pythag (- x centerx) (- y centery)))) color-list)))
 734         (forward-line)
 735         (search-forward "\"" nil t))
 736       (xpm-mode))))
 737
 738
 739 (defun xpm-new-circles-from-center-gradient (&optional width height centercolor edgecolor)
 740   "Creates a new xpm file with a circular gradient about the center of the image."
 741   (interactive "nWidth:
 742 nHeight: ")
 743   (xpm-new-circles-gradient width height nil nil (/ width 2) (/ height 2)))
 744
 745 (defun xpm-new-squares-gradient (&optional width height centercolor edgecolor centerx centery)
 746   "Creates a new xpm file with a square gradient about centerx and centery."
 747   (interactive "nWidth:
 748 nHeight:
 749 i
 750 i
 751 nCenter X:
 752 nCenter Y: ")
 753   (save-excursion
 754     (unless centercolor (setq centercolor (facemenu-read-color "Center color (tab for list): ")))
 755     (unless edgecolor (setq edgecolor (facemenu-read-color "Edge color (tab for list): ")))
 756     (let ((new-buffer (create-file-buffer "Untitled.xpm"))
 757           (edgecc (color-rgb-components (make-color-specifier edgecolor)))
 758           (centercc (color-rgb-components (make-color-specifier centercolor)))
 759           (newcc '(0 0 0))
 760           (color-list nil)
 761           (colors (apply 'max (mapcar 'abs (list (- width centerx) (- height centery) (- 0 centerx) (- 0 centery)))))
 762           new-str
 763           new-list)
 764       (switch-to-buffer new-buffer)
 765       (setq new-list (xpm-make-solid-image-strings width height))
 766       (insert (car new-list) "None" (cadr new-list))
 767       (xpm-init)
 768       (xpm-add-color " " "None")
 769       (xpm-add-alpha-extension)
 770       (xpm-make-two-char)
 771       (loop for x from 0 to colors      do
 772         (setq newcc (mapcar* (lambda (edge center) (+ (/ (* x (- center edge)) colors) edge)) edgecc centercc))
 773         (setq new-str (xpm-generate-str))
 774         (xpm-add-color new-str (apply 'format "#%04x%04x%04x" newcc))
 775         (xpm-add-alpha new-str "65536")
 776         (push new-str color-list))
 777       (goto-char xpm-body-start)
 778       (search-forward "\"")
 779       (loop for y from 0 to (1- height) do
 780         (loop for x from 0 to (1- width) do
 781           (delete-char xpm-chars-per-pixel)
 782           (insert (nth (max (abs (- x centerx)) (abs (- y centery))) color-list)))
 783         (forward-line)
 784         (search-forward "\"" nil t))
 785       (xpm-mode))))
 786
 787 (defun xpm-new-squares-from-center-gradient (&optional width height centercolor edgecolor)
 788   "Creates a new xpm file with a square gradient about the center of the image."
 789   (interactive "nWidth:
 790 nHeight: ")
 791   (xpm-new-squares-gradient width height nil nil (/ width 2) (/ height 2)))
 792
 793 (defun xpm-overlay-alpha (overstr understr)
 794   "Overlays `overstr' and `understr' colors.
 795 Returns a list of three elements: a new str (made with `xpm-generate-str'),
 796 a new face, and a new alpha value. Note that the display ignores alpha layer."
 797   (let (overface  underface
 798                   overalpha underalpha
 799                   overcc    undercc
 800                   newstr    newface
 801                   newcc     newalpha)
 802     (setq overface   (cdr (assoc overstr xpm-pixel-values))
 803           underface  (cdr (assoc understr xpm-pixel-values))
 804           overalpha  (string-to-number (or (cdr (assoc overstr xpm-alpha-values))
 805                                            "65536"))
 806           underalpha (string-to-number (or (cdr (assoc understr xpm-alpha-values))
 807                                            "65536"))
 808           overcc     (color-rgb-components (face-background overface))
 809           undercc    (color-rgb-components (face-background underface))
 810           newcc      '(0 0 0))
 811     (setf (car newcc) (floor (/ (+ (* (car overcc) (float overalpha))
 812                                    (/ (* (- 65536.0 overalpha) (* (car undercc) (float underalpha))) 65536)) 65536)))
 813     (setf (cadr newcc) (floor (/ (+ (* (cadr overcc) (float overalpha))
 814                                     (/ (* (- 65536.0 overalpha) (* (cadr undercc) (float underalpha))) 65536)) 65536)))
 815     (setf (caddr newcc) (floor (/ (+ (* (caddr overcc) (float overalpha))
 816                                      (/ (* (- 65536.0 overalpha) (* (caddr undercc) (float underalpha))) 65536)) 65536)))
 817     (setf newalpha (number-to-string (floor (+ overalpha (/ (* underalpha (- 65336.0 overalpha)) 65536)))))
 818     (setq newface (xpm-make-face (apply 'format "#%04x%04x%04x" newcc)))
 819     (if (and (rassoc newalpha xpm-alpha-values)
 820              (equal (car (rassoc newalpha xpm-alpha-values))
 821                     (car (rassoc newface xpm-pixel-values))))
 822         (setq newstr (car (rassoc newalpha xpm-alpha-values)))
 823       (setq newstr (xpm-generate-str))
 824       (xpm-add-color newstr (apply 'format "#%04x%04x%04x" newcc))
 825       (xpm-add-alpha newstr newalpha))
 826     (list newstr newface newalpha)))
 827
 828 (defun xpm-merge-in-color-list (pixel-values alpha-values)
 829   "Merges another set of xpm faces and alpha values into this one, and updates the buffer to match."
 830   (let ((new-colors nil)
 831         (rename-colors nil)
 832         xpmstr
 833         alpha)
 834     (loop for (str . face) in pixel-values
 835       do
 836       (setq alpha (cdr (assoc str alpha-values)))
 837       (setq xpmstr (car (rassoc face xpm-pixel-values)))
 838       (if (and xpmstr                   ;If the face exists locally
 839                (or (and (not alpha)
 840                         (not (assoc xpmstr xpm-alpha-values))) ; and either we both don't specify an alpha
 841                    (equal alpha (assoc xpmstr xpm-alpha-values)))) ;   or our alphas are identical.
 842           (unless (equal str xpmstr)
 843             (unless (member (cons str xpmstr) rename-colors)
 844               (setq rename-colors (cons (cons str xpmstr) rename-colors))))
 845         (setq new-colors (cons (cons str (cons face (or alpha "65536"))) new-colors))))
 846     (loop for (oldstr face . alpha) in new-colors
 847       do
 848       (setq xpmstr (xpm-generate-str))
 849       (xpm-add-color xpmstr (apply 'format  "#%04x%04x%04x" (color-rgb-components (face-background face))))
 850                           ;;;;Long and slow; Maybe there is a better way?
 851       (xpm-add-alpha xpmstr alpha)
 852       (setq rename-colors (cons (cons oldstr xpmstr) rename-colors)))
 853     rename-colors))
 854
 855 (defun xpm-rename-colors (rename-list image-list)
 856   "Renames all the pixels in `image-list' according to `rename-list'.
 857 `image-list' is of the format produced by (`xpm-read-image-in').
 858 `rename-list' is of the format produced by  (`xpm-merge-in-color-list').
 859 Returns new image-list."
 860   (let ((middle-list nil)
 861         middle)
 862     (setq middle-list (loop for (first . last) in rename-list ; Generate a middle stage with unique strs
 863                         for x from 1 to 10000
 864                         for y = "0" then (number-to-string x)
 865                         with string = (make-string xpm-chars-per-pixel ?X)
 866                         do (setq middle (concat string y))
 867                         collect (cons first middle)))
 868     (loop for row in
 869       (loop for row in image-list
 870         collect (loop for pixel in row
 871                   collect (or (cdr (assoc pixel middle-list))
 872                               pixel)))
 873       collect (loop for pixel in row
 874                 collect (or (cdr (assoc (car (rassoc pixel middle-list)) rename-list))
 875                             pixel)))))
 876
 877
 878 (defun xpm-overlay-image (image-list xoffset yoffset)
 879   "Overlays the image described by image-list onto the current-xpm file.
 880 Requires the colors to already be identical between the two images"
 881   (save-excursion
 882     (let ((image-xsize (length (car image-list)))
 883           (image-ysize (length image-list))
 884           newface)
 885       (xpm-goto-body-line yoffset)
 886       (search-forward "\"")
 887       (forward-char (* xpm-chars-per-pixel xoffset))
 888       (loop for y from 0 to (1- image-ysize)
 889         while (< (+ y yoffset) xpm-ysize)
 890         do (loop for x from 0 to (1- image-xsize)
 891              while (< (+ x xoffset) xpm-xsize)
 892              do
 893              (setq newface (xpm-overlay-alpha (nth x (nth y image-list))
 894                                               (buffer-substring (point) (+ xpm-chars-per-pixel (point)))))
 895              (delete-char xpm-chars-per-pixel)
 896              (insert (car newface)))
 897         (forward-line)
 898         (search-forward "\"")
 899         (forward-char (* xpm-chars-per-pixel xoffset))))
 900     (xpm-init)))
 901
 902 (defun xpm-overlay-buffer (target-buffer overlay-buffer xoff yoff)
 903   "Overlays an xpm in `overlay-buffer' on the xpm in `target-buffer'
 904 with x and y as offsets from upper left corner."
 905   (interactive "bTarget Buffer:
 906 bOverlay Buffer:
 907 nOffset in x direction:
 908 nOffset in y direction: ")
 909   (save-excursion
 910     (set-buffer overlay-buffer)
 911     (xpm-init)
 912     (let ((overlay-image-list (xpm-read-pixels-in))
 913           (overlay-pixel-values xpm-pixel-values)
 914           (overlay-alpha-values xpm-alpha-values))
 915       (set-buffer target-buffer)
 916       (xpm-init)
 917       (message "Overlaying images...")
 918       (xpm-overlay-image
 919        (xpm-rename-colors (xpm-merge-in-color-list overlay-pixel-values overlay-alpha-values)
 920                           overlay-image-list)
 921        xoff yoff))
 922     (message "Removing duplicate colors...")
 923     (xpm-replace-duplicate-colors)
 924     (message "Removing unused colors...")
 925     (xpm-remove-unused-colors)
 926     (message "Removing unused colors...Done")
 927     (xpm-init)))
 928
 929
 930 (defun xpm-remove-unused-colors ()
 931   "Removes unused color definitions from current buffer."
 932   (interactive)
 933   (save-excursion
 934     (let ((used-colors nil))
 935       (goto-char xpm-body-start)
 936       (search-forward "\"")
 937       (setq used-colors
 938             (loop repeat xpm-ysize
 939               append (loop repeat xpm-xsize
 940                        collect (buffer-substring (point) (+ (point) xpm-chars-per-pixel))
 941                        do (forward-char xpm-chars-per-pixel))
 942               do (forward-line)
 943               (search-forward "\"" nil t)))
 944       (goto-char xpm-color-start)
 945       (setq xpm-num-colors
 946             (loop until (eq (line-number) (line-number xpm-body-start))
 947               do (search-forward-regexp (concat "\"\\("  (make-string xpm-chars-per-pixel ?.) "\\)"))
 948               count (member (match-string 1) used-colors)
 949               do
 950               (if (member (match-string 1) used-colors)
 951                   (forward-line)
 952                 (delete-region (point-at-bol) (point-at-bol 2)))))
 953       (goto-char (point-min))
 954       (search-forward-regexp "\"\\s-*\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)" nil t)
 955       (replace-match (number-to-string xpm-num-colors) nil nil nil 3)
 956       (goto-char xpm-body-end)
 957       (when (search-forward-regexp "\"XPMEXT *xemacs_alpha_value" nil t)
 958         (forward-line)
 959         (loop until (search-forward "XPMENDEXT" (point-at-eol) t)
 960           do (search-forward-regexp (concat "\"\\("  (make-string xpm-chars-per-pixel ?.) "\\)"))
 961           (if (member (match-string 1) used-colors)
 962               (forward-line)
 963             (delete-region (point-at-bol) (point-at-bol 2)))))
 964       (xpm-init))))
 965
 966 (defun xpm-find-duplicate-colors (&optional no-alpha)
 967   "Finds all colors with identical values, and returns a list of suggested conversions.
 968 Pays attention to the alpha extension. If `no-color' is non-nil, ignore alpha extension.
 969 This function tests on the basis of the color name; it is possible for two colors with
 970 different names, but the same RGB values to exist."
 971   (let ((color-changes nil)
 972         (known-colors nil)
 973         (known-alphas nil)
 974         (kept-colors nil)
 975         color-key
 976         color-alpha)
 977     (goto-char xpm-color-start)
 978     (loop until (eq (line-number) (line-number xpm-body-start))
 979       do (search-forward-regexp (concat "\"\\("  (make-string xpm-chars-per-pixel ?.) "\\).*?c\\s-+\\(.*?\\)\\(\\s-\\|\"\\)"))
 980       (setq known-colors (cons (cons (match-string 1) (match-string 2)) known-colors))
 981       (forward-line))
 982     (when (and (not no-alpha)
 983                (search-forward-regexp "\"XPMEXT\\s-*xemacs_alpha_values" nil t))
 984       (forward-line)
 985       (loop until (search-forward "XPMENDEXT" (point-at-eol) t)
 986         do (goto-char (point-at-bol))
 987         (search-forward-regexp (concat "\"\\("  (make-string xpm-chars-per-pixel ?.) "\\).*?a\\s-+\\(.*?\\)\\(\\s-\\|\"\\)"))
 988         (unless (assoc (match-string 1) known-alphas)
 989           (setq known-alphas (cons (cons (match-string 1) (match-string 2)) known-alphas)))
 990         (forward-line)))
 991     (setq color-changes (loop for (str . color) in known-colors
 992                           do (setq color-alpha (or (cdr (assoc str known-alphas))
 993                                                    "65536"))
 994                           collect (if (setq color-key (car (rassoc (concat color-alpha "-" color) kept-colors)))
 995                                       (cons str color-key)
 996                                     (setq kept-colors (cons (cons str (concat color-alpha "-" color )) kept-colors))
 997                                     nil)))
 998     (setq color-changes (remove-if-not 'identity color-changes))))
 999
1000 (defun xpm-replace-duplicate-colors ()
1001   "Replaces all instances of one color with another in the image and removes the original color.
1002 This also modifies the alpha extension. "
1003   (interactive)
1004   (save-excursion
1005     (let ((color-changes (xpm-find-duplicate-colors))
1006           color-found)
1007       (goto-char xpm-body-start)
1008       (loop repeat xpm-ysize
1009         do (search-forward "\"")
1010         (loop repeat xpm-xsize
1011           do (if (setq color-found (assoc (buffer-substring (point) (+ (point) xpm-chars-per-pixel)) color-changes))
1012                  (progn (delete-char xpm-chars-per-pixel)
1013                         (insert (cdr color-found)))
1014                (forward-char xpm-chars-per-pixel)))
1015         (forward-line))
1016       (goto-char xpm-color-start)
1017       (loop until (eq (line-number) (line-number xpm-body-start))
1018         do (search-forward-regexp (concat "\"\\("  (make-string xpm-chars-per-pixel ?.) "\\)"))
1019         (if (assoc (match-string 1) color-changes)
1020             (delete-region (point-at-bol) (point-at-bol 2))
1021           (forward-line)))
1022       (when (search-forward-regexp "\"XPMEXT\\s-*xemacs_alpha_values" nil t)
1023         (forward-line)
1024         (loop until (search-forward "XPMENDEXT" (point-at-eol) t)
1025           do (search-forward-regexp (concat "\"\\("  (make-string xpm-chars-per-pixel ?.) "\\).*?a"))
1026           (if (assoc (match-string 1) color-changes)
1027               (delete-region (point-at-bol) (point-at-bol 2))
1028             (forward-line))))
1029       (setq xpm-num-colors (- xpm-num-colors (length color-changes)))
1030       (goto-char (point-min))
1031       (search-forward-regexp "\"\\s-*\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)" nil t)
1032       (replace-match (number-to-string xpm-num-colors) nil nil nil 3)))
1033   (xpm-init))
1034
1035 (defun xpm-store-color (str color)
1036   "Add STR to xpm-pixel-values with a new face set to background COLOR
1037 if STR already has an entry, the existing face will be used, with the
1038 new color replacing the old (on the display only, not in the xpm color
1039 defs!)"
1040   (let (new-face)
1041     (setq new-face (xpm-make-face color))
1042     (if xpm-show-characters
1043         (let ((ccc (color-rgb-components (make-color-specifier color))))
1044           (if ccc
1045               (if (or (or (> (elt ccc 0) 32767) ; If any color component is greater than 50%
1046                           (> (elt ccc 1) 32767)) ; Maybe some more gradual change could be used, to better preserve appearance?
1047                       (> (elt ccc 2) 32767))
1048                   (set-face-foreground new-face "black")
1049                 (set-face-foreground new-face "white"))))
1050       (set-face-foreground new-face color))
1051     (setq xpm-pixel-values (cons (cons str new-face) xpm-pixel-values))
1052     (if (featurep 'toolbar)
1053         (when (< (length xpm-palette) xpm-max-palette-size)
1054           (let ((strings (xpm-make-solid-image-strings 12 12)))
1055             (setq xpm-palette
1056                   (cons (vector
1057                          (list (make-glyph (concat (car strings) color (cadr strings))))
1058                          ;; Major cool things with quotes..... (setq str "a " color "green")
1059                          (`(lambda (event)
1060                              (interactive "e")
1061                              (xpm-toolbar-select-colour event (,str) (,color))))
1062                          t
1063                          color) xpm-palette)))))))
1064
1065 (defun xpm-parse-color (class)
1066   "Parse xpm color string from current line and set the color.
1067 `class' is the string that indicates the proper colors (\"c\" would be standard color)"
1068   (interactive)
1069   (save-excursion
1070     (goto-char (point-at-bol))
1071     (if (re-search-forward
1072          ;; Generate a regexp on the fly
1073          (concat "\"\\(" (make-string xpm-chars-per-pixel ?.) "\\)" ; chars
1074                  ".*?"                  ; other classes
1075                  class                  ; our class
1076                  "\\s-+\\(.+?\\)\\(\\s-\\|\"\\)") ;Simplified by non-greedy operators.
1077          (point-at-eol) t)
1078         (if (equal class "a")
1079             (xpm-store-alpha (match-string 1) (match-string 2))
1080           (xpm-store-color (match-string 1) (match-string 2)))
1081       (error (concat "Unable to parse color on line " (number-to-string (line-number)))))))
1082
1083 (defun xpm-generate-str ()
1084   "Generates a unique color string in the current xpm's color-space.
1085 Returns nil if space is full."
1086   (let ((valid-chars "1234567890-=qwertyuiop[]asdfghjkl;'zxcvbnm,./`!@#$%^&*()_+QWERTYUIOP{|ASDFGHJKL:ZXCVBNM<>?~"))
1087                                         ;Technically, almost all control characters will also work just fine; unfortunately
1088                                         ;they will display as two characters wide per char, and mess with your columns dreadfully.
1089     (if (>= xpm-num-colors
1090             (loop repeat xpm-chars-per-pixel
1091               for x = (length valid-chars) then (* x (length valid-chars))
1092               finally return x))
1093         nil
1094       (let ((newstr (make-string xpm-chars-per-pixel ?1)))
1095         (loop while (assoc newstr xpm-pixel-values)
1096           do (setq newstr (loop repeat xpm-chars-per-pixel
1097                             concat (char-to-string (elt valid-chars (random* (length valid-chars)))))))
1098                                         ;If xpm is written by hand, this will probably be quite efficient.
1099         newstr))))
1100
1101 (defun xpm-add-color (str color)
1102   "add a color to an xpm's list of color defs"
1103   (interactive "sPixel character:
1104 sPixel color (any valid color string):")
1105   (save-excursion
1106     (xpm-goto-color-def xpm-num-colors)
1107     (insert-before-markers (format "\"%s\tc %s\",\n" str color))
1108     (forward-line -1)
1109     (xpm-parse-color "c")
1110     (goto-char (point-min))
1111     (incf xpm-num-colors)
1112     (search-forward-regexp "\"\\s-*\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)" nil t)
1113     (replace-match (int-to-string xpm-num-colors) nil nil nil 3)))
1114
1115 (defun xpm-add-alpha (str alpha)
1116   "add an alpha to the xpm alpha extension list"
1117   (interactive "sPixel character:
1118 nPixel alpha (any number from 0-65536):")
1119   (save-excursion
1120     (xpm-goto-color-def xpm-num-colors)
1121     (unless (search-forward-regexp "\"XPMEXT\\s-*xemacs_alpha_values" nil t)
1122       (error "No alpha extention in this XPM."))
1123     (forward-line)
1124     (insert-before-markers (format "\"%s\ta %s\",\n" str alpha))
1125     (forward-line -1)
1126     (xpm-parse-color "a")))
1127
1128 (defun xpm-map-buffer ()
1129   "Finds the start and end positions of each section, and sets the markers accordingly.
1130 This function sets `xpm-color-start', `xpm-body-start', and `xpm-body-end' to markers at
1131 the appropriate locations. Note that this function places xpm-color-start at the
1132 beginning of the first color definition line, xpm-body-start at the beginning of the
1133 first body line and xpm-body-end at the end of the last body string."
1134   (save-excursion
1135     (goto-char (point-min))
1136     (unless (search-forward-regexp "\"\\s-*\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)" nil t)
1137       (error "Cannot parse xpm file: can't find size string!"))
1138     (setq xpm-chars-per-pixel (string-to-int (match-string 4))
1139           xpm-num-colors      (string-to-int (match-string 3))
1140           xpm-xsize           (string-to-int (match-string 1))
1141           xpm-ysize           (string-to-int (match-string 2)))
1142     (forward-line)
1143     (while (and (not (eobp)) (not (looking-at "\\s-*\"")))
1144       (forward-line))
1145     (setq xpm-color-start (point-marker))
1146     (forward-line xpm-num-colors)
1147     (search-forward "\"")
1148     (backward-char)
1149     (setq xpm-body-start (point-marker))
1150     (forward-line (1- xpm-ysize))
1151     (search-forward "\"")
1152     (search-forward "\"")
1153     (setq xpm-body-end (point-marker))))
1154
1155
1156 (defun xpm-shift-image ( x y )
1157   "Shifts xpm down and to the right by `x' and `y'.
1158 Negative values mean up and to the left, respectively."
1159   (interactive "nNumber of pixels to shift right:
1160 nNumber of pixels to shift down: ")
1161   (if (> x 0)
1162       (xpm-shift-image-right x)
1163     (xpm-shift-image-left (- x)))
1164   (if (> y 0)
1165       (xpm-shift-image-down y)
1166     (xpm-shift-image-up (- y))))
1167
1168
1169 (defun xpm-shift-image-left ( &optional pixels )
1170   "Shifts the xpm left `pixels', defaults to one.
1171 Fills empty column(s) with removed columns."
1172   (interactive)
1173   (unless pixels
1174     (setq pixels (string-to-number (read-string "Number of pixels to shift left (1): " nil nil "1"))))
1175   (save-excursion
1176     (xpm-goto-body-line 0)
1177     (loop repeat xpm-ysize
1178       do
1179       (search-forward "\"")
1180       (delete-char (* xpm-chars-per-pixel pixels) t)
1181       (search-forward "\"")
1182       (forward-char -1)
1183       (yank)
1184       (forward-line)))
1185   (xpm-init))
1186
1187 (defun xpm-shift-image-right ( &optional pixels )
1188   "Shifts the xpm right `pixels', defaults to one.
1189 Fills empty column(s) with removed columns."
1190   (interactive)
1191   (unless pixels
1192     (setq pixels (string-to-number (read-string "Number of pixels to shift right (1): " nil nil "1"))))
1193   (save-excursion
1194     (xpm-goto-body-line 0)
1195     (loop repeat xpm-ysize
1196       do
1197       (search-forward "\"")
1198       (search-forward "\"")
1199       (forward-char -1)
1200       (delete-backward-char (* xpm-chars-per-pixel pixels) t)
1201       (search-backward "\"")
1202       (forward-char 1)
1203       (yank)
1204       (forward-line)))
1205   (xpm-init))
1206
1207 (defun xpm-shift-image-up ( &optional pixels )
1208   "Shifts the xpm up `pixels', defaults to one.
1209 Fills empty row(s) with removed rows."
1210   (interactive)
1211   (unless pixels
1212     (setq pixels (string-to-number (read-string "Number of pixels to shift up (1): " nil nil "1"))))
1213   (save-excursion
1214     (xpm-goto-body-line 0)
1215     (kill-entire-line pixels)
1216     (goto-char xpm-body-end)
1217     (insert ",\n")
1218     (yank)
1219     (search-backward-regexp ",\\s-*")
1220     (replace-match ""))
1221   (xpm-init))
1222
1223 (defun xpm-shift-image-down ( &optional pixels )
1224   "Shifts the xpm down `pixels', defaults to one.
1225 Fills empty row(s) with removed rows."
1226   (interactive)
1227   (unless pixels
1228     (setq pixels (string-to-number (read-string "Number of pixels to shift down (1): " nil nil "1"))))
1229   (save-excursion
1230     (goto-char xpm-body-end)
1231     (insert ",\n")
1232     (kill-entire-line (* -1 pixels))
1233     (search-backward-regexp ",\\s-*\n")
1234     (replace-match "")
1235     (goto-char xpm-body-start)
1236     (yank))
1237   (xpm-init))
1238
1239 (defun xpm-read-pixels-in ()
1240   "Reads the pixels out of the image into a nested list format.
1241 format is: (( row_1 )
1242             ( row_2 )
1243             ( row_3 ))"
1244   (let (xpm-pixels)
1245     (save-excursion
1246       (goto-char xpm-body-start)
1247       (setq xpm-pixels
1248             (loop repeat xpm-ysize
1249               do (search-forward "\"")
1250               collect (loop repeat xpm-xsize
1251                         collect (buffer-substring (point) (+ (point) xpm-chars-per-pixel))
1252                         do (forward-char xpm-chars-per-pixel))
1253               do (forward-line))))
1254     xpm-pixels))
1255
1256
1257 (defun xpm-rotate-image-cw ()
1258   "Rotates the image 90 degrees clockwise.
1259 Modifies the x and y size in the image."
1260   (interactive)
1261   (let ((xpm-pixels (xpm-read-pixels-in)))
1262     (save-excursion
1263       (goto-char xpm-body-start)
1264       (loop for x from 0 to (1- xpm-xsize)
1265         do
1266         (insert "\"")
1267         (loop for y from (1- xpm-ysize) downto 0
1268           do (insert (nth x (nth y xpm-pixels))))
1269         (insert "\",\n")
1270         finally
1271         (loop until (search-forward "XPMEXT" (point-at-eol) t)
1272           until (eobp)
1273           do
1274           (delete-region (point-at-bol) (point-at-eol))
1275           (delete-char))
1276         (unless (search-forward "};" nil t)
1277           (search-backward "\",")
1278           (replace-match "\"};")))
1279       (goto-char xpm-color-start)
1280       (rotatef xpm-xsize xpm-ysize)
1281       (search-backward-regexp "\"\\s-*\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)")
1282       (replace-match (number-to-string xpm-xsize) nil nil nil 1)
1283       (replace-match (number-to-string xpm-ysize) nil nil nil 2)))
1284   (xpm-init))
1285
1286
1287 (defun xpm-rotate-image-ccw ()
1288   "Rotates the image 90 degrees counterclockwise.
1289 Modifies the x and y size in the image."
1290   (interactive)
1291   (let ((xpm-pixels (xpm-read-pixels-in)))
1292     (save-excursion
1293       (goto-char xpm-body-start)
1294       (loop for x from (1- xpm-xsize) downto 0
1295         do
1296         (insert "\"")
1297         (loop for y from 0 to (1- xpm-ysize)
1298           do (insert (nth x (nth y xpm-pixels))))
1299         (insert "\",\n")
1300         finally
1301         (loop until (search-forward "XPMEXT" (point-at-eol) t)
1302           until (eobp)
1303           do
1304           (delete-region (point-at-bol) (point-at-eol))
1305           (delete-char))
1306         (unless (search-forward "};" nil t)
1307           (search-backward "\",")
1308           (replace-match "\"};")))
1309       (goto-char xpm-color-start)
1310       (rotatef xpm-xsize xpm-ysize)
1311       (search-backward-regexp "\"\\s-*\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)")
1312       (replace-match (number-to-string xpm-xsize) nil nil nil 1)
1313       (replace-match (number-to-string xpm-ysize) nil nil nil 2)))
1314   (xpm-init))
1315
1316 (defun xpm-mirror-image-vertical-axis ()
1317   "Mirrors an image about a vertical axis."
1318   (interactive)
1319   (save-excursion
1320     (let (row)
1321       (goto-char xpm-body-start)
1322       (loop repeat xpm-ysize
1323         do (search-forward "\"")
1324         (setq row (loop repeat xpm-xsize
1325                     collect (buffer-substring (point) (+ (point) xpm-chars-per-pixel))
1326                     do (forward-char xpm-chars-per-pixel)))
1327         (delete-region (point-at-bol) (point-at-eol))
1328         (insert "\"")
1329         (loop for pixel from (1- xpm-xsize) downto 0
1330           do (insert (nth pixel row)))
1331         (insert "\",")
1332         (forward-line)
1333         finally
1334         (unless (search-forward "};" nil t)
1335           (search-backward "\",")
1336           (replace-match "\"};")))))
1337   (xpm-init))
1338
1339 (defun xpm-mirror-image-horizontal-axis ()
1340   "Mirrors an image about a horizontal axis."
1341   (interactive)
1342   (save-excursion
1343     (let (rows)
1344       (goto-char xpm-body-start)
1345       (setq rows (loop repeat xpm-ysize
1346                    collect (buffer-substring (point-at-bol) (point-at-eol))
1347                    do (forward-line)))
1348       (goto-char xpm-body-start)
1349       (loop for row in (nreverse rows)
1350         do
1351         (insert row "\n"))
1352       (loop until (search-forward "XPMEXT" (point-at-eol) t)
1353         until (eobp)
1354         do
1355         (delete-region (point-at-bol) (point-at-eol))
1356         (delete-char))
1357       (unless (search-forward "};" nil t)
1358         (search-backward "\",")
1359         (replace-match "\"};")))
1360     (search-backward "};")
1361     (and (search-backward "};" nil t) (replace-match ",")))
1362   (xpm-init))
1363
1364 (defun xpm-eyedropper-tool ()
1365   "Sets the xpm tool to eyedropper."
1366   (interactive)
1367   (setq xpm-tool 'xpm-eyedropper)
1368   (set-glyph-image text-pointer-glyph (make-image-instance xpm-eyedropper-image nil 'pointer) (current-buffer))
1369   (set-glyph-image text-pointer-glyph xpm-eyedropper-image (current-buffer)))
1370
1371 (defun xpm-pencil-tool ()
1372   "Sets the xpm tool to pencil."
1373   (interactive)
1374   (setq xpm-tool 'xpm-pencil)
1375   (set-glyph-image text-pointer-glyph (make-image-instance xpm-pencil-image nil 'pointer) (current-buffer))
1376   (set-glyph-image text-pointer-glyph xpm-pencil-image (current-buffer)))
1377
1378 (defun xpm-select-tool ()
1379   "Sets the xpm tool to select."
1380   (interactive)
1381   (setq xpm-tool 'xpm-select)
1382   (set-glyph-image text-pointer-glyph (make-image-instance xpm-select-image nil 'pointer) (current-buffer))
1383   (set-glyph-image text-pointer-glyph xpm-select-image (current-buffer)))
1384
1385
1386 (defun xpm-crop (&optional point mark)
1387   "Crops to a rectangle described by point and mark."
1388   (interactive)
1389   (or point
1390       (setq point (point)))
1391   (or mark
1392       (setq mark (mark)))
1393   (if (eq xpm-tool 'xpm-select)
1394       (when (and (xpm-in-bodyp point)
1395                  (xpm-in-bodyp mark))
1396         (let ((p (move-marker (make-marker) point))
1397               (m (move-marker (make-marker) mark))
1398               left
1399               right
1400               top
1401               bottom
1402               left-margin
1403               right-margin
1404               top-margin
1405               bottom-margin)
1406           (setq top (if (> p m) m p))
1407           (setq bottom (if (> p m) p m))
1408           (if (< (- m (point-at-bol (1+ (- (line-number m) (line-number)))))
1409                  (- p (point-at-bol)))
1410               (progn
1411                 (setq left m)
1412                 (setq right p))
1413             (setq left p)
1414             (setq right m))
1415           (goto-line (line-number left))
1416           (search-forward "\"")
1417           (setq left-margin (- left (point)))
1418           (goto-line (line-number right))
1419           (search-forward "\",")
1420           (backward-char 2)
1421           (setq right-margin (- (point) right))
1422           (setq top-margin (- (line-number top) (line-number xpm-body-start)))
1423           (setq bottom-margin (- (line-number xpm-body-end) (line-number bottom)))
1424           (goto-char xpm-body-start)
1425           (loop repeat top-margin
1426             do (delete-region (point-at-bol) (point-at-bol 2)))
1427           (goto-char bottom)
1428           (forward-line)
1429           (loop repeat bottom-margin
1430             do (delete-region (point-at-bol) (point-at-bol 2)))
1431           (unless (search-forward "};" nil t)
1432             (goto-char bottom)
1433             (goto-char (point-at-eol))
1434             (search-backward "\",")
1435             (replace-match "\"};"))
1436           (goto-char xpm-body-start)
1437           (loop repeat (- (line-number bottom) (line-number top) -1)
1438             do (search-forward "\"")
1439             (delete-char left-margin)
1440             (search-forward "\"")
1441             (backward-char)
1442             (delete-backward-char right-margin)
1443             (forward-line))
1444           (setq xpm-xsize (- xpm-xsize left-margin right-margin))
1445           (setq xpm-ysize (- xpm-ysize top-margin bottom-margin))
1446           (goto-char (point-min))
1447           (search-forward-regexp "\"\\s-*\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)")
1448           (replace-match (number-to-string xpm-xsize) nil nil nil 1)
1449           (replace-match (number-to-string xpm-ysize) nil nil nil 2)))
1450     (xpm-select-tool)))
1451
1452 (defun xpm-enlarge (x y)
1453   "Adds space at the bottom and left sides of the image in the current colors."
1454   (interactive "nHow many more pixels to the right:
1455 nHow many more pixels to the bottom: ")
1456   (save-excursion
1457     (goto-char xpm-body-start)
1458     (search-forward "\"")
1459     (search-forward "\"")
1460     (backward-char)
1461     (loop repeat xpm-ysize
1462       do (loop repeat x do (insert xpm-paint-string))
1463       (forward-line)
1464       (search-forward "\"")
1465       (search-forward "\"")
1466       (backward-char))
1467     (setq xpm-xsize (+ xpm-xsize x))
1468     (forward-line 0)
1469     (loop repeat y
1470       do (insert "\"")
1471       (loop repeat xpm-xsize do (insert xpm-paint-string))
1472       (insert "\",\n"))
1473     (unless (search-forward "};" nil t)
1474       (search-backward "\",")
1475       (replace-match "\"};"))
1476     (backward-char)
1477     (while (search-backward "\"};" nil t)
1478       (replace-match "\","))
1479     (setq xpm-ysize (+ xpm-ysize y))
1480     (goto-char (point-min))
1481     (search-forward-regexp "\"\\s-*\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)")
1482     (replace-match (number-to-string xpm-xsize) nil nil nil 1)
1483     (replace-match (number-to-string xpm-ysize) nil nil nil 2)
1484     (xpm-init)))
1485
1486
1487 (defun xpm-goto-color-def (def)
1488   "move to color DEF in the xpm header"
1489   (interactive "nColor number:")
1490   (goto-char xpm-color-start)
1491   (forward-line def))
1492
1493 (defun xpm-goto-body-line (line)
1494   "move to LINE lines down from the start of the body of an xpm"
1495   (interactive "nBody line:")
1496   (goto-char xpm-body-start)
1497   (forward-line line))
1498
1499 (defun xpm-show-characters ()
1500   "Sets the `xpm-show-characters' flag, and re-sets all the faces"
1501   (interactive)
1502   (setq xpm-show-characters t)
1503   (loop for (str . face) in xpm-pixel-values
1504     do
1505     (let ((ccc (color-rgb-components (face-background face))))
1506       (if ccc
1507           (if (or (or (> (elt ccc 0) 32767) ; If any color component is greater than 50%
1508                       (> (elt ccc 1) 32767)) ; Maybe some more gradual change could be used, to better preserve appearance?
1509                   (> (elt ccc 2) 32767))
1510               (set-face-foreground face "black")
1511             (set-face-foreground face "white"))))))
1512
1513
1514 (defun xpm-hide-characters ()
1515   "Clears the `xpm-show-characters' flag, and re-sets all the faces"
1516   (interactive)
1517   (setq xpm-show-characters nil)
1518   (loop for (str . face) in xpm-pixel-values
1519     do
1520     (set-face-foreground face (face-background face))))
1521
1522 (defun xpm-show-image ()
1523   "Display the xpm in the current buffer at the end of the topmost line"
1524   (interactive)
1525   (save-excursion
1526     (if (annotationp xpm-anno)
1527         (delete-annotation xpm-anno))
1528     (setq xpm-glyph (make-glyph
1529                      (vector 'xpm :data
1530                              (buffer-substring (point-min) (point-max)))))
1531     (goto-char (point-min))
1532     (goto-char (point-at-eol))
1533     (setq xpm-anno (make-annotation xpm-glyph (point) 'text))))
1534
1535 (defun xpm-hide-image ()
1536   "Remove the image of the xpm from the buffer"
1537   (interactive)
1538   (if (annotationp xpm-anno)
1539       (delete-annotation xpm-anno)))
1540
1541 (defun xpm-change-str-color (str newcolor)
1542   "Changes the `str' to use `newcolor'"
1543   (interactive "sCharacter to change: ")
1544   (unless newcolor (setq newcolor (facemenu-read-color "New color (tab for list): ")))
1545   (xpm-map-buffer)
1546   (goto-char xpm-color-start)
1547   (if (not (search-forward (concat "\"" str) xpm-body-start t))
1548       (error (concat "Color " str " cannot be found"))
1549     (search-forward-regexp "c\\s-*\\(.*?\\)\\(\\s-\\|\"\\)")
1550     (replace-match newcolor nil nil nil 1)))
1551
1552 (defun xpm-in-bodyp (&optional pos)
1553   "Checks if current cursor position is inside the body of the xpm."
1554   (setq pos (or pos (point)))
1555   (and (< pos xpm-body-end) (> pos xpm-body-start)))
1556
1557 (defun xpm-in-colorsp ()
1558   "Checks if current cursor position is inside the color definitions of the xpm."
1559   (and (< (point) xpm-body-start) (> (point) xpm-color-start)))
1560
1561
1562 (defun xpm-toolbar-select-colour (event chars color)
1563   "The function called by toolbar (palette) buttons.
1564 `chars' is the color symbol, and `color' is the color corresponding to it."
1565   (message "Toolbar selected %s (%s)"  color chars)
1566   (xpm-pencil-tool)
1567   (setq xpm-palette
1568         (mapcar #'(lambda (but)
1569                     (aset but 2 (not (eq color (aref but 3))))
1570                     but)
1571                 xpm-palette))
1572   (xpm-set-paint-str chars)
1573   (set-specifier left-toolbar (cons (current-buffer) xpm-palette)))
1574
1575 (defun xpm-help-display ()
1576   "Displays a new frame with the help for this mode in it."
1577   (interactive)
1578   (let ((help-buffer (get-buffer-create "XPM Mode Help"))
1579         (help-frame (get-other-frame)))
1580     (display-buffer help-buffer nil help-frame)
1581     (set-buffer help-buffer)
1582     (erase-buffer)
1583     (insert
1584      "XPM Mode is a mode principally designed for editing icons. To make
1585 this easier, we've added a few default keybindings, which you can see
1586 below. Feel free to change these like the examples you'll see below in
1587 the keymap, and even add more! We've added several functions which
1588 aren't in our default keymap, but can only be accessed from the XPM
1589 menu. If you want to get the command that any of them runs, you can
1590 just type C-x k and then use the mouse to select whichever menu item
1591 you're interested in.
1592
1593 Default XPM Mode Keymap:
1594
1595 Key combination     Command             Purpose
1596 ---------------     -------             -------
1597         C-c C-r     xpm-show-image      Reloads the preview image at
1598                                                 the top of the buffer
1599         S-button1   mouse-track         Allows you to paint on the
1600                                                 screen with the cursor
1601         C-c C-c     xpm-add-color       Adds a new color to the xpm file
1602
1603         M-up        xpm-shift-up        Shifts the image up on the
1604                                                 screen
1605         M-down      xpm-shift-down      Shifts the image down on the
1606                                                 screen
1607         M-left      xpm-shift-left      Shifts the image left on the
1608                                                 screen
1609         M-right     xpm-shift-right     Shifts the image right on the
1610                                                 screen
1611
1612         M-m M-l     xpm-rotate-left     Rotates the image left
1613         M-m M-r     xpm-rotate-right    Rotates the image right
1614
1615         M-m M-v     xpm-mirror-         Mirrors the image about a
1616                         vertical-axis           vertical axis
1617         M-m M-h     xpm-mirror-         Mirrors the image about a
1618                         horizontal-axis         horizontal axis
1619
1620         M-m M-c     xpm-crop            Allows you to crop using the
1621                                                 mouse
1622         M-m M-e     xpm-enlarge         Pads the image on the bottom
1623                                                 and right side with the
1624                                                 current color
1625         M-m M-l     xpm-show-characters Shows the characters in the
1626                                                 editing area
1627         M-m M-i     xpm-hide-characters Hides the characters in the
1628                                                 editing area
1629         M-m M-f1    xpm-mode-help       Pulls up a new frame with this
1630                                                 help document in it.
1631
1632 Using the mouse:
1633
1634 There are three tools you can use with the mouse: a pencil, a color
1635 picker, and a crop tool. These are selected by the three icons to the
1636 left of this help icon on the toolbar.
1637
1638 The pencil is used for drawing on the image. To use it, you either
1639 have to hold down shift, and click with your primary button, or just
1640 click with button2 (usually your middle button). Before you can use it
1641 you have to select a color. This can be done with the color picker
1642 tool, or a couple of ways without switching tools. You can select the
1643 color from the palette on the far left of the screen with the pencil,
1644 or from the color definition section of the buffer, with either a
1645 middle click, or a shifted primary click.
1646
1647 The color picker is used for selecting colors. With the color picker
1648 chosen, you can pick a color three ways: you can select it from the
1649 palette on the far left of the screen, or you can middle click or
1650 shifted primary click in either the color definition section, or on
1651 any pixel in the image. The color picker toolbar icon will show you
1652 what color is selected.
1653
1654 The crop tool is used for cutting the buffer to a certain selection.
1655 You use it by selecting the tool, then middle clicking or
1656 shift-clicking each corner of the box you want to cut the image down
1657 to. Finally, when the selected area is what you want, click the crop
1658 tool again.
1659
1660
1661
1662 Examples:
1663
1664 To assign a new function to a key, try the following:
1665
1666 I wanted to add xpm-init to a handy key so I could reload the page
1667 easily. To do this, I put the following in my init.el:
1668         (define-key xpm-mode-map [(control c) (control i)] 'xpm-init)
1669 This adds the key to the xpm mode-map, so next time I load xpm-mode,
1670 this key will be available.
1671
1672 It's as easy as that!")
1673     (raise-frame help-frame)))
1674
1675 (defun xpm-mouse-down (event n)
1676 ;  (interactive "ep")
1677   (case xpm-tool
1678     ('xpm-pencil (mouse-set-point event)
1679                  (unless xpm-paint-string (error "Select a color before painting!"))
1680                  (if (xpm-in-bodyp)
1681                      ;; in body, overwrite the paint string where the mouse is clicked
1682                      (let ((ext (extent-at-event event))
1683                            (pixel-color (assoc xpm-paint-string xpm-pixel-values)))
1684                        (goto-char (extent-start-position ext))
1685                        (insert xpm-paint-string)
1686                        (delete-char xpm-chars-per-pixel)
1687                        (if xpm-always-update-image
1688                            (xpm-show-image))
1689                        (if pixel-color
1690                            (set-extent-face ext (cdr pixel-color))
1691                          (set-extent-face ext 'default)))
1692                    ;; otherwise, select the color defined by the line where the mouse
1693                    ;; was clicked
1694                    (if (xpm-in-colorsp)
1695                        (save-excursion
1696                          (goto-char (point-at-bol))
1697                          (when (search-forward-regexp (concat "\"\\s-*\\(" (make-string xpm-chars-per-pixel ?.) "\\)") (point-at-eol) t)
1698                            (xpm-set-paint-str (match-string 1))))))
1699                  (mouse-set-point event))
1700     ('xpm-select (let ((ext1 (extent-at (point)))
1701                        (ext2 (extent-at-event event)))
1702                    (if (< (- (extent-start-position ext1) (point-at-bol)) (- (extent-start-position ext2) (point-at-bol)))
1703                        (progn (goto-char (extent-start-position ext1))
1704                               (push-mark)
1705                               (goto-char (extent-end-position ext2)))
1706                      (goto-char (extent-end-position ext1))
1707                      (push-mark)
1708                      (goto-char (extent-start-position ext2))))
1709                  (zmacs-activate-region))
1710     ('xpm-eyedropper (mouse-set-point event)
1711                      (if (xpm-in-bodyp)
1712                          (let ((face (extent-face (extent-at-event event))))
1713                            (xpm-set-paint-str (car (rassoc (make-face face) xpm-pixel-values))))
1714                        (if (xpm-in-colorsp)
1715                            (save-excursion
1716                              (goto-char (point-at-bol))
1717                              (when (search-forward-regexp (concat "\"\\s-*\\(" (make-string xpm-chars-per-pixel ?.) "\\)") (point-at-eol) t)
1718                                (xpm-set-paint-str (match-string 1)))))))))
1719
1720 (defun xpm-set-paint-str (str)
1721   "Sets the current paint color."
1722   (save-excursion
1723     (setq xpm-paint-string str)
1724     (let* ((color (face-background-name (cdr (assoc str xpm-pixel-values))))
1725            (ccc (color-rgb-components (make-color-specifier color))))
1726       (if ccc
1727           (if (or (or (> (elt ccc 0) 32767) ; If any color component is greater than 50%
1728                       (> (elt ccc 1) 32767)) ; Maybe some more gradual change could be used, to better preserve appearance?
1729                   (> (elt ccc 2) 32767))
1730               (progn
1731                 (set-buffer (get-buffer-create "*Icon*"))
1732                 (insert-file-contents xpm-black-color-icon-path)
1733                 (xpm-change-str-color " " color)
1734                 (setq xpm-color-icon
1735                       (list (make-glyph (vector 'xpm :data (buffer-string)))))
1736                 (kill-buffer (current-buffer)))
1737             (set-buffer (get-buffer-create "*Icon*"))
1738             (insert-file-contents xpm-white-color-icon-path)
1739             (xpm-change-str-color " "  color)
1740             (setq xpm-color-icon
1741                   (list (make-glyph (vector 'xpm :data (buffer-string)))))
1742             (kill-buffer (current-buffer))))))
1743   (xpm-update-toolbar))
1744
1745
1746 (defun xpm-mouse-drag (event n timeout)
1747   (case xpm-tool ('xpm-pencil (mouse-set-point event)
1748                               (or timeout
1749                                   (progn
1750                                     (if (xpm-in-bodyp)
1751                                         ;; Much improved by not using font-lock-mode
1752                                         (or (string= xpm-paint-string
1753                                                      (buffer-substring (point)
1754                                                                        (+ xpm-chars-per-pixel
1755                                                                           (point))))
1756                                             (let ((ext (extent-at-event event))
1757                                                   (pixel-color (assoc xpm-paint-string xpm-pixel-values)))
1758                                               (goto-char (extent-start-position ext))
1759                                               (insert xpm-paint-string)
1760                                               (delete-char xpm-chars-per-pixel)
1761                                               (if xpm-always-update-image
1762                                                   (xpm-show-image))
1763                                               (if pixel-color
1764                                                   (set-extent-face ext (cdr pixel-color))
1765                                                 (set-extent-face ext 'default)))))))
1766                               (mouse-set-point event))
1767         ('xpm-select (mouse-set-point event)
1768                      (zmacs-activate-region))
1769         ('xpm-eyedropper (mouse-set-point event))))
1770
1771
1772
1773
1774 (defun xpm-mouse-up (event n)
1775   (case xpm-tool
1776     ('xpm-pencil
1777      (xpm-show-image))
1778     ('xpm-select (if (< (- (mark) (point-at-bol (1+ (- (line-number (mark)) (line-number)))))
1779                         (- (point) (point-at-bol)))
1780                                         ; Checks if mark is closer to the beginning of its line than point.
1781                      (goto-char (extent-end-position (extent-at-event event)))
1782                    (goto-char (extent-start-position (extent-at-event event))))
1783                  (zmacs-activate-region))
1784     ('xpm-eye-dropper (if (xpm-in-bodyp)
1785                           (let ((face (extent-face (extent-at-event event))))
1786                             (xpm-set-paint-str (car (rassoc (make-face face) xpm-pixel-values))))
1787                         (if (xpm-in-colorsp)
1788                             (save-excursion
1789                               (goto-char (point-at-bol))
1790                               (when (search-forward-regexp (concat "\"\\s-*\\(" (make-string xpm-chars-per-pixel ?.) "\\)") (point-at-eol) t)
1791                                 (xpm-set-paint-str (match-string 1)))))))))
1792
1793 (defun xpm-toggle-chars ()
1794   "Toggles whether characters are shown in the editting area.
1795 Also modifies the toolbar icon."
1796   (interactive)
1797   (if xpm-show-characters
1798       (progn (xpm-hide-characters)
1799              (setq xpm-chars-icon xpm-show-chars-icon))
1800     (xpm-show-characters)
1801     (setq xpm-chars-icon xpm-hide-chars-icon))
1802   (xpm-update-toolbar))
1803
1804 (defun xpm-update-toolbar ()
1805   "Hack to update toolbar.
1806 If I find a better way, I'll put it here, but for now it simply removes the
1807 toolbar, redisplays, and adds it again."
1808   (remove-specifier default-toolbar (current-buffer))
1809   (sit-for 0)
1810   (set-specifier default-toolbar xpm-toolbar (current-buffer)))
1811
1812
1813 (defun xpm-movement-right ()
1814   "Move right after self-inserting character in Picture mode."
1815   (interactive)
1816   (xpm-set-motion 0 1))
1817
1818 (defun xpm-movement-left ()
1819   "Move left after self-inserting character in Picture mode."
1820   (interactive)
1821   (xpm-set-motion 0 -1))
1822
1823 (defun xpm-movement-up ()
1824   "Move up after self-inserting character in Picture mode."
1825   (interactive)
1826   (xpm-set-motion -1 0))
1827
1828 (defun xpm-movement-down ()
1829   "Move down after self-inserting character in Picture mode."
1830   (interactive)
1831   (xpm-set-motion 1 0))
1832
1833 (defun xpm-movement-nw ()
1834   "Move up and left after self-inserting character in Picture mode."
1835   (interactive)
1836   (xpm-set-motion -1 -1))
1837
1838 (defun xpm-movement-ne ()
1839   "Move up and right after self-inserting character in Picture mode."
1840   (interactive)
1841   (xpm-set-motion -1 1))
1842
1843 (defun xpm-movement-sw ()
1844   "Move down and left after self-inserting character in Picture mode."
1845   (interactive)
1846   (xpm-set-motion 1 -1))
1847
1848 (defun xpm-movement-se ()
1849   "Move down and right after self-inserting character in Picture mode."
1850   (interactive)
1851   (xpm-set-motion 1 1))
1852
1853 (defun xpm-set-motion (vert horiz)
1854   "Set VERTICAL and HORIZONTAL increments for movement in Picture mode.
1855 The modeline is updated to reflect the current direction."
1856   (setq picture-vertical-step vert
1857         picture-horizontal-step horiz)
1858   (setq mode-name
1859         (format "XPM:%s"
1860                 (car (nthcdr (+ 1 (% horiz 2) (* 3 (1+ (% vert 2))))
1861                              '(nw up ne left none right sw down se)))))
1862   (redraw-modeline)
1863   (message nil))
1864
1865
1866 (defun xpm-make-toolbar-buttons()
1867   "Makes all the buttons for the xpm toolbar.
1868 Can use either locate-data-directory to find the files or data-directory."
1869   (if (not text-modes-toolbar-icon-directory)
1870       (setq text-modes-toolbar-icon-directory
1871             (if (fboundp 'locate-data-directory)
1872                 (locate-data-directory "text-modes")
1873               (file-name-as-directory
1874                (expand-file-name "text-modes" data-directory)))))
1875 ;--- define buttons for the xpm-mode toolbar
1876   (setq xpm-open-icon  (toolbar-make-button-list   (vector 'xpm :file (concat text-modes-toolbar-icon-directory "xpm-open-file-icon-48-48.xpm") ) ))
1877   (setq xpm-save-icon  (toolbar-make-button-list   (vector 'xpm :file (concat text-modes-toolbar-icon-directory "xpm-save-file-icon-48-48.xpm") ) ))
1878   (setq xpm-undo-icon  (toolbar-make-button-list   (vector 'xpm :file (concat text-modes-toolbar-icon-directory "xpm-undo-icon-48-48.xpm" )) ))
1879   (setq xpm-new-image-icon (toolbar-make-button-list   (vector 'xpm :file (concat text-modes-toolbar-icon-directory "xpm-new-image-icon-48-48.xpm" )) ))
1880   (setq xpm-sh-l-icon  (toolbar-make-button-list   (vector 'xpm :file (concat text-modes-toolbar-icon-directory "xpm-shift-left-icon-48-48.xpm") )  ))
1881   (setq xpm-sh-r-icon  (toolbar-make-button-list   (vector 'xpm :file (concat text-modes-toolbar-icon-directory "xpm-shift-right-icon-48-48.xpm") ) ))
1882   (setq xpm-sh-u-icon  (toolbar-make-button-list   (vector 'xpm :file (concat text-modes-toolbar-icon-directory "xpm-shift-up-icon-48-48.xpm") ) ))
1883   (setq xpm-sh-d-icon  (toolbar-make-button-list   (vector 'xpm :file (concat text-modes-toolbar-icon-directory "xpm-shift-down-icon-48-48.xpm") ) ))
1884   (setq xpm-r-cw-icon  (toolbar-make-button-list   (vector 'xpm :file (concat text-modes-toolbar-icon-directory "xpm-rotate-cw-icon-48-48.xpm") ) ))
1885   (setq xpm-r-ccw-icon (toolbar-make-button-list   (vector 'xpm :file (concat text-modes-toolbar-icon-directory "xpm-rotate-ccw-icon-48-48.xpm") ) ))
1886   (setq xpm-m-vert-icon  (toolbar-make-button-list (vector 'xpm :file (concat text-modes-toolbar-icon-directory "xpm-mirror-vertical-icon-48-48.xpm") ) ))
1887   (setq xpm-m-horiz-icon (toolbar-make-button-list (vector 'xpm :file (concat text-modes-toolbar-icon-directory "xpm-mirror-horizontal-icon-48-48.xpm") ) ))
1888   (setq xpm-crop-icon  (toolbar-make-button-list   (vector 'xpm :file (concat text-modes-toolbar-icon-directory "xpm-crop-icon-48-48.xpm") ) ))
1889   (setq xpm-enlarge-icon  (toolbar-make-button-list   (vector 'xpm :file (concat text-modes-toolbar-icon-directory "xpm-enlarge-icon-48-48.xpm") ) ))
1890   (setq xpm-show-chars-icon  (toolbar-make-button-list   (vector 'xpm :file (concat text-modes-toolbar-icon-directory "xpm-show-chars-icon-48-48.xpm") ) ))
1891   (setq xpm-hide-chars-icon  (toolbar-make-button-list   (vector 'xpm :file (concat text-modes-toolbar-icon-directory "xpm-hide-chars-icon-48-48.xpm") ) ))
1892   (setq xpm-help-icon  (toolbar-make-button-list   (vector 'xpm :file (concat text-modes-toolbar-icon-directory "xpm-help-icon-48-48.xpm") ) ))
1893   (setq xpm-color-icon  (toolbar-make-button-list   (vector 'xpm :file (concat text-modes-toolbar-icon-directory "xpm-black-color-icon-48-48.xpm") ) ))
1894   (setq xpm-pencil-icon  (toolbar-make-button-list   (vector 'xpm :file (concat text-modes-toolbar-icon-directory "xpm-set-pencil-icon-48-48.xpm") ) ))
1895   (setq xpm-black-color-icon-path (concat text-modes-toolbar-icon-directory "xpm-black-color-icon-48-48.xpm"))
1896   (setq xpm-white-color-icon-path (concat text-modes-toolbar-icon-directory "xpm-white-color-icon-48-48.xpm"))
1897   (setq xpm-eyedropper-image (vector 'xpm :file (concat text-modes-toolbar-icon-directory "xpm-eyedropper.xpm" )))
1898   (setq xpm-select-image (vector 'xpm :file (concat text-modes-toolbar-icon-directory "xpm-select.xpm")))
1899   (setq xpm-pencil-image (vector 'xpm :file (concat text-modes-toolbar-icon-directory "xpm-pencil.xpm" )))
1900   (if xpm-show-characters
1901       (setq xpm-chars-icon xpm-hide-chars-icon)
1902     (setq xpm-chars-icon xpm-show-chars-icon)))
1903
1904
1905 ;--- Add an icon specification to the xpm-top-toolbar for each icon
1906 (load "picture")
1907 (defvar xpm-mode nil)
1908 (make-variable-buffer-local 'xpm-mode)
1909 (defvar xpm-mode-map nil)
1910
1911 (if xpm-mode-map
1912     ()
1913   (setq xpm-mode-map (copy-keymap picture-mode-map))
1914   (define-key xpm-mode-map [(control c) (control r)] 'xpm-show-image)
1915   (define-key xpm-mode-map [(shift button1)] 'mouse-track)
1916   (define-key xpm-mode-map [button1] 'mouse-track-default)
1917   (define-key xpm-mode-map [(control c) (control c)] 'xpm-add-color)
1918   (define-key xpm-mode-map [(control c) (control p)] 'xpm-parse-color)
1919   (define-key xpm-mode-map [(meta up)] (lambda () (interactive) (xpm-shift-image-up 1)))
1920   (define-key xpm-mode-map [(meta down)] (lambda () (interactive) (xpm-shift-image-down 1)))
1921   (define-key xpm-mode-map [(meta left)] (lambda () (interactive) (xpm-shift-image-left 1)))
1922   (define-key xpm-mode-map [(meta right)] (lambda () (interactive) (xpm-shift-image-right 1)))
1923   (define-key xpm-mode-map [(meta m) (meta l)] 'xpm-rotate-image-ccw)
1924   (define-key xpm-mode-map [(meta m) (meta r)] 'xpm-rotate-image-cw)
1925   (define-key xpm-mode-map [(meta m) (meta v)] 'xpm-mirror-image-vertical-axis)
1926   (define-key xpm-mode-map [(meta m) (meta h)] 'xpm-mirror-image-horizontal-axis)
1927   (define-key xpm-mode-map [(meta m) (meta c)] 'xpm-crop)
1928   (define-key xpm-mode-map [(meta m) (meta e)] 'xpm-enlarge)
1929   (define-key xpm-mode-map [(meta m) (meta v)] 'xpm-show-characters)
1930   (define-key xpm-mode-map [(meta m) (meta i)] 'xpm-hide-characters)
1931   (define-key xpm-mode-map [(meta m) (meta f1)] 'xpm-help-display)
1932   (define-key xpm-mode-map "\C-c<" 'xpm-movement-left)
1933   (define-key xpm-mode-map "\C-c>" 'xpm-movement-right)
1934   (define-key xpm-mode-map "\C-c^" 'xpm-movement-up)
1935   (define-key xpm-mode-map "\C-c." 'xpm-movement-down)
1936   (define-key xpm-mode-map "\C-c`" 'xpm-movement-nw)
1937   (define-key xpm-mode-map "\C-c'" 'xpm-movement-ne)
1938   (define-key xpm-mode-map "\C-c/" 'xpm-movement-sw)
1939   (define-key xpm-mode-map "\C-c\\" 'xpm-movement-se))
1940
1941 (if xpm-menu
1942     ()
1943   (setq xpm-menu '("XPM"
1944                    ["Refresh buffer" xpm-init ]
1945                    ["Create New .xpm Image" xpm-new-transparent ]
1946                    ["Enlarge Existing .xpm" xpm-enlarge ]
1947                    ["Crop .xpm" xpm-crop ]
1948                    ["Overlay .xpm over .xpm" xpm-overlay-buffer  ]
1949                    "---"
1950                    ["Lighten Image" xpm-lighten-image ]
1951                    ["Darken Image" xpm-darken-image ]
1952                    ["Show Characters" xpm-toggle-chars :style toggle :selected xpm-show-characters]
1953                    "---"
1954                    ["Shift Left" xpm-shift-image-left ]
1955                    ["Shift Right" xpm-shift-image-right ]
1956                    ["Shift Up" xpm-shift-image-up ]
1957                    ["Shift Down" xpm-shift-image-down ]
1958                    ["Rotate CW 90 deg." xpm-rotate-image-cw ]
1959                    ["Rotate CCW 90 deg." xpm-rotate-image-ccw ]
1960                    ["Mirror On Vertical Axis" xpm-mirror-image-vertical-axis ]
1961                    ["Mirror On Horizontal Axis" xpm-mirror-image-horizontal-axis ])))
1962
1963 (if xpm-gradient-menu
1964     ()
1965   (setq xpm-gradient-menu '("Gradients"
1966                             ["Gradient 2 colors type 1" xpm-new-vertical-gradient ]
1967                             ["Gradient 2 colors type 2" xpm-new-vertical-twosided-gradient ]
1968                             ["Gradient Diagonal" xpm-new-diagonal-gradient ]
1969                             ["Gradient Circles From Center" xpm-new-circles-from-center-gradient  ]
1970                             ["Gradient Squares From Center" xpm-new-squares-from-center-gradient  ])))
1971
1972 ;;;###autoload(add-to-list 'auto-mode-alist '("\\.xpm$" . xpm-mode))
1973
1974 ;;;###autoload
1975 (define-derived-mode xpm-mode picture-mode "XPM"
1976   "A mode for editing xpm files. Based on picture-mode.
1977   Shift-button-1 lets you paint by dragging the mouse.  Shift-button-1 on a
1978 color definition line will change the current painting color to that line's
1979 value.
1980
1981   Characters inserted from the keyboard will NOT be colored properly yet.
1982 Use the mouse, or do xpm-init (\\[xpm-init]) after making changes.
1983
1984 \\[xpm-add-color] Add a new color, prompting for character and value
1985 \\[xpm-show-image] show the current image at the top of the buffer
1986 \\[xpm-parse-color] parse the current line's color definition and add
1987    it to the color table.  Provided as a means of changing colors.
1988 XPM major mode bindings:
1989 \\{xpm-mode-map}"
1990   (make-local-variable 'xpm-palette)
1991   (make-local-variable 'xpm-xsize)
1992   (make-local-variable 'xpm-ysize)
1993   (make-local-variable 'xpm-num-colors)
1994   (make-local-variable 'xpm-chars-per-pixel)
1995   (make-local-variable 'xpm-paint-string)
1996   (make-local-variable 'xpm-color-start)
1997   (make-local-variable 'xpm-body-start)
1998   (make-local-variable 'xpm-body-end)
1999   (make-local-variable 'xpm-glyph)
2000   (make-local-variable 'xpm-anno)
2001   (make-local-variable 'xpm-pixel-values)
2002   (make-local-variable 'xpm-alpha-values)
2003   (make-local-variable 'mouse-track-down-hook)
2004   (make-local-variable 'mouse-track-drag-hook)
2005   (make-local-variable 'mouse-track-up-hook)
2006   (make-local-variable 'mouse-track-drag-up-hook)
2007   (make-local-variable 'mouse-track-click-hook)
2008   (make-local-variable 'current-menubar)
2009   (xpm-make-toolbar-buttons)
2010   (xpm-init)
2011   (xpm-pencil-tool)
2012   (setq mouse-track-down-hook 'xpm-mouse-down)
2013   (setq mouse-track-drag-hook 'xpm-mouse-drag)
2014   (setq mouse-track-up-hook 'xpm-mouse-up)
2015   (setq mouse-track-drag-up-hook 'xpm-mouse-up)
2016   (setq mouse-track-click-hook nil)
2017   (set-specifier default-toolbar xpm-toolbar (current-buffer))
2018   (add-submenu nil xpm-menu nil)
2019   (add-submenu '("XPM") xpm-gradient-menu nil)
2020   (xpm-set-motion 0 1)
2021   (use-local-map xpm-mode-map)
2022   (set-specifier default-toolbar-height 53 (current-buffer))) ; Set toolbar height to match toolbar icons.
2023
2024
2025 (provide 'xpm-mode)
2026
2027 ;;; xpm-mode.el ends here