|
0
|
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
|
|
|
6 ;; Authors: Joe Rumsey <ogre@netcom.com>
|
|
|
7 ;; Rich Williams <rdw@hplb.hpl.hp.com>
|
|
|
8 ;; Cleanup: Chuck Thompson <cthomp@cs.uiuc.edu>
|
|
|
9
|
|
|
10 ;; Version: 1.5
|
|
|
11 ;; Last Modified: Rich Williams <rdw@hplb.hpl.hp.com>, 13 July 1995
|
|
|
12 ;; Keywords: data tools
|
|
|
13
|
|
|
14 ;; This file is part of XEmacs.
|
|
|
15
|
|
|
16 ;; XEmacs is free software; you can redistribute it and/or modify it
|
|
|
17 ;; under the terms of the GNU General Public License as published by
|
|
|
18 ;; the Free Software Foundation; either version 2, or (at your option)
|
|
|
19 ;; any later version.
|
|
|
20
|
|
|
21 ;; XEmacs is distributed in the hope that it will be useful, but
|
|
|
22 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
23 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
|
24 ;; General Public License for more details.
|
|
|
25
|
|
|
26 ;; You should have received a copy of the GNU General Public License
|
|
|
27 ;; along with XEmacs; see the file COPYING. If not, write to the Free
|
|
|
28 ;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
|
|
|
29
|
|
|
30 ;;; Synched up with: Not in FSF.
|
|
|
31
|
|
|
32 ;;
|
|
|
33 ;; xpm mode: Display xpm files in color
|
|
|
34 ;;
|
|
|
35 ;; thanks to Rich Williams for mods to do this without font-lock-mode,
|
|
|
36 ;; resulting in much improved performance and a better display
|
|
|
37 ;; (headers don't get colored strangely). Also for the palette toolbar.
|
|
|
38 ;;
|
|
|
39 ;; Non-standard minor mode in that it starts picture-mode automatically.
|
|
|
40 ;;
|
|
|
41 ;; To get this turned on automatically for .xpms, add an entry
|
|
|
42 ;; ("\\.xpm" . xpm-mode)
|
|
|
43 ;; to your auto-mode-alist. For example, my .emacs has this: (abbreviated)
|
|
|
44 ;; (setq auto-mode-alist (mapcar 'purecopy
|
|
|
45 ;; '(("\\.c$" . c-mode)
|
|
|
46 ;; ("\\.h$" . c-mode)
|
|
|
47 ;; ("\\.el$" . emacs-lisp-mode)
|
|
|
48 ;; ("\\.emacs$" . emacs-lisp-mode)
|
|
|
49 ;; ("\\.a$" . c-mode)
|
|
|
50 ;; ("\\.xpm" . xpm-mode))))
|
|
|
51 ;; (autoload 'xpm-mode "xpm-mode")
|
|
|
52 ;;
|
|
|
53 ;; I am a lisp newbie, practically everything in here I had to look up
|
|
|
54 ;; in the manual. It probably shows, suggestions for coding
|
|
|
55 ;; improvements are welcomed.
|
|
|
56 ;;
|
|
|
57 ;; May fail on some xpm's. Seems to be fine with files generated by
|
|
|
58 ;; xpaint and ppmtoxpm anyway. Will definitely fail on xpm's with
|
|
|
59 ;; more than one character per pixel. Not that hard to fix, but I've
|
|
|
60 ;; never seen one like that.
|
|
|
61 ;;
|
|
|
62 ;; If your default font is proportional, this will not be very useful.
|
|
|
63 ;;
|
|
|
64
|
|
|
65 (require 'annotations)
|
|
|
66
|
|
|
67 (defvar xpm-pixel-values nil)
|
|
|
68 (defvar xpm-glyph nil)
|
|
|
69 (defvar xpm-anno nil)
|
|
|
70 (defvar xpm-paint-string nil)
|
|
|
71 (defvar xpm-chars-per-pixel 1)
|
|
|
72 (defvar xpm-palette nil)
|
|
|
73 (defvar xpm-always-update-image nil
|
|
|
74 "If non-nil, update actual-size image after every click or drag movement.
|
|
|
75 Otherwise, only update on button releases or when asked to. This is slow.")
|
|
|
76
|
|
|
77 (make-variable-buffer-local 'xpm-palette)
|
|
|
78 (make-variable-buffer-local 'xpm-chars-per-pixel)
|
|
|
79 (make-variable-buffer-local 'xpm-paint-string)
|
|
|
80 (make-variable-buffer-local 'xpm-glyph)
|
|
|
81 (make-variable-buffer-local 'xpm-anno)
|
|
|
82 (make-variable-buffer-local 'xpm-pixel-values)
|
|
|
83 ;(make-variable-buffer-local 'xpm-faces-used)
|
|
|
84
|
|
|
85 (defun xpm-make-face (name)
|
|
|
86 "Makes a face with name xpm-NAME, and colour NAME."
|
|
|
87 (let ((face (make-face (intern (concat "xpm-" name))
|
|
|
88 "Temporary xpm-mode face" t)))
|
|
|
89 (set-face-background face name)
|
|
|
90 (set-face-foreground face "black")
|
|
|
91 face))
|
|
|
92
|
|
|
93 (defun xpm-init ()
|
|
|
94 "Treat the current buffer as an xpm file and colorize it."
|
|
|
95 (interactive)
|
|
|
96 (require 'picture)
|
|
|
97
|
|
|
98 (setq xpm-pixel-values nil)
|
|
|
99 (xpm-clear-extents)
|
|
|
100 (setq xpm-palette nil)
|
|
|
101
|
|
|
102 (message "Finding number of colors...")
|
|
|
103 (save-excursion
|
|
|
104 (goto-char (point-min))
|
|
|
105 (beginning-of-line)
|
|
|
106 (next-line 1)
|
|
|
107 (while (not (looking-at "\\s-*\""))
|
|
|
108 (next-line 1))
|
|
|
109 (next-line 1)
|
|
|
110 (while (not (looking-at "\\s-*\""))
|
|
|
111 (next-line 1))
|
|
4
|
112
|
|
|
113 (save-excursion
|
|
|
114 (goto-char (point-min))
|
|
|
115 (if (re-search-forward
|
|
|
116 "\"\\s-*\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-*"
|
|
|
117 (point-max) t)
|
|
|
118 (setq xpm-chars-per-pixel (string-to-int (match-string 4)))))
|
|
|
119
|
|
0
|
120 (let ((co 0))
|
|
|
121 (while (< co (xpm-num-colors))
|
|
|
122 (progn
|
|
|
123 (xpm-parse-color)
|
|
|
124 (setq co (1+ co))
|
|
|
125 (next-line 1)
|
|
|
126 (beginning-of-line)))))
|
|
|
127 (if (not (eq major-mode 'picture-mode))
|
|
|
128 (picture-mode))
|
|
2
|
129 (if (featurep 'toolbar)
|
|
|
130 (progn
|
|
|
131 (set-specifier left-toolbar-width (cons (selected-frame) 16))
|
|
|
132 (set-specifier left-toolbar (cons (current-buffer) xpm-palette))))
|
|
0
|
133 (message "Parsing body...")
|
|
|
134 (xpm-color-data)
|
|
|
135 (message "Parsing body...done")
|
|
|
136 (xpm-show-image))
|
|
|
137
|
|
|
138 (defun xpm-clear-extents ()
|
|
|
139 (let (cur-extent
|
|
|
140 next-extent)
|
|
|
141 (setq cur-extent (next-extent (current-buffer)))
|
|
|
142 (setq next-extent (next-extent cur-extent))
|
|
|
143 (while cur-extent
|
|
|
144 (delete-extent cur-extent)
|
|
|
145 (setq cur-extent next-extent)
|
|
|
146 (setq next-extent (next-extent cur-extent)))))
|
|
|
147
|
|
|
148 (defun xpm-color-data ()
|
|
|
149 (interactive)
|
|
|
150 (save-excursion
|
|
|
151 (xpm-goto-body-line 0)
|
|
|
152 (let (ext
|
|
|
153 pixel-chars
|
|
|
154 pixel-color)
|
|
4
|
155 (while (and (< (point) (point-max))
|
|
|
156 (< (+ (point) xpm-chars-per-pixel) (point-max)))
|
|
0
|
157 (setq pixel-chars
|
|
|
158 (buffer-substring (point) (+ (point) xpm-chars-per-pixel))
|
|
|
159 pixel-color (assoc pixel-chars xpm-pixel-values)
|
|
|
160 ext (make-extent (point) (+ (point) xpm-chars-per-pixel)))
|
|
|
161 (if pixel-color
|
|
|
162 (progn
|
|
|
163 (set-extent-face ext (cdr pixel-color)))
|
|
|
164 (set-extent-face ext 'default))
|
|
|
165 (forward-char xpm-chars-per-pixel)))))
|
|
|
166
|
|
|
167 (defun xpm-num-colors ()
|
|
|
168 (save-excursion
|
|
|
169 (goto-char (point-min))
|
|
|
170 (if (re-search-forward
|
|
|
171 "\"\\s-*\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-*"
|
|
|
172 (point-max) t)
|
|
|
173 (string-to-int (match-string 3))
|
|
|
174 (error "Unable to parse xpm information"))))
|
|
|
175
|
|
|
176 (defun xpm-make-solid-pixmap (colour width height)
|
|
|
177 (let ((x 0)
|
|
|
178 (y 0)
|
|
|
179 (line nil)
|
|
|
180 (total nil))
|
|
|
181 (setq line ",\n\"")
|
|
|
182 (while (< x width)
|
|
|
183 (setq line (concat line ".")
|
|
|
184 x (+ x 1)))
|
|
|
185 (setq line (concat line "\"")
|
|
|
186 total (format "/* XPM */\nstatic char * %s[] = {\n\"%d %d 1 1\",\n\". c %s\""
|
|
|
187 colour width height colour))
|
|
|
188 (while (< y height)
|
|
|
189 (setq total (concat total line)
|
|
|
190 y (+ y 1)))
|
|
|
191 (make-glyph (concat total "};\n"))))
|
|
|
192
|
|
|
193 (defun xpm-store-color (str color)
|
|
|
194 "Add STR to xpm-pixel-values with a new face set to background COLOR
|
|
|
195 if STR already has an entry, the existing face will be used, with the
|
|
|
196 new color replacing the old (on the display only, not in the xpm color
|
|
|
197 defs!)"
|
|
|
198 (let (new-face)
|
|
|
199 (setq new-face (xpm-make-face color))
|
|
|
200 (set-face-background new-face color)
|
|
|
201 (let ((ccc (color-rgb-components (make-color-specifier color))))
|
|
|
202 (if (> (length ccc) 0)
|
|
|
203 (if (or (or (> (elt ccc 0) 32767)
|
|
|
204 (> (elt ccc 1) 32767))
|
|
|
205 (> (elt ccc 2) 32767))
|
|
|
206 (set-face-foreground new-face "black")
|
|
|
207 (set-face-foreground new-face "white"))))
|
|
2
|
208 (setq xpm-pixel-values (cons (cons str new-face) xpm-pixel-values))
|
|
|
209 (if (featurep 'toolbar)
|
|
|
210 (setq xpm-palette
|
|
|
211 (cons (vector
|
|
|
212 (list (xpm-make-solid-pixmap color 12 12))
|
|
|
213 ;; Major cool things with quotes.....
|
|
|
214 (`
|
|
|
215 (lambda (event)
|
|
|
216 (interactive "e")
|
|
|
217 (xpm-toolbar-select-colour event (, str))))
|
|
|
218 t
|
|
|
219 color) xpm-palette)))
|
|
0
|
220 ))
|
|
|
221
|
|
|
222 (defun xpm-parse-color ()
|
|
|
223 "Parse xpm color string from current line and set the color"
|
|
|
224 (interactive)
|
|
|
225 (let (end)
|
|
|
226 (save-excursion
|
|
|
227 (end-of-line)
|
|
|
228 (setq end (point))
|
|
|
229 (beginning-of-line)
|
|
|
230 (if (re-search-forward
|
|
|
231 ;; Generate a regexp on the fly
|
|
|
232 (concat "\"\\(" (make-string xpm-chars-per-pixel ?.) "\\)" ; chars
|
|
|
233 "\\s-+\\([c]\\)" ; there are more classes than 'c'
|
|
|
234 "\\s-+\\([^\"]+\\)\"")
|
|
|
235 end t)
|
|
|
236 (progn
|
|
|
237 (xpm-store-color (match-string 1) (match-string 3))
|
|
|
238 (list (match-string 1) (match-string 3)))
|
|
|
239 (error "Unable to parse color")))))
|
|
|
240
|
|
|
241 (defun xpm-add-color (str color)
|
|
|
242 "add a color to an xpm's list of color defs"
|
|
|
243 (interactive "sPixel character:
|
|
|
244 sPixel color (any valid X color string):")
|
|
|
245 (save-excursion
|
|
|
246 (goto-char (point-min))
|
|
|
247 (while (not (looking-at "\\s-*\""))
|
|
|
248 (next-line 1))
|
|
|
249 (next-line 1)
|
|
|
250 (while (not (looking-at "\\s-*\""))
|
|
|
251 (next-line 1))
|
|
|
252 (let ((co 0))
|
|
|
253 (while (< co (xpm-num-colors))
|
|
|
254 (next-line 1)
|
|
|
255 (setq co (1+ co))))
|
|
|
256 (insert (format "\"%s\tc %s\",\n" str color))
|
|
|
257 (previous-line 1)
|
|
|
258 (xpm-parse-color)
|
|
|
259
|
|
|
260 (goto-char (point-min))
|
|
|
261 (while (not (looking-at "\\s-*\""))
|
|
|
262 (next-line 1))
|
|
|
263 (let ((entry 0))
|
|
|
264 (while (or (= (char-after (point)) ? ) (= (char-after (point)) ?\"))
|
|
|
265 (forward-char 1))
|
|
|
266 (while (< entry 2)
|
|
|
267 (progn
|
|
|
268 (if (eq (char-after (point)) ? )
|
|
|
269 (progn
|
|
|
270 (setq entry (1+ entry))
|
|
|
271 (while (eq (char-after (point)) ? )
|
|
|
272 (forward-char 1)))
|
|
|
273 (forward-char 1))))
|
|
|
274 (let ((old-colors (xpm-num-colors)))
|
|
|
275 (while (and (>= (char-after (point)) ?0) (<= (char-after (point)) ?9))
|
|
|
276 (delete-char 1))
|
|
|
277 (insert (int-to-string (1+ old-colors)))))))
|
|
|
278
|
|
|
279
|
|
|
280 (defun xpm-goto-color-def (def)
|
|
|
281 "move to color DEF in the xpm header"
|
|
|
282 (interactive "nColor number:")
|
|
|
283 (goto-char (point-min))
|
|
|
284 (while (not (looking-at "\\s-*\""))
|
|
|
285 (next-line 1))
|
|
|
286 (next-line 1)
|
|
|
287 (while (not (looking-at "\\s-*\""))
|
|
|
288 (next-line 1))
|
|
|
289 (next-line def))
|
|
|
290
|
|
|
291 (defun xpm-goto-body-line (line)
|
|
|
292 "move to LINE lines down from the start of the body of an xpm"
|
|
|
293 (interactive "nBody line:")
|
|
|
294 (goto-char (point-min))
|
|
|
295 (xpm-goto-color-def (xpm-num-colors))
|
|
|
296 (next-line line))
|
|
|
297
|
|
|
298 (defun xpm-show-image ()
|
|
|
299 "Display the xpm in the current buffer at the end of the topmost line"
|
|
|
300 (interactive)
|
|
|
301 (save-excursion
|
|
|
302 (if (annotationp xpm-anno)
|
|
|
303 (delete-annotation xpm-anno))
|
|
|
304 (setq xpm-glyph (make-glyph
|
|
|
305 (vector 'xpm :data
|
|
|
306 (buffer-substring (point-min) (point-max)))))
|
|
|
307 (goto-char (point-min))
|
|
|
308 (end-of-line)
|
|
|
309 (setq xpm-anno (make-annotation xpm-glyph (point) 'text))))
|
|
|
310
|
|
|
311 (defun xpm-hide-image ()
|
|
|
312 "Remove the image of the xpm from the buffer"
|
|
|
313 (interactive)
|
|
|
314 (if (annotationp xpm-anno)
|
|
|
315 (delete-annotation xpm-anno)))
|
|
|
316
|
|
|
317 (defun xpm-in-body ()
|
|
|
318 (let ((p (point)))
|
|
|
319 (save-excursion
|
|
|
320 (xpm-goto-body-line 0)
|
|
|
321 (> p (point)))))
|
|
|
322
|
|
|
323 (defvar xpm-mode nil)
|
|
|
324 (make-variable-buffer-local 'xpm-mode)
|
|
|
325 (add-minor-mode 'xpm-mode " XPM" nil)
|
|
|
326 (defvar xpm-mode-map (make-keymap))
|
|
|
327
|
|
|
328 (defun xpm-toolbar-select-colour (event chars)
|
|
|
329 "Toolbar button"
|
|
|
330 (let* ((button (event-toolbar-button event))
|
|
|
331 (help (toolbar-button-help-string button)))
|
|
|
332 (message "Toolbar selected %s (%s)" help chars)
|
|
|
333 (setq xpm-palette
|
|
|
334 (mapcar #'(lambda (but)
|
|
|
335 (aset but 2 (not (eq help (aref but 3))))
|
|
|
336 but)
|
|
|
337 xpm-palette)
|
|
|
338 xpm-paint-string chars)
|
|
|
339 (set-specifier left-toolbar (cons (current-buffer) xpm-palette))))
|
|
|
340
|
|
|
341 (defun xpm-mouse-paint (event)
|
|
|
342 (interactive "e")
|
|
|
343 (mouse-set-point event)
|
|
|
344 (if (xpm-in-body)
|
|
|
345 ;; in body, overwrite the paint string where the mouse is clicked
|
|
|
346 (progn
|
|
|
347 (insert xpm-paint-string)
|
|
|
348 (delete-char (length xpm-paint-string)))
|
|
|
349 ;; otherwise, select the color defined by the line where the mouse
|
|
|
350 ;; was clicked
|
|
|
351 (save-excursion
|
|
|
352 (beginning-of-line)
|
|
|
353 (forward-char 1)
|
|
|
354 (setq xpm-paint-string (buffer-substring (point) (1+ (point)))))))
|
|
|
355
|
|
|
356 (defun xpm-mouse-down (event n)
|
|
|
357 ; (interactive "ep")
|
|
|
358 (mouse-set-point event)
|
|
|
359 (if (xpm-in-body)
|
|
|
360 ;; in body, overwrite the paint string where the mouse is clicked
|
|
|
361 (progn
|
|
|
362 (insert xpm-paint-string)
|
|
|
363 (delete-char (length xpm-paint-string))
|
|
|
364 (if xpm-always-update-image
|
|
|
365 (xpm-show-image))
|
|
|
366 (let ((ext (make-extent (1- (point))
|
|
|
367 (+ (1- (point)) xpm-chars-per-pixel)))
|
|
|
368 (pixel-color (assoc xpm-paint-string xpm-pixel-values)))
|
|
|
369 (if pixel-color
|
|
|
370 (set-extent-face ext (cdr pixel-color))
|
|
|
371 (set-extent-face ext 'default))))
|
|
|
372 ;; otherwise, select the color defined by the line where the mouse
|
|
|
373 ;; was clicked
|
|
|
374 (save-excursion
|
|
|
375 (beginning-of-line)
|
|
|
376 (forward-char 1)
|
|
|
377 (setq xpm-paint-string (buffer-substring (point) (1+ (point)))))))
|
|
|
378
|
|
|
379 (defun xpm-mouse-drag (event n timeout)
|
|
|
380 (or timeout
|
|
|
381 (progn
|
|
|
382 (mouse-set-point event)
|
|
|
383 (if (xpm-in-body)
|
|
|
384 ;; Much improved by not using font-lock-mode
|
|
|
385 (or (string= xpm-paint-string
|
|
|
386 (buffer-substring (point)
|
|
|
387 (+ (length xpm-paint-string)
|
|
|
388 (point))))
|
|
|
389 (progn
|
|
|
390 (insert-char (string-to-char xpm-paint-string) 1)
|
|
|
391 ; (insert xpm-paint-string)
|
|
|
392 (delete-char (length xpm-paint-string))
|
|
|
393 (if xpm-always-update-image
|
|
|
394 (xpm-show-image))
|
|
|
395 (let ((ext (make-extent
|
|
|
396 (1- (point))
|
|
|
397 (+ (1- (point)) xpm-chars-per-pixel)))
|
|
|
398 (pixel-color
|
|
|
399 (assoc xpm-paint-string xpm-pixel-values)))
|
|
|
400 (if pixel-color
|
|
|
401 (set-extent-face ext (cdr pixel-color))
|
|
|
402 (set-extent-face ext 'default)))))))))
|
|
|
403
|
|
|
404 (defun xpm-mouse-up (event n)
|
|
|
405 (xpm-show-image))
|
|
|
406
|
|
|
407 ;;;###autoload
|
|
|
408 (defun xpm-mode (&optional arg)
|
|
|
409 "Treat the current buffer as an xpm file and colorize it.
|
|
|
410
|
|
|
411 Shift-button-1 lets you paint by dragging the mouse. Shift-button-1 on a
|
|
|
412 color definition line will change the current painting color to that line's
|
|
|
413 value.
|
|
|
414
|
|
|
415 Characters inserted from the keyboard will NOT be colored properly yet.
|
|
|
416 Use the mouse, or do xpm-init (\\[xpm-init]) after making changes.
|
|
|
417
|
|
|
418 \\[xpm-add-color] Add a new color, prompting for character and value
|
|
|
419 \\[xpm-show-image] show the current image at the top of the buffer
|
|
|
420 \\[xpm-parse-color] parse the current line's color definition and add
|
|
|
421 it to the color table. Provided as a means of changing colors.
|
|
|
422 XPM minor mode bindings:
|
|
|
423 \\{xpm-mode-map}"
|
|
|
424
|
|
|
425 (interactive "P")
|
|
|
426 (setq xpm-mode
|
|
|
427 (if (null arg) (not xpm-mode)
|
|
|
428 (> (prefix-numeric-value arg) 0)))
|
|
|
429 (if xpm-mode
|
|
|
430 (progn
|
|
|
431 (xpm-init)
|
|
|
432 (make-local-variable 'mouse-track-down-hook)
|
|
|
433 (make-local-variable 'mouse-track-drag-hook)
|
|
|
434 (make-local-variable 'mouse-track-up-hook)
|
|
|
435 (make-local-variable 'mouse-track-drag-up-hook)
|
|
|
436 (make-local-variable 'mouse-track-click-hook)
|
|
|
437 (setq mouse-track-down-hook 'xpm-mouse-down)
|
|
|
438 (setq mouse-track-drag-hook 'xpm-mouse-drag)
|
|
|
439 (setq mouse-track-up-hook 'xpm-mouse-up)
|
|
|
440 (setq mouse-track-drag-up-hook 'xpm-mouse-up)
|
|
|
441 (setq mouse-track-click-hook nil)
|
|
|
442 (or (assq 'xpm-mode minor-mode-map-alist)
|
|
|
443 (progn
|
|
|
444 (define-key xpm-mode-map [(control c) r] 'xpm-show-image)
|
|
|
445 (define-key xpm-mode-map [(shift button1)] 'mouse-track)
|
|
|
446 (define-key xpm-mode-map [button1] 'mouse-track-default)
|
|
|
447 (define-key xpm-mode-map [(control c) c] 'xpm-add-color)
|
|
|
448 (define-key xpm-mode-map [(control c) p] 'xpm-parse-color)
|
|
|
449 (setq minor-mode-map-alist (cons (cons 'xpm-mode xpm-mode-map)
|
|
|
450 minor-mode-map-alist)))))))
|
|
|
451
|
|
|
452 (provide 'xpm-mode)
|
|
|
453 ;;; xpm-mode.el ends here
|
