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