Source

text-modes / xpm-mode.el

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
;;; xpm-mode.el	--- minor mode for editing XPM files

;; Copyright (C) 1995 Joe Rumsey <ogre@netcom.com>
;; Copyright (C) 1995 Rich Williams <rdw@hplb.hpl.hp.com>

;; Authors: Joe Rumsey <ogre@netcom.com>
;;	    Rich Williams <rdw@hplb.hpl.hp.com>
;; Cleanup: Chuck Thompson <cthomp@cs.uiuc.edu>

;; Version:  1.5
;; Last Modified: Rich Williams <rdw@hplb.hpl.hp.com>, 13 July 1995
;; Keywords: data tools

;; This file is part of XEmacs.

;; XEmacs is free software; you can redistribute it and/or modify it
;; under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; XEmacs is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with XEmacs; see the file COPYING.  If not, write to the 
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Synched up with: Not in FSF.

;;
;; xpm mode:  Display xpm files in color
;;
;; thanks to Rich Williams for mods to do this without font-lock-mode,
;; resulting in much improved performance and a better display
;; (headers don't get colored strangely). Also for the palette toolbar.
;;
;; Non-standard minor mode in that it starts picture-mode automatically.
;;
;; To get this turned on automatically for .xpms, add an entry
;;       ("\\.xpm" . xpm-mode)
;; to your auto-mode-alist.  For example, my .emacs has this: (abbreviated)
;; (setq auto-mode-alist (mapcar 'purecopy
;;                               '(("\\.c$" . c-mode)
;;                                ("\\.h$" . c-mode)
;;                                ("\\.el$" . emacs-lisp-mode)
;;				  ("\\.emacs$" . emacs-lisp-mode)
;;                                ("\\.a$" . c-mode)
;;				  ("\\.xpm" . xpm-mode))))
;; (autoload 'xpm-mode "xpm-mode")
;;
;; I am a lisp newbie, practically everything in here I had to look up
;; in the manual.  It probably shows, suggestions for coding
;; improvements are welcomed.
;;
;; May fail on some xpm's.  Seems to be fine with files generated by
;; xpaint and ppmtoxpm anyway.  Will definitely fail on xpm's with
;; more than one character per pixel.  Not that hard to fix, but I've
;; never seen one like that.
;;
;; If your default font is proportional, this will not be very useful.
;;

(require 'annotations)

(defvar xpm-pixel-values nil)
(defvar xpm-glyph nil)
(defvar xpm-anno nil)
(defvar xpm-paint-string nil)
(defvar xpm-chars-per-pixel 1)
(defvar xpm-palette nil)
(defvar xpm-always-update-image nil
  "If non-nil, update actual-size image after every click or drag movement.
Otherwise, only update on button releases or when asked to.  This is slow.")

(make-variable-buffer-local 'xpm-palette)
(make-variable-buffer-local 'xpm-chars-per-pixel)
(make-variable-buffer-local 'xpm-paint-string)
(make-variable-buffer-local 'xpm-glyph)
(make-variable-buffer-local 'xpm-anno)
(make-variable-buffer-local 'xpm-pixel-values)
;(make-variable-buffer-local 'xpm-faces-used)

(defun xpm-make-face (name)
  "Makes a face with name xpm-NAME, and colour NAME."
  (let ((face (make-face (intern (concat "xpm-" name))
			 "Temporary xpm-mode face" t)))
    (set-face-background face name)
    (set-face-foreground face "black")
    face))

(defun xpm-init ()
  "Treat the current buffer as an xpm file and colorize it."
  (interactive)
  (require 'picture)

  (setq xpm-pixel-values nil)
  (xpm-clear-extents)
  (setq xpm-palette nil)

  (message "Finding number of colors...")
  (save-excursion
    (goto-char (point-min))
    (beginning-of-line)
    (next-line 1)
    (while (and (not (eobp)) (not (looking-at "\\s-*\"")))
      (next-line 1))
    (next-line 1)
    (while (and (not (eobp)) (not (looking-at "\\s-*\"")))
      (next-line 1))

    (save-excursion
      (goto-char (point-min))
      (if (re-search-forward 
	   "\"\\s-*\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-*"
	   (point-max) t)
	  (setq xpm-chars-per-pixel (string-to-int (match-string 4)))))

    (let ((co 0))
      (while (< co (xpm-num-colors))
	(progn
	  (xpm-parse-color)
	  (setq co (1+ co))
	  (next-line 1)
	  (beginning-of-line)))))
  (if (not (eq major-mode 'picture-mode))
      (picture-mode))
  (if (featurep 'toolbar)
      (progn
	;; Use `current-buffer', not `selected-frame', here.
	;; Fixes bug where switching to another buffer causes its
	;; full-width left toolbar to be truncated to the xpm-mode
	;; palette (16 pixels).  Causes "window bounce" if sharing a
	;; frame with a window displaying a buffer with a full-width
	;; toolbar (suggested workaround: don't reset toolbar width
	;; for palette).
	(set-specifier left-toolbar-width (cons (current-buffer) 16))
	(set-specifier left-toolbar (cons (current-buffer) xpm-palette))))
  (message "Parsing body...")
  (xpm-color-data)
  (message "Parsing body...done")
  (xpm-show-image))

(defun xpm-clear-extents ()
  (let (cur-extent
	next-extent)
    (setq cur-extent (next-extent (current-buffer)))
    (setq next-extent (next-extent cur-extent))
    (while cur-extent
      (delete-extent cur-extent)
      (setq cur-extent next-extent)
      (setq next-extent (next-extent cur-extent)))))

(defun xpm-color-data ()
  (interactive)
  (save-excursion
    (xpm-goto-body-line 0)
    (let (ext
	  pixel-chars
	  pixel-color)
      (while (and (< (point) (point-max))
		  (< (+ (point) xpm-chars-per-pixel) (point-max)))
	(setq pixel-chars
	      (buffer-substring (point) (+ (point) xpm-chars-per-pixel))
	      pixel-color (assoc pixel-chars xpm-pixel-values)
	      ext (make-extent (point) (+ (point) xpm-chars-per-pixel)))
	(if pixel-color
	    (progn
	      (set-extent-face ext (cdr pixel-color)))
	  (set-extent-face ext 'default))
	(forward-char xpm-chars-per-pixel)))))

(defun xpm-num-colors ()
  (save-excursion
    (goto-char (point-min))
    (if (re-search-forward 
	 "\"\\s-*\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-*"
	 (point-max) t)
	(string-to-int (match-string 3))
      (error "Unable to parse xpm information"))))

(defun xpm-make-solid-pixmap (colour width height)
  (let ((x 0)
	(y 0)
	(line nil)
	(total nil))
    (setq line ",\n\"")
    (while (< x width)
      (setq line (concat line ".")
	    x (+ x 1)))
    (setq line (concat line "\"")
	  total (format "/* XPM */\nstatic char * %s[] = {\n\"%d %d 1 1\",\n\". c %s\""
			colour width height colour))
    (while (< y height)
      (setq total (concat total line)
	    y (+ y 1)))
    (make-glyph (concat total "};\n"))))

(defun xpm-store-color (str color)
  "Add STR to xpm-pixel-values with a new face set to background COLOR
if STR already has an entry, the existing face will be used, with the
new color replacing the old (on the display only, not in the xpm color
defs!)"
  (let (new-face)
    (setq new-face (xpm-make-face color))
    (set-face-background new-face color)
    (let ((ccc (color-rgb-components (make-color-specifier color))))
      (if (> (length ccc) 0)
	  (if (or (or (> (elt ccc 0) 32767)
		      (> (elt ccc 1) 32767))
		  (> (elt ccc 2) 32767))
	      (set-face-foreground new-face "black")
	    (set-face-foreground new-face "white"))))
    (setq xpm-pixel-values (cons (cons str new-face) xpm-pixel-values))
    (if (featurep 'toolbar)
	(setq xpm-palette
	      (cons (vector 
		     (list (xpm-make-solid-pixmap color 12 12))
		     ;; Major cool things with quotes.....
		     (` 
		      (lambda (event)
			(interactive "e")
			(xpm-toolbar-select-colour event (, str))))
		     t
		     color) xpm-palette)))
    ))

(defun xpm-parse-color ()
  "Parse xpm color string from current line and set the color"
  (interactive)
  (let (end)
    (save-excursion
      (end-of-line)
      (setq end (point))
      (beginning-of-line)
      (if (re-search-forward
	   ;; Generate a regexp on the fly
	   (concat "\"\\(" (make-string xpm-chars-per-pixel ?.) "\\)" ; chars
		   "\\(\\s-+[sm]\\s-+\\S-*\\)*"   ; s and m classes
		   "\\s-+\\([c]\\)"	          ; c class
		   "\\s-+\\([^ \t\"]+\\)")
	   end t)
	  (progn 
	    (xpm-store-color (match-string 1) (match-string 4))
	    (list (match-string 1) (match-string 4)))
	(error "Unable to parse color")))))

(defun xpm-add-color (str color)
  "add a color to an xpm's list of color defs"
  (interactive "sPixel character: 
sPixel color (any valid X color string):")
  (save-excursion
    (goto-char (point-min))
    (while (not (looking-at "\\s-*\""))
      (next-line 1))
    (next-line 1)
    (while (not (looking-at "\\s-*\""))
      (next-line 1))
    (let ((co 0))
      (while (< co (xpm-num-colors))
	(next-line 1)
	(setq co (1+ co))))
    (insert (format "\"%s\tc %s\",\n" str color))
    (previous-line 1)
    (xpm-parse-color)

    (goto-char (point-min))
    (while (not (looking-at "\\s-*\""))
      (next-line 1))
    (let ((entry 0))
      (while (or (= (char-after (point)) ? ) (= (char-after (point)) ?\"))
	(forward-char 1))
      (while (< entry 2)
	(progn
	  (if (eq (char-after (point)) ? )
	      (progn
		(setq entry (1+ entry))
		(while (eq (char-after (point)) ? )
		  (forward-char 1)))
	    (forward-char 1))))
      (let ((old-colors (xpm-num-colors)))
	(while (and (>= (char-after (point)) ?0) (<= (char-after (point)) ?9))
	  (delete-char 1))
      (insert (int-to-string (1+ old-colors)))))))


(defun xpm-goto-color-def (def)
  "move to color DEF in the xpm header"
  (interactive "nColor number:")
  (goto-char (point-min))
  (while (not (looking-at "\\s-*\""))
    (next-line 1))
  (next-line 1)
  (while (not (looking-at "\\s-*\""))
    (next-line 1))
  (next-line def))

(defun xpm-goto-body-line (line)
  "move to LINE lines down from the start of the body of an xpm"
  (interactive "nBody line:")
  (goto-char (point-min))
  (xpm-goto-color-def (xpm-num-colors))
  (next-line line))

(defun xpm-show-image ()
  "Display the xpm in the current buffer at the end of the topmost line"
  (interactive)
  (save-excursion
    (if (annotationp xpm-anno)
	(delete-annotation xpm-anno))
    (setq xpm-glyph (make-glyph 
		     (vector 'xpm :data 
			     (buffer-substring (point-min) (point-max)))))
    (goto-char (point-min))
    (end-of-line)
    (setq xpm-anno (make-annotation xpm-glyph (point) 'text))))

(defun xpm-hide-image ()
  "Remove the image of the xpm from the buffer"
  (interactive)
  (if (annotationp xpm-anno)
      (delete-annotation xpm-anno)))

(defun xpm-in-body ()
  (let ((p (point)))
    (save-excursion
      (xpm-goto-body-line 0)
      (> p (point)))))

(defvar xpm-mode nil)
(make-variable-buffer-local 'xpm-mode)
(add-minor-mode 'xpm-mode " XPM" nil)
(defvar xpm-mode-map (make-keymap))

(defun xpm-toolbar-select-colour (event chars)
  "Toolbar button"
  (let* ((button (event-toolbar-button event))
	 (help (and button (toolbar-button-help-string button))))
    (message "Toolbar selected %s (%s)"  help chars)
    (setq xpm-palette
	  (mapcar #'(lambda (but)
		      (aset but 2 (not (eq help (aref but 3))))
		      but)
		  xpm-palette)
	  xpm-paint-string chars)
    (set-specifier left-toolbar (cons (current-buffer) xpm-palette))))

(defun xpm-mouse-paint (event)
  (interactive "e")
  (mouse-set-point event)
  (if (xpm-in-body)
      ;; in body, overwrite the paint string where the mouse is clicked
      (progn
	(insert xpm-paint-string)
	(delete-char (length xpm-paint-string)))
    ;; otherwise, select the color defined by the line where the mouse
    ;; was clicked
    (save-excursion
      (beginning-of-line)
      (forward-char 1)
      (setq xpm-paint-string (buffer-substring (point) (1+ (point)))))))

(defun xpm-mouse-down (event n)
;  (interactive "ep")
  (mouse-set-point event)
  (if (xpm-in-body)
      ;; in body, overwrite the paint string where the mouse is clicked
      (progn
	(insert xpm-paint-string)
	(delete-char (length xpm-paint-string))
	(if xpm-always-update-image
	    (xpm-show-image))
	(let ((ext (make-extent (1- (point))
				(+ (1- (point)) xpm-chars-per-pixel)))
	      (pixel-color (assoc xpm-paint-string xpm-pixel-values)))
	  (if pixel-color
	      (set-extent-face ext (cdr pixel-color))
	    (set-extent-face ext 'default))))
    ;; otherwise, select the color defined by the line where the mouse
    ;; was clicked
    (save-excursion
      (beginning-of-line)
      (forward-char 1)
      (setq xpm-paint-string (buffer-substring (point) (1+ (point)))))))

(defun xpm-mouse-drag (event n timeout)
  (or timeout
      (progn
	(mouse-set-point event)
	(if (xpm-in-body)
	    ;; Much improved by not using font-lock-mode
	    (or (string= xpm-paint-string
			 (buffer-substring (point)
					   (+ (length xpm-paint-string)
					      (point))))
		(progn
		  (insert-char (string-to-char xpm-paint-string) 1)
					;	  (insert xpm-paint-string)
		  (delete-char (length xpm-paint-string))
		  (if xpm-always-update-image
		      (xpm-show-image))
		  (let ((ext (make-extent
			      (1- (point))
			      (+ (1- (point)) xpm-chars-per-pixel)))
			(pixel-color
			 (assoc xpm-paint-string xpm-pixel-values)))
		    (if pixel-color
			(set-extent-face ext (cdr pixel-color))
		      (set-extent-face ext 'default)))))))))

(defun xpm-mouse-up (event n)
  (xpm-show-image))

;;;###autoload(add-to-list 'auto-mode-alist '("\\.xpm$" . xpm-mode))

;;;###autoload
(defun xpm-mode (&optional arg)
  "Treat the current buffer as an xpm file and colorize it.

  Shift-button-1 lets you paint by dragging the mouse.  Shift-button-1 on a
color definition line will change the current painting color to that line's
value.

  Characters inserted from the keyboard will NOT be colored properly yet.
Use the mouse, or do xpm-init (\\[xpm-init]) after making changes.

\\[xpm-add-color] Add a new color, prompting for character and value
\\[xpm-show-image] show the current image at the top of the buffer
\\[xpm-parse-color] parse the current line's color definition and add
   it to the color table.  Provided as a means of changing colors.
XPM minor mode bindings:
\\{xpm-mode-map}"

  (interactive "P")
  (setq xpm-mode
	(if (null arg) (not xpm-mode)
	  (> (prefix-numeric-value arg) 0)))
  (if xpm-mode
      (progn
	(xpm-init)
	(make-local-variable 'mouse-track-down-hook)
	(make-local-variable 'mouse-track-drag-hook)
	(make-local-variable 'mouse-track-up-hook)
	(make-local-variable 'mouse-track-drag-up-hook)
	(make-local-variable 'mouse-track-click-hook)
	(setq mouse-track-down-hook 'xpm-mouse-down)
	(setq mouse-track-drag-hook 'xpm-mouse-drag)
	(setq mouse-track-up-hook 'xpm-mouse-up)
	(setq mouse-track-drag-up-hook 'xpm-mouse-up)
	(setq mouse-track-click-hook nil)
	(or (assq 'xpm-mode minor-mode-map-alist)
	    (progn
	      (define-key xpm-mode-map [(control c) r] 'xpm-show-image)
	      (define-key xpm-mode-map [(shift button1)] 'mouse-track)
	      (define-key xpm-mode-map [button1] 'mouse-track-default)
	      (define-key xpm-mode-map [(control c) c] 'xpm-add-color)
	      (define-key xpm-mode-map [(control c) p] 'xpm-parse-color)
	      (setq minor-mode-map-alist (cons (cons 'xpm-mode xpm-mode-map)
					       minor-mode-map-alist)))))))

(provide 'xpm-mode)
;;; xpm-mode.el ends here
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.