Mercurial > hg > xemacs-beta

comparison lisp/modes/xpm-mode.el @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children ac2d302a0011
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
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))
112 (let ((co 0))
113 (while (< co (xpm-num-colors))
114 (progn
115 (xpm-parse-color)
116 (setq co (1+ co))
117 (next-line 1)
118 (beginning-of-line)))))
119 (if (not (eq major-mode 'picture-mode))
120 (picture-mode))
121 (set-specifier left-toolbar-width (cons (selected-frame) 16))
122 (set-specifier left-toolbar (cons (current-buffer) xpm-palette))
123 (message "Parsing body...")
124 (xpm-color-data)
125 (message "Parsing body...done")
126 (xpm-show-image))
127
128 (defun xpm-clear-extents ()
129 (let (cur-extent
130 next-extent)
131 (setq cur-extent (next-extent (current-buffer)))
132 (setq next-extent (next-extent cur-extent))
133 (while cur-extent
134 (delete-extent cur-extent)
135 (setq cur-extent next-extent)
136 (setq next-extent (next-extent cur-extent)))))
137
138 (defun xpm-color-data ()
139 (interactive)
140 (save-excursion
141 (xpm-goto-body-line 0)
142 (let (ext
143 pixel-chars
144 pixel-color)
145 (while (< (point) (point-max))
146 (setq pixel-chars
147 (buffer-substring (point) (+ (point) xpm-chars-per-pixel))
148 pixel-color (assoc pixel-chars xpm-pixel-values)
149 ext (make-extent (point) (+ (point) xpm-chars-per-pixel)))
150 (if pixel-color
151 (progn
152 (set-extent-face ext (cdr pixel-color)))
153 (set-extent-face ext 'default))
154 (forward-char xpm-chars-per-pixel)))))
155
156 (defun xpm-num-colors ()
157 (save-excursion
158 (goto-char (point-min))
159 (if (re-search-forward
160 "\"\\s-*\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-*"
161 (point-max) t)
162 (string-to-int (match-string 3))
163 (error "Unable to parse xpm information"))))
164
165 (defun xpm-make-solid-pixmap (colour width height)
166 (let ((x 0)
167 (y 0)
168 (line nil)
169 (total nil))
170 (setq line ",\n\"")
171 (while (< x width)
172 (setq line (concat line ".")
173 x (+ x 1)))
174 (setq line (concat line "\"")
175 total (format "/* XPM */\nstatic char * %s[] = {\n\"%d %d 1 1\",\n\". c %s\""
176 colour width height colour))
177 (while (< y height)
178 (setq total (concat total line)
179 y (+ y 1)))
180 (make-glyph (concat total "};\n"))))
181
182 (defun xpm-store-color (str color)
183 "Add STR to xpm-pixel-values with a new face set to background COLOR
184 if STR already has an entry, the existing face will be used, with the
185 new color replacing the old (on the display only, not in the xpm color
186 defs!)"
187 (let (new-face)
188 (setq new-face (xpm-make-face color))
189 (set-face-background new-face color)
190 (let ((ccc (color-rgb-components (make-color-specifier color))))
191 (if (> (length ccc) 0)
192 (if (or (or (> (elt ccc 0) 32767)
193 (> (elt ccc 1) 32767))
194 (> (elt ccc 2) 32767))
195 (set-face-foreground new-face "black")
196 (set-face-foreground new-face "white"))))
197 (setq xpm-pixel-values (cons (cons str new-face) xpm-pixel-values)
198 xpm-palette
199 (cons (vector
200 (list (xpm-make-solid-pixmap color 12 12))
201 ;; Major cool things with quotes.....
202 (`
203 (lambda (event)
204 (interactive "e")
205 (xpm-toolbar-select-colour event (, str))))
206 t
207 color) xpm-palette))
208 ))
209
210 (defun xpm-parse-color ()
211 "Parse xpm color string from current line and set the color"
212 (interactive)
213 (let (end)
214 (save-excursion
215 (end-of-line)
216 (setq end (point))
217 (beginning-of-line)
218 (if (re-search-forward
219 ;; Generate a regexp on the fly
220 (concat "\"\\(" (make-string xpm-chars-per-pixel ?.) "\\)" ; chars
221 "\\s-+\\([c]\\)" ; there are more classes than 'c'
222 "\\s-+\\([^\"]+\\)\"")
223 end t)
224 (progn
225 (xpm-store-color (match-string 1) (match-string 3))
226 (list (match-string 1) (match-string 3)))
227 (error "Unable to parse color")))))
228
229 (defun xpm-add-color (str color)
230 "add a color to an xpm's list of color defs"
231 (interactive "sPixel character:
232 sPixel color (any valid X color string):")
233 (save-excursion
234 (goto-char (point-min))
235 (while (not (looking-at "\\s-*\""))
236 (next-line 1))
237 (next-line 1)
238 (while (not (looking-at "\\s-*\""))
239 (next-line 1))
240 (let ((co 0))
241 (while (< co (xpm-num-colors))
242 (next-line 1)
243 (setq co (1+ co))))
244 (insert (format "\"%s\tc %s\",\n" str color))
245 (previous-line 1)
246 (xpm-parse-color)
247
248 (goto-char (point-min))
249 (while (not (looking-at "\\s-*\""))
250 (next-line 1))
251 (let ((entry 0))
252 (while (or (= (char-after (point)) ? ) (= (char-after (point)) ?\"))
253 (forward-char 1))
254 (while (< entry 2)
255 (progn
256 (if (eq (char-after (point)) ? )
257 (progn
258 (setq entry (1+ entry))
259 (while (eq (char-after (point)) ? )
260 (forward-char 1)))
261 (forward-char 1))))
262 (let ((old-colors (xpm-num-colors)))
263 (while (and (>= (char-after (point)) ?0) (<= (char-after (point)) ?9))
264 (delete-char 1))
265 (insert (int-to-string (1+ old-colors)))))))
266
267
268 (defun xpm-goto-color-def (def)
269 "move to color DEF in the xpm header"
270 (interactive "nColor number:")
271 (goto-char (point-min))
272 (while (not (looking-at "\\s-*\""))
273 (next-line 1))
274 (next-line 1)
275 (while (not (looking-at "\\s-*\""))
276 (next-line 1))
277 (next-line def))
278
279 (defun xpm-goto-body-line (line)
280 "move to LINE lines down from the start of the body of an xpm"
281 (interactive "nBody line:")
282 (goto-char (point-min))
283 (xpm-goto-color-def (xpm-num-colors))
284 (next-line line))
285
286 (defun xpm-show-image ()
287 "Display the xpm in the current buffer at the end of the topmost line"
288 (interactive)
289 (save-excursion
290 (if (annotationp xpm-anno)
291 (delete-annotation xpm-anno))
292 (setq xpm-glyph (make-glyph
293 (vector 'xpm :data
294 (buffer-substring (point-min) (point-max)))))
295 (goto-char (point-min))
296 (end-of-line)
297 (setq xpm-anno (make-annotation xpm-glyph (point) 'text))))
298
299 (defun xpm-hide-image ()
300 "Remove the image of the xpm from the buffer"
301 (interactive)
302 (if (annotationp xpm-anno)
303 (delete-annotation xpm-anno)))
304
305 (defun xpm-in-body ()
306 (let ((p (point)))
307 (save-excursion
308 (xpm-goto-body-line 0)
309 (> p (point)))))
310
311 (defvar xpm-mode nil)
312 (make-variable-buffer-local 'xpm-mode)
313 (add-minor-mode 'xpm-mode " XPM" nil)
314 (defvar xpm-mode-map (make-keymap))
315
316 (defun xpm-toolbar-select-colour (event chars)
317 "Toolbar button"
318 (let* ((button (event-toolbar-button event))
319 (help (toolbar-button-help-string button)))
320 (message "Toolbar selected %s (%s)" help chars)
321 (setq xpm-palette
322 (mapcar #'(lambda (but)
323 (aset but 2 (not (eq help (aref but 3))))
324 but)
325 xpm-palette)
326 xpm-paint-string chars)
327 (set-specifier left-toolbar (cons (current-buffer) xpm-palette))))
328
329 (defun xpm-mouse-paint (event)
330 (interactive "e")
331 (mouse-set-point event)
332 (if (xpm-in-body)
333 ;; in body, overwrite the paint string where the mouse is clicked
334 (progn
335 (insert xpm-paint-string)
336 (delete-char (length xpm-paint-string)))
337 ;; otherwise, select the color defined by the line where the mouse
338 ;; was clicked
339 (save-excursion
340 (beginning-of-line)
341 (forward-char 1)
342 (setq xpm-paint-string (buffer-substring (point) (1+ (point)))))))
343
344 (defun xpm-mouse-down (event n)
345 ; (interactive "ep")
346 (mouse-set-point event)
347 (if (xpm-in-body)
348 ;; in body, overwrite the paint string where the mouse is clicked
349 (progn
350 (insert xpm-paint-string)
351 (delete-char (length xpm-paint-string))
352 (if xpm-always-update-image
353 (xpm-show-image))
354 (let ((ext (make-extent (1- (point))
355 (+ (1- (point)) xpm-chars-per-pixel)))
356 (pixel-color (assoc xpm-paint-string xpm-pixel-values)))
357 (if pixel-color
358 (set-extent-face ext (cdr pixel-color))
359 (set-extent-face ext 'default))))
360 ;; otherwise, select the color defined by the line where the mouse
361 ;; was clicked
362 (save-excursion
363 (beginning-of-line)
364 (forward-char 1)
365 (setq xpm-paint-string (buffer-substring (point) (1+ (point)))))))
366
367 (defun xpm-mouse-drag (event n timeout)
368 (or timeout
369 (progn
370 (mouse-set-point event)
371 (if (xpm-in-body)
372 ;; Much improved by not using font-lock-mode
373 (or (string= xpm-paint-string
374 (buffer-substring (point)
375 (+ (length xpm-paint-string)
376 (point))))
377 (progn
378 (insert-char (string-to-char xpm-paint-string) 1)
379 ; (insert xpm-paint-string)
380 (delete-char (length xpm-paint-string))
381 (if xpm-always-update-image
382 (xpm-show-image))
383 (let ((ext (make-extent
384 (1- (point))
385 (+ (1- (point)) xpm-chars-per-pixel)))
386 (pixel-color
387 (assoc xpm-paint-string xpm-pixel-values)))
388 (if pixel-color
389 (set-extent-face ext (cdr pixel-color))
390 (set-extent-face ext 'default)))))))))
391
392 (defun xpm-mouse-up (event n)
393 (xpm-show-image))
394
395 ;;;###autoload
396 (defun xpm-mode (&optional arg)
397 "Treat the current buffer as an xpm file and colorize it.
398
399 Shift-button-1 lets you paint by dragging the mouse. Shift-button-1 on a
400 color definition line will change the current painting color to that line's
401 value.
402
403 Characters inserted from the keyboard will NOT be colored properly yet.
404 Use the mouse, or do xpm-init (\\[xpm-init]) after making changes.
405
406 \\[xpm-add-color] Add a new color, prompting for character and value
407 \\[xpm-show-image] show the current image at the top of the buffer
408 \\[xpm-parse-color] parse the current line's color definition and add
409 it to the color table. Provided as a means of changing colors.
410 XPM minor mode bindings:
411 \\{xpm-mode-map}"
412
413 (interactive "P")
414 (setq xpm-mode
415 (if (null arg) (not xpm-mode)
416 (> (prefix-numeric-value arg) 0)))
417 (if xpm-mode
418 (progn
419 (xpm-init)
420 (make-local-variable 'mouse-track-down-hook)
421 (make-local-variable 'mouse-track-drag-hook)
422 (make-local-variable 'mouse-track-up-hook)
423 (make-local-variable 'mouse-track-drag-up-hook)
424 (make-local-variable 'mouse-track-click-hook)
425 (setq mouse-track-down-hook 'xpm-mouse-down)
426 (setq mouse-track-drag-hook 'xpm-mouse-drag)
427 (setq mouse-track-up-hook 'xpm-mouse-up)
428 (setq mouse-track-drag-up-hook 'xpm-mouse-up)
429 (setq mouse-track-click-hook nil)
430 (or (assq 'xpm-mode minor-mode-map-alist)
431 (progn
432 (define-key xpm-mode-map [(control c) r] 'xpm-show-image)
433 (define-key xpm-mode-map [(shift button1)] 'mouse-track)
434 (define-key xpm-mode-map [button1] 'mouse-track-default)
435 (define-key xpm-mode-map [(control c) c] 'xpm-add-color)
436 (define-key xpm-mode-map [(control c) p] 'xpm-parse-color)
437 (setq minor-mode-map-alist (cons (cons 'xpm-mode xpm-mode-map)
438 minor-mode-map-alist)))))))
439
440 (provide 'xpm-mode)
441 ;;; xpm-mode.el ends here