1 ;;; xpm-mode.el --- minor mode for editing XPM files
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>
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>
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
19 ;; This file is part of XEmacs.
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)
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.
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.
36 ;;; Synched up with: Not in FSF.
39 ;; xpm mode: Display xpm files in color
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.
45 ;; Non-standard minor mode in that it starts picture-mode automatically.
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)
53 ;; ("\\.el$" . emacs-lisp-mode)
54 ;; ("\\.emacs$" . emacs-lisp-mode)
56 ;; ("\\.xpm" . xpm-mode))))
57 ;; (autoload 'xpm-mode "xpm-mode")
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.
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.
68 ;; If your default font is proportional, this will not be very useful.
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.
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)
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
114 ;; -generate error codes that tell exactly what it cannot parse
115 ;; and which line number it fails at.
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...
125 ;; to run, load an xpm into XEmacs, or type M-x xpm-mode in the minibuffer.
129 (require 'annotations)
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:
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)
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)
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" ]
209 [ xpm-help-icon xpm-help-display t "List commands for xpm-editor" ]))
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)
221 "Treat the current buffer as an xpm file and colorize it."
224 (setq xpm-alpha-values nil)
225 (setq xpm-pixel-values nil)
227 (setq xpm-palette nil)
228 (message "Mapping Buffer...")
230 (message "Finding number of colors...")
232 (goto-char xpm-color-start)
233 (loop repeat xpm-num-colors
235 (xpm-parse-color "c")
238 (goto-char (point-min))
239 (when (search-forward-regexp "\"XPMEXT *xemacs_alpha_values" nil t)
241 (loop until (search-forward "\"XPMENDEXT" (point-at-eol) t)
242 do (xpm-parse-color "a")
244 (if (featurep 'toolbar)
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
253 (set-specifier left-toolbar-width (cons (current-buffer) 16))
254 (set-specifier left-toolbar (cons (current-buffer) xpm-palette))))
255 (message "Parsing body...")
258 (xpm-color-alpha-extension)
259 (message "Parsing body...done")
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)))
267 (defun xpm-color-data ()
268 "Make extents and color them for each pixel in the xpm."
271 (xpm-goto-body-line 0)
275 (loop until (search-forward "\"XPMEXT" (point-at-eol) t)
276 while (< (+ (point) xpm-chars-per-pixel) (point-max))
278 (if (string-match "\"" (buffer-substring (point) (+ (point) xpm-chars-per-pixel)))
279 ;If there is a quote in our next chunk
281 (search-forward "\"")
282 (unless (string-match "^\\s-*\"$" (buffer-substring (point-at-bol) (point)))
283 ; unless nothing but whitespace before quote
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)))
290 (set-extent-face ext (cdr pixel-color)))
291 (set-extent-face ext 'default))
292 (forward-char xpm-chars-per-pixel))))))
294 (defun xpm-color-colors ()
295 "Make extents and color them for every color defined in xpm"
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))))
305 (set-extent-face ext (cdr pixel-color)))
306 (set-extent-face ext 'default)))
309 (defun xpm-color-alpha-extension ()
310 "Make extents and color them for every color defined in xpm"
313 (goto-char (point-min))
314 (when (search-forward-regexp "\"XPMEXT *xemacs_alpha_values" nil t)
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))))
322 (set-extent-face ext (cdr pixel-color)))
323 (set-extent-face ext 'default)))
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
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))
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)))
351 (defun xpm-add-alpha-extension ()
352 "Adds an alpha extension section to the current xpm."
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)))
364 (goto-char xpm-body-end)
366 (insert "\"XPMEXT xemacs_alpha_values\",\n"
367 (loop for symbol in transparent-colors
372 (unless (search-forward "};" nil t)
373 (search-backward "\",")
374 (replace-match "\"};"))
376 (while (search-backward "\"};" nil t)
377 (replace-match "\","))))))
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."
384 (if (and (> xpm-chars-per-pixel 1) (not more-than-two))
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)
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)
398 (search-forward "\"" nil t))
399 (goto-char xpm-body-end)
400 (when (search-forward-regexp "XPMEXT\\s-*xemacs_alpha_values" nil t)
402 (loop until (search-forward "XPMENDEXT" (point-at-eol) t)
403 do (search-forward-regexp (concat "\"" (make-string xpm-chars-per-pixel ?.)) nil t)
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)
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."
420 (setq strength 0.05))
422 (let* ((target-buffer (or buffer (current-buffer)))
423 (filter-buffer (get-buffer-create "*Filter Buffer*"))
427 (set-buffer filter-buffer)
429 (setq filter-list (xpm-make-solid-image-strings xsize ysize))
430 (insert (car filter-list) "#000000000000" (cadr filter-list))
432 (xpm-add-alpha-extension)
433 (xpm-add-alpha "." (format "%i" (* 65535 strength)))
435 (xpm-overlay-buffer target-buffer filter-buffer 0 0))))
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."
444 (setq strength 0.05))
446 (let* ((target-buffer (or buffer (current-buffer)))
447 (filter-buffer (get-buffer-create "*Filter Buffer*"))
451 (set-buffer filter-buffer)
453 (setq filter-list (xpm-make-solid-image-strings xsize ysize))
454 (insert (car filter-list) "#ffffffffffff" (cadr filter-list))
456 (xpm-add-alpha-extension)
457 (xpm-add-alpha "." (format "%i" (* 65535 strength)))
459 (xpm-overlay-buffer target-buffer filter-buffer 0 0))))
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): ")
469 (setq strength 0.10))
471 (let* ((target-buffer (or buffer (current-buffer)))
472 (filter-buffer (get-buffer-create "*Filter Buffer*"))
476 (set-buffer filter-buffer)
478 (setq filter-list (xpm-make-solid-image-strings xsize ysize))
479 (insert (car filter-list) "#00000000ffff" (cadr filter-list))
481 (xpm-add-alpha-extension)
482 (xpm-add-alpha "." "0")
484 (loop for x from 1 to bevel-width
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)
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)))
501 (backward-char xpm-chars-per-pixel)))
502 (goto-char xpm-body-start)
503 (loop for x from 0 to (1- bevel-width) do
506 (loop repeat (- xpm-xsize (* 2 x) 1) do
507 (delete-char xpm-chars-per-pixel)
508 (insert (concat "l" (format "%x" x))))
510 (goto-char xpm-body-end)
511 (goto-char (point-at-bol))
512 (loop for x from 0 to (1- bevel-width) do
515 (loop repeat (- xpm-xsize (* 2 x) 1) do
516 (delete-char xpm-chars-per-pixel)
517 (insert (concat "d" (format "%x" x))))
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)))
529 (backward-char xpm-chars-per-pixel))) ;Finished constructing the filter
530 (xpm-overlay-buffer target-buffer filter-buffer 0 0))))
532 (defun xpm-new-solid-color ( width height color )
533 "Creates a new xpm file with a solid background color."
534 (interactive "nWidth:
537 (let ((new-buffer (create-file-buffer "Untitled.xpm"))
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))
544 (xpm-add-color " " "None")
545 (xpm-add-alpha-extension)
546 (xpm-add-alpha " " "0")
550 (defun xpm-new-transparent ( width height )
551 "Creates a new xpm file with a transparent background."
552 (interactive "nWidth:
555 (let ((new-buffer (create-file-buffer "Untitled.xpm"))
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))
561 (xpm-add-color " " "None")
562 (xpm-add-alpha-extension)
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:
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)))
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))
585 (xpm-add-color " " "None")
586 (xpm-add-alpha-extension)
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)))
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:
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)))
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))
621 (xpm-add-color " " "None")
622 (xpm-add-alpha-extension)
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)))
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)))
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:
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)))
659 (colors (+ height width -1))
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))
666 (xpm-add-color " " "None")
667 (xpm-add-alpha-extension)
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) ?\")))
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))))
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:
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): ")))
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)))
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))))))
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))
719 (xpm-add-color " " "None")
720 (xpm-add-alpha-extension)
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)))
735 (search-forward "\"" nil t))
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:
743 (xpm-new-circles-gradient width height nil nil (/ width 2) (/ height 2)))
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:
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)))
761 (colors (apply 'max (mapcar 'abs (list (- width centerx) (- height centery) (- 0 centerx) (- 0 centery)))))
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))
768 (xpm-add-color " " "None")
769 (xpm-add-alpha-extension)
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)))
784 (search-forward "\"" nil t))
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:
791 (xpm-new-squares-gradient width height nil nil (/ width 2) (/ height 2)))
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
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))
806 underalpha (string-to-number (or (cdr (assoc understr xpm-alpha-values))
808 overcc (color-rgb-components (face-background overface))
809 undercc (color-rgb-components (face-background underface))
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)))
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)
834 (loop for (str . face) in pixel-values
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
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
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)))
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)
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)))
869 (loop for row in image-list
870 collect (loop for pixel in row
871 collect (or (cdr (assoc pixel middle-list))
873 collect (loop for pixel in row
874 collect (or (cdr (assoc (car (rassoc pixel middle-list)) rename-list))
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"
882 (let ((image-xsize (length (car image-list)))
883 (image-ysize (length image-list))
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)
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)))
898 (search-forward "\"")
899 (forward-char (* xpm-chars-per-pixel xoffset))))
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:
907 nOffset in x direction:
908 nOffset in y direction: ")
910 (set-buffer overlay-buffer)
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)
917 (message "Overlaying images...")
919 (xpm-rename-colors (xpm-merge-in-color-list overlay-pixel-values overlay-alpha-values)
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")
930 (defun xpm-remove-unused-colors ()
931 "Removes unused color definitions from current buffer."
934 (let ((used-colors nil))
935 (goto-char xpm-body-start)
936 (search-forward "\"")
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))
943 (search-forward "\"" nil t)))
944 (goto-char xpm-color-start)
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)
950 (if (member (match-string 1) used-colors)
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)
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)
963 (delete-region (point-at-bol) (point-at-bol 2)))))
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)
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))
982 (when (and (not no-alpha)
983 (search-forward-regexp "\"XPMEXT\\s-*xemacs_alpha_values" nil t))
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)))
991 (setq color-changes (loop for (str . color) in known-colors
992 do (setq color-alpha (or (cdr (assoc str known-alphas))
994 collect (if (setq color-key (car (rassoc (concat color-alpha "-" color) kept-colors)))
996 (setq kept-colors (cons (cons str (concat color-alpha "-" color )) kept-colors))
998 (setq color-changes (remove-if-not 'identity color-changes))))
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. "
1005 (let ((color-changes (xpm-find-duplicate-colors))
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)))
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))
1022 (when (search-forward-regexp "\"XPMEXT\\s-*xemacs_alpha_values" nil t)
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))
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)))
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
1041 (setq new-face (xpm-make-face color))
1042 (if xpm-show-characters
1043 (let ((ccc (color-rgb-components (make-color-specifier color))))
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)))
1057 (list (make-glyph (concat (car strings) color (cadr strings))))
1058 ;; Major cool things with quotes..... (setq str "a " color "green")
1061 (xpm-toolbar-select-colour event (,str) (,color))))
1063 color) xpm-palette)))))))
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)"
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
1076 "\\s-+\\(.+?\\)\\(\\s-\\|\"\\)") ;Simplified by non-greedy operators.
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)))))))
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))
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.
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):")
1106 (xpm-goto-color-def xpm-num-colors)
1107 (insert-before-markers (format "\"%s\tc %s\",\n" str color))
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)))
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):")
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."))
1124 (insert-before-markers (format "\"%s\ta %s\",\n" str alpha))
1126 (xpm-parse-color "a")))
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."
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)))
1143 (while (and (not (eobp)) (not (looking-at "\\s-*\"")))
1145 (setq xpm-color-start (point-marker))
1146 (forward-line xpm-num-colors)
1147 (search-forward "\"")
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))))
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: ")
1162 (xpm-shift-image-right x)
1163 (xpm-shift-image-left (- x)))
1165 (xpm-shift-image-down y)
1166 (xpm-shift-image-up (- y))))
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."
1174 (setq pixels (string-to-number (read-string "Number of pixels to shift left (1): " nil nil "1"))))
1176 (xpm-goto-body-line 0)
1177 (loop repeat xpm-ysize
1179 (search-forward "\"")
1180 (delete-char (* xpm-chars-per-pixel pixels) t)
1181 (search-forward "\"")
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."
1192 (setq pixels (string-to-number (read-string "Number of pixels to shift right (1): " nil nil "1"))))
1194 (xpm-goto-body-line 0)
1195 (loop repeat xpm-ysize
1197 (search-forward "\"")
1198 (search-forward "\"")
1200 (delete-backward-char (* xpm-chars-per-pixel pixels) t)
1201 (search-backward "\"")
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."
1212 (setq pixels (string-to-number (read-string "Number of pixels to shift up (1): " nil nil "1"))))
1214 (xpm-goto-body-line 0)
1215 (kill-entire-line pixels)
1216 (goto-char xpm-body-end)
1219 (search-backward-regexp ",\\s-*")
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."
1228 (setq pixels (string-to-number (read-string "Number of pixels to shift down (1): " nil nil "1"))))
1230 (goto-char xpm-body-end)
1232 (kill-entire-line (* -1 pixels))
1233 (search-backward-regexp ",\\s-*\n")
1235 (goto-char xpm-body-start)
1239 (defun xpm-read-pixels-in ()
1240 "Reads the pixels out of the image into a nested list format.
1241 format is: (( row_1 )
1246 (goto-char xpm-body-start)
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))))
1257 (defun xpm-rotate-image-cw ()
1258 "Rotates the image 90 degrees clockwise.
1259 Modifies the x and y size in the image."
1261 (let ((xpm-pixels (xpm-read-pixels-in)))
1263 (goto-char xpm-body-start)
1264 (loop for x from 0 to (1- xpm-xsize)
1267 (loop for y from (1- xpm-ysize) downto 0
1268 do (insert (nth x (nth y xpm-pixels))))
1271 (loop until (search-forward "XPMEXT" (point-at-eol) t)
1274 (delete-region (point-at-bol) (point-at-eol))
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)))
1287 (defun xpm-rotate-image-ccw ()
1288 "Rotates the image 90 degrees counterclockwise.
1289 Modifies the x and y size in the image."
1291 (let ((xpm-pixels (xpm-read-pixels-in)))
1293 (goto-char xpm-body-start)
1294 (loop for x from (1- xpm-xsize) downto 0
1297 (loop for y from 0 to (1- xpm-ysize)
1298 do (insert (nth x (nth y xpm-pixels))))
1301 (loop until (search-forward "XPMEXT" (point-at-eol) t)
1304 (delete-region (point-at-bol) (point-at-eol))
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)))
1316 (defun xpm-mirror-image-vertical-axis ()
1317 "Mirrors an image about a vertical axis."
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))
1329 (loop for pixel from (1- xpm-xsize) downto 0
1330 do (insert (nth pixel row)))
1334 (unless (search-forward "};" nil t)
1335 (search-backward "\",")
1336 (replace-match "\"};")))))
1339 (defun xpm-mirror-image-horizontal-axis ()
1340 "Mirrors an image about a horizontal axis."
1344 (goto-char xpm-body-start)
1345 (setq rows (loop repeat xpm-ysize
1346 collect (buffer-substring (point-at-bol) (point-at-eol))
1348 (goto-char xpm-body-start)
1349 (loop for row in (nreverse rows)
1352 (loop until (search-forward "XPMEXT" (point-at-eol) t)
1355 (delete-region (point-at-bol) (point-at-eol))
1357 (unless (search-forward "};" nil t)
1358 (search-backward "\",")
1359 (replace-match "\"};")))
1360 (search-backward "};")
1361 (and (search-backward "};" nil t) (replace-match ",")))
1364 (defun xpm-eyedropper-tool ()
1365 "Sets the xpm tool to eyedropper."
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)))
1371 (defun xpm-pencil-tool ()
1372 "Sets the xpm tool to pencil."
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)))
1378 (defun xpm-select-tool ()
1379 "Sets the xpm tool to select."
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)))
1386 (defun xpm-crop (&optional point mark)
1387 "Crops to a rectangle described by point and mark."
1390 (setq point (point)))
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))
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)))
1415 (goto-line (line-number left))
1416 (search-forward "\"")
1417 (setq left-margin (- left (point)))
1418 (goto-line (line-number right))
1419 (search-forward "\",")
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)))
1429 (loop repeat bottom-margin
1430 do (delete-region (point-at-bol) (point-at-bol 2)))
1431 (unless (search-forward "};" nil t)
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 "\"")
1442 (delete-backward-char right-margin)
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)))
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: ")
1457 (goto-char xpm-body-start)
1458 (search-forward "\"")
1459 (search-forward "\"")
1461 (loop repeat xpm-ysize
1462 do (loop repeat x do (insert xpm-paint-string))
1464 (search-forward "\"")
1465 (search-forward "\"")
1467 (setq xpm-xsize (+ xpm-xsize x))
1471 (loop repeat xpm-xsize do (insert xpm-paint-string))
1473 (unless (search-forward "};" nil t)
1474 (search-backward "\",")
1475 (replace-match "\"};"))
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)
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)
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))
1499 (defun xpm-show-characters ()
1500 "Sets the `xpm-show-characters' flag, and re-sets all the faces"
1502 (setq xpm-show-characters t)
1503 (loop for (str . face) in xpm-pixel-values
1505 (let ((ccc (color-rgb-components (face-background face))))
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"))))))
1514 (defun xpm-hide-characters ()
1515 "Clears the `xpm-show-characters' flag, and re-sets all the faces"
1517 (setq xpm-show-characters nil)
1518 (loop for (str . face) in xpm-pixel-values
1520 (set-face-foreground face (face-background face))))
1522 (defun xpm-show-image ()
1523 "Display the xpm in the current buffer at the end of the topmost line"
1526 (if (annotationp xpm-anno)
1527 (delete-annotation xpm-anno))
1528 (setq xpm-glyph (make-glyph
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))))
1535 (defun xpm-hide-image ()
1536 "Remove the image of the xpm from the buffer"
1538 (if (annotationp xpm-anno)
1539 (delete-annotation xpm-anno)))
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): ")))
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)))
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)))
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)))
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)
1568 (mapcar #'(lambda (but)
1569 (aset but 2 (not (eq color (aref but 3))))
1572 (xpm-set-paint-str chars)
1573 (set-specifier left-toolbar (cons (current-buffer) xpm-palette)))
1575 (defun xpm-help-display ()
1576 "Displays a new frame with the help for this mode in it."
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)
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.
1593 Default XPM Mode Keymap:
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
1603 M-up xpm-shift-up Shifts the image up on the
1605 M-down xpm-shift-down Shifts the image down on the
1607 M-left xpm-shift-left Shifts the image left on the
1609 M-right xpm-shift-right Shifts the image right on the
1612 M-m M-l xpm-rotate-left Rotates the image left
1613 M-m M-r xpm-rotate-right Rotates the image right
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
1620 M-m M-c xpm-crop Allows you to crop using the
1622 M-m M-e xpm-enlarge Pads the image on the bottom
1623 and right side with the
1625 M-m M-l xpm-show-characters Shows the characters in the
1627 M-m M-i xpm-hide-characters Hides the characters in the
1629 M-m M-f1 xpm-mode-help Pulls up a new frame with this
1630 help document in it.
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.
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.
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.
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
1664 To assign a new function to a key, try the following:
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.
1672 It's as easy as that!")
1673 (raise-frame help-frame)))
1675 (defun xpm-mouse-down (event n)
1676 ; (interactive "ep")
1678 ('xpm-pencil (mouse-set-point event)
1679 (unless xpm-paint-string (error "Select a color before painting!"))
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
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
1694 (if (xpm-in-colorsp)
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))
1705 (goto-char (extent-end-position ext2)))
1706 (goto-char (extent-end-position ext1))
1708 (goto-char (extent-start-position ext2))))
1709 (zmacs-activate-region))
1710 ('xpm-eyedropper (mouse-set-point event)
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)
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)))))))))
1720 (defun xpm-set-paint-str (str)
1721 "Sets the current paint color."
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))))
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))
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))
1746 (defun xpm-mouse-drag (event n timeout)
1747 (case xpm-tool ('xpm-pencil (mouse-set-point event)
1751 ;; Much improved by not using font-lock-mode
1752 (or (string= xpm-paint-string
1753 (buffer-substring (point)
1754 (+ xpm-chars-per-pixel
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
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))))
1774 (defun xpm-mouse-up (event n)
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)
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)))))))))
1793 (defun xpm-toggle-chars ()
1794 "Toggles whether characters are shown in the editting area.
1795 Also modifies the toolbar icon."
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))
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))
1810 (set-specifier default-toolbar xpm-toolbar (current-buffer)))
1813 (defun xpm-movement-right ()
1814 "Move right after self-inserting character in Picture mode."
1816 (xpm-set-motion 0 1))
1818 (defun xpm-movement-left ()
1819 "Move left after self-inserting character in Picture mode."
1821 (xpm-set-motion 0 -1))
1823 (defun xpm-movement-up ()
1824 "Move up after self-inserting character in Picture mode."
1826 (xpm-set-motion -1 0))
1828 (defun xpm-movement-down ()
1829 "Move down after self-inserting character in Picture mode."
1831 (xpm-set-motion 1 0))
1833 (defun xpm-movement-nw ()
1834 "Move up and left after self-inserting character in Picture mode."
1836 (xpm-set-motion -1 -1))
1838 (defun xpm-movement-ne ()
1839 "Move up and right after self-inserting character in Picture mode."
1841 (xpm-set-motion -1 1))
1843 (defun xpm-movement-sw ()
1844 "Move down and left after self-inserting character in Picture mode."
1846 (xpm-set-motion 1 -1))
1848 (defun xpm-movement-se ()
1849 "Move down and right after self-inserting character in Picture mode."
1851 (xpm-set-motion 1 1))
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)
1860 (car (nthcdr (+ 1 (% horiz 2) (* 3 (1+ (% vert 2))))
1861 '(nw up ne left none right sw down se)))))
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)))
1905 ;--- Add an icon specification to the xpm-top-toolbar for each icon
1907 (defvar xpm-mode nil)
1908 (make-variable-buffer-local 'xpm-mode)
1909 (defvar xpm-mode-map nil)
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))
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 ]
1950 ["Lighten Image" xpm-lighten-image ]
1951 ["Darken Image" xpm-darken-image ]
1952 ["Show Characters" xpm-toggle-chars :style toggle :selected xpm-show-characters]
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 ])))
1963 (if xpm-gradient-menu
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 ])))
1972 ;;;###autoload(add-to-list 'auto-mode-alist '("\\.xpm$" . xpm-mode))
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
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.
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:
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)
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.
2027 ;;; xpm-mode.el ends here