Mercurial > hg > xemacs-beta

comparison lisp/utils/live-icon.el @ 134:34a5b81f86ba r20-2b1

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-2b1
author cvs
date Mon, 13 Aug 2007 09:30:11 +0200
parents 9b50b4588a93
children 5a88923fcbfe
comparison
equal deleted inserted replaced
133:b27e67717092 134:34a5b81f86ba
4 ;; Copyright (C) 1995 Jamie Zawinski <jwz@netscape.com> 4 ;; Copyright (C) 1995 Jamie Zawinski <jwz@netscape.com>
5 5
6 ;; Authors: Rich Williams <rdw@hplb.hpl.hp.com> 6 ;; Authors: Rich Williams <rdw@hplb.hpl.hp.com>
7 ;; Jamie Zawinski <jwz@netscape.com> 7 ;; Jamie Zawinski <jwz@netscape.com>
8 8
9 ;; Version 1.2 9 ;; Minor cleanups and conversion from obsolete functions by
10 ;; Karl M. Hegbloom <karlheg@inetarena.com>
11
12 ;; Version 1.3
13
10 14
11 ;; This file is part of XEmacs. 15 ;; This file is part of XEmacs.
12 16
13 ;; XEmacs is free software; you can redistribute it and/or modify it 17 ;; XEmacs is free software; you can redistribute it and/or modify it
14 ;; under the terms of the GNU General Public License as published by 18 ;; under the terms of the GNU General Public License as published by
26 ;; Boston, MA 02111-1307, USA. 30 ;; Boston, MA 02111-1307, USA.
27 31
28 ;;; Synched up with: Not in FSF. 32 ;;; Synched up with: Not in FSF.
29 33
30 ;; Generates little pixmaps representing the contents of your frames. 34 ;; Generates little pixmaps representing the contents of your frames.
31
32 ;; #### This thing is somewhat of a mess and could stand some clean-up.
33
34 (defun live-icon-colour-name-from-face (face &optional bg-p)
35 "Do backward compatible things to faces and colours"
36 (if (and (boundp 'emacs-major-version)
37 (or (> emacs-major-version 19)
38 (and (= emacs-major-version 19)
39 (>= emacs-minor-version 12))))
40 (let* ((face (if (consp face) (car face) face))
41 (colour (if bg-p
42 (face-background face)
43 (face-foreground face))))
44 (if (consp colour)
45 (setq colour (cdr (car colour))))
46 (if (color-instance-p colour)
47 (setq colour (color-instance-name colour)))
48 (if (specifierp colour)
49 (setq colour (color-name colour)))
50 (if colour
51 (let ((hack (format "%s" colour)))
52 (if (string-match "(?\\([^)]*\\))?" hack)
53 (substring hack (match-beginning 1) (match-end 1))
54 hack))))
55 (let ((p (if bg-p (face-background face) (face-foreground face))))
56 (and (pixelp p)
57 (pixel-name p)))))
58 35
59 (defun live-icon-alloc-colour (cmv colour) 36 (defun live-icon-alloc-colour (cmv colour)
60 "Allocate a colour and a char from the magic vector" 37 "Allocate a colour and a char from the magic vector"
61 (let ((bob (assoc colour (aref cmv 0))) 38 (let ((bob (assoc colour (aref cmv 0)))
62 (jim (aref cmv 2))) 39 (jim (aref cmv 2)))
68 jim))) 45 jim)))
69 46
70 (defun live-icon-from-frame (&optional frame) 47 (defun live-icon-from-frame (&optional frame)
71 "Calculates the live-icon XPM of FRAME." 48 "Calculates the live-icon XPM of FRAME."
72 (if (not frame) 49 (if (not frame)
73 (setq frame (selected-screen))) 50 (setq frame (selected-frame)))
74 (save-excursion 51 (save-excursion
75 (select-screen frame) 52 (select-frame frame)
76 (let* ((w (screen-width)) 53 (let* ((w (frame-width))
77 (h (screen-height)) 54 (h (frame-height))
78 (pix (make-vector h nil)) 55 (pix (make-vector h nil))
79 (ny 0) 56 (ny 0)
80 (cmv (vector nil 0 ?A)) 57 (cmv (vector nil 0 ?A))
81 (d (live-icon-alloc-colour 58 (d (live-icon-alloc-colour
82 cmv (pixel-name (face-background 'default)))) 59 cmv (color-name (face-background 'default))))
83 (m (live-icon-alloc-colour 60 (m (live-icon-alloc-colour
84 cmv (pixel-name (face-background 'modeline)))) 61 cmv (color-name (face-background 'modeline))))
85 (x (live-icon-alloc-colour 62 (x (live-icon-alloc-colour
86 cmv (pixel-name (face-foreground 'default)))) 63 cmv (color-name (face-foreground 'default))))
87 y) 64 y)
88 (let ((loop 0)) 65 (let ((loop 0))
89 (while (< loop h) 66 (while (< loop h)
90 (aset pix loop (make-string w d)) 67 (aset pix loop (make-string w d))
91 (setq loop (1+ loop)))) 68 (setq loop (1+ loop))))
106 (< y (1- ny))) 83 (< y (1- ny)))
107 (while (and (not (eolp)) 84 (while (and (not (eolp))
108 (< (current-column) w)) 85 (< (current-column) w))
109 (if (> (char-after (point)) 32) 86 (if (> (char-after (point)) 32)
110 (let* ((ex (extent-at (point) (current-buffer) 'face)) 87 (let* ((ex (extent-at (point) (current-buffer) 'face))
111 (f (if ex (extent-face ex))) 88 (f (if ex (let ((f (extent-face ex)))
112 (z (if f (live-icon-colour-name-from-face f))) 89 (if (not (consp f))
90 f
91 (car f)))))
92 (z (if f (color-name (face-foreground f))))
113 (c (if z (live-icon-alloc-colour cmv z) x))) 93 (c (if z (live-icon-alloc-colour cmv z) x)))
114 (aset (aref pix y) (current-column) c))) 94 (aset (aref pix y) (current-column) c)))
115 (forward-char 1)) 95 (forward-char 1))
116 (setq y (1+ y)) 96 (setq y (1+ y))
117 (forward-line 1)))))) 97 (forward-line 1))))))
118 (sort (if (fboundp 'window-list) 98 (sort (if (fboundp 'window-list)
119 (window-list) 99 (window-list)
120 (let* ((w (screen-root-window)) 100 (let* ((w (frame-root-window))
121 (ws nil)) 101 (ws nil))
122 (while (not (memq (setq w (next-window w)) ws)) 102 (while (not (memq (setq w (next-window w)) ws))
123 (setq ws (cons w ws))) 103 (setq ws (cons w ws)))
124 ws)) 104 ws))
125 (if (fboundp 'window-pixel-edges)
126 #'(lambda (won woo) 105 #'(lambda (won woo)
127 (< (nth 1 (window-pixel-edges won)) 106 (< (nth 1 (window-pixel-edges won))
128 (nth 1 (window-pixel-edges woo)))) 107 (nth 1 (window-pixel-edges woo))))))
129 #'(lambda (won woo)
130 (< (nth 1 (window-edges won))
131 (nth 1 (window-edges woo)))))))
132 (concat "/* XPM */\nstatic char icon[] = {\n" 108 (concat "/* XPM */\nstatic char icon[] = {\n"
133 (format "\"%d %d %d 1\",\n" w (* h 2) (aref cmv 1)) 109 (format "\"%d %d %d 1\",\n" w (* h 2) (aref cmv 1))
134 (mapconcat #'(lambda (colour-entry) 110 (mapconcat #'(lambda (colour-entry)
135 (format "\"%c c %s\"" 111 (format "\"%c c %s\""
136 (cdr colour-entry) 112 (cdr colour-entry)
138 (aref cmv 0) 114 (aref cmv 0)
139 ",\n") 115 ",\n")
140 ",\n" 116 ",\n"
141 (mapconcat #'(lambda (scan-line) 117 (mapconcat #'(lambda (scan-line)
142 (concat "\"" scan-line "\"," "\n" 118 (concat "\"" scan-line "\"," "\n"
143 ;; "\"" scan-line "\""
144 "\"" (make-string w d) "\"," 119 "\"" (make-string w d) "\","
145 )) 120 ))
146 pix 121 pix
147 ",\n") 122 ",\n")
148 "};\n")))) 123 "};\n"))))
149 124
150
151 (defun live-icon-start-ppm-stuff (&optional frame)
152 "Start a live icon conversion going"
153 (interactive)
154 (if (not frame)
155 (setq frame (selected-screen)))
156 (let ((buf (get-buffer-create " *live-icon*")))
157 (message "live-icon...(backgrounding)")
158 (save-excursion
159 (set-buffer buf)
160 (erase-buffer))
161 (set-process-sentinel
162 (start-process-shell-command "live-icon"
163 buf
164 "xwd"
165 "-id" (format "%s" (x-window-id frame)) "|"
166 "xwdtopnm" "|"
167 "pnmscale" "-xysize" "64" "64" "|"
168 "ppmquant" "256" "|"
169 "ppmtoxpm")
170 #'(lambda (p s)
171 (message "live-icon...(munching)")
172 (save-excursion
173 (set-buffer " *live-icon*")
174 (goto-char (point-min))
175 (search-forward "/* XPM */")
176 (x-set-screen-icon-pixmap frame
177 (make-pixmap
178 (buffer-substring
179 (match-beginning 0) (point-max)))))
180 (message "live-icon...... done"))))
181 nil)
182
183
184 (defun live-icon-one-frame (&optional frame) 125 (defun live-icon-one-frame (&optional frame)
185 "Gives FRAME (defaulting to (selected-frame)) a live icon." 126 "Gives FRAME (defaulting to (selected-frame)) a live icon."
186 (interactive) 127 (interactive)
187 ; (message "Updating live icon...")
188 (if (not frame) 128 (if (not frame)
189 (setq frame (selected-screen))) 129 (setq frame (selected-frame)))
190 (x-set-screen-icon-pixmap frame (make-pixmap (live-icon-from-frame frame))) 130 (set-glyph-image frame-icon-glyph (live-icon-from-frame frame) frame))
191 ; (message "Updating live icon... done") 131
192 ) 132 ;;(defun live-icon-all-frames ()
193 133 ;; "Gives all your frames live-icons."
194 (defun live-icon-all-frames () 134 ;; (interactive)
195 "Gives all your frames live-icons." 135 ;; (mapcar #'(lambda (fr)
196 (interactive) 136 ;; (set-glyph-image frame-icon-glyph
197 (message "Updating live icons...") 137 ;; (live-icon-from-frame fr)
198 (mapcar #'(lambda (fr) 138 ;; fr))
199 (x-set-screen-icon-pixmap 139 ;; (frame-list)))
200 fr (make-pixmap (live-icon-from-frame fr))))
201 (screen-list))
202 (message "Updating live icons... done"))
203 140
204 (add-hook 'unmap-screen-hook 'live-icon-one-frame) 141 (add-hook 'unmap-screen-hook 'live-icon-one-frame)
205 ;;(start-itimer "live-icon" 'live-icon-all-frames 120 120) 142 ;;(start-itimer "live-icon" 'live-icon-all-frames 120 120)
206 143
207
208
209 (defun live-icon-goto-position (x y)
210 (let (window edges)
211 (catch 'done
212 (walk-windows
213 #'(lambda (w)
214 (setq edges (window-edges w))
215 (if (and (>= x (nth 0 edges))
216 (<= x (nth 2 edges))
217 (>= y (nth 1 edges))
218 (<= y (nth 3 edges)))
219 (throw 'done (setq window w))))
220 nil t))
221 (if (not window)
222 nil
223 (select-window window)
224 (move-to-window-line (- y (nth 1 edges)))
225 (move-to-column (- x (nth 0 edges)))
226 )))
227
228 (defun live-icon-make-image (width height)
229 (let* ((text-aspect 1.5)
230 (xscale (/ (/ (* (screen-width) 1.0) width) text-aspect))
231 (yscale (/ (* (screen-height) 1.0) height))
232 (x 0)
233 (y 0)
234 (cmv (vector nil 0 ?A))
235 (default-fg (live-icon-alloc-colour
236 cmv (pixel-name (face-foreground 'default))))
237 (default-bg (live-icon-alloc-colour
238 cmv (pixel-name (face-background 'default))))
239 (modeline-bg (live-icon-alloc-colour
240 cmv (pixel-name (face-background 'modeline))))
241 (lines (make-vector height nil)))
242 ;;
243 ;; Put in the text.
244 ;;
245 (save-excursion
246 (save-window-excursion
247 (while (< y height)
248 (aset lines y (make-string width default-bg))
249 (setq x 0)
250 (while (< x width)
251 (let ((sx (floor (* x xscale)))
252 (sy (floor (* y yscale))))
253 (live-icon-goto-position sx sy)
254 (let* ((extent (extent-at (point) (current-buffer) 'face))
255 (face (if extent (extent-face extent)))
256 (name (if face (live-icon-colour-name-from-face
257 face (<= (char-after (point)) 32))))
258 (color (if name
259 (live-icon-alloc-colour cmv name)
260 (if (<= (or (char-after (point)) 0) 32)
261 default-bg default-fg))))
262 (aset (aref lines y) x color)))
263 (setq x (1+ x)))
264 (setq y (1+ y)))))
265 ;;
266 ;; Now put in the modelines.
267 ;;
268 (let (sx sy)
269 (walk-windows
270 #'(lambda (w)
271 (let ((edges (window-edges w)))
272 (setq x (nth 0 edges)
273 y (nth 3 edges)
274 sx (floor (/ x xscale))
275 sy (floor (/ y yscale)))
276 (while (and (< x (1- (nth 2 edges)))
277 (< sx (length (aref lines 0))))
278 (aset (aref lines sy) sx modeline-bg)
279 (if (> sy 0)
280 (aset (aref lines (1- sy)) sx modeline-bg))
281 (setq x (1+ x)
282 sx (floor (/ x xscale))))
283 (if (>= sx (length (aref lines 0)))
284 (setq sx (1- sx)))
285 (while (>= y (nth 1 edges))
286 (aset (aref lines sy) sx modeline-bg)
287 (setq y (1- y)
288 sy (floor (/ y yscale))))))
289 nil nil))
290 ;;
291 ;; Now put in the top and left edges
292 ;;
293 (setq x 0)
294 (while (< x width)
295 (aset (aref lines 0) x modeline-bg)
296 (setq x (1+ x)))
297 (setq y 0)
298 (while (< y height)
299 (aset (aref lines y) 0 modeline-bg)
300 (setq y (1+ y)))
301 ;;
302 ;; Now make the XPM
303 ;;
304 (concat "/* XPM */\nstatic char icon[] = {\n"
305 (format "\"%d %d %d 1\",\n"
306 width
307 ;; (* height 2)
308 height
309 (aref cmv 1))
310 (mapconcat #'(lambda (colour-entry)
311 (format "\"%c c %s\""
312 (cdr colour-entry)
313 (car colour-entry)))
314 (aref cmv 0)
315 ",\n")
316 ",\n"
317 (mapconcat #'(lambda (scan-line)
318 (concat "\"" scan-line "\"," "\n"
319 ;; "\"" scan-line "\""
320 ;; "\"" (make-string width default-bg)
321 ;; "\","
322 ))
323 lines
324 ",\n")
325 "};\n")))
326
327 (provide 'live-icon) 144 (provide 'live-icon)
328 ;;; live-icon.el ends here 145 ;;; live-icon.el ends here
146
147
148
149 ;;;; Spare parts and leftovers department:
150
151 ;; #### This thing is somewhat of a mess and could stand some clean-up.
152
153 ;;(defun live-icon-colour-name-from-face (face &optional bg-p)
154 ;; "Do backward compatible things to faces and colours"
155 ;; (if (and (boundp 'emacs-major-version)
156 ;; (or (> emacs-major-version 19)
157 ;; (and (= emacs-major-version 19)
158 ;; (>= emacs-minor-version 12))))
159 ;; (let* ((face (if (consp face) (car face) face))
160 ;; (colour (if bg-p
161 ;; (face-background face)
162 ;; (face-foreground face))))
163 ;; (if (consp colour)
164 ;; (setq colour (cdr (car colour))))
165 ;; (if (color-instance-p colour)
166 ;; (setq colour (color-instance-name colour)))
167 ;; (if (specifierp colour)
168 ;; (setq colour (color-name colour)))
169 ;; (if colour
170 ;; (let ((hack (format "%s" colour)))
171 ;; (if (string-match "(?\\([^)]*\\))?" hack)
172 ;; (substring hack (match-beginning 1) (match-end 1))
173 ;; hack))))
174 ;; (let ((p (if bg-p (face-background face) (face-foreground face))))
175 ;; (and (pixelp p)
176 ;; ;; ** The following functions are not known to be defined: pixelp
177 ;; (pixel-name p)))))
178 ;;;; ** pixel-name is an obsolete function; use color-name instead.
179
180 ;;(defun live-icon-start-ppm-stuff (&optional frame)
181 ;; "Start a live icon conversion going"
182 ;; (interactive)
183 ;; (if (not frame)
184 ;; (setq frame (selected-frame)))
185 ;; (let ((buf (get-buffer-create " *live-icon*")))
186 ;; (message "live-icon...(backgrounding)")
187 ;; (save-excursion
188 ;; (set-buffer buf)
189 ;; (erase-buffer))
190 ;; (set-process-sentinel
191 ;; (start-process-shell-command "live-icon"
192 ;; buf
193 ;; "xwd"
194 ;; "-id" (format "%s" (x-window-id frame)) "|"
195 ;; "xwdtopnm" "|"
196 ;; "pnmscale" "-xysize" "64" "64" "|"
197 ;; "ppmquant" "256" "|"
198 ;; "ppmtoxpm")
199 ;; #'(lambda (p s)
200 ;; (message "live-icon...(munching)")
201 ;; (save-excursion
202 ;; (set-buffer " *live-icon*")
203 ;; (goto-char (point-min))
204 ;; (search-forward "/* XPM */")
205 ;; (set-glyph-image frame-icon-glyph
206 ;; (buffer-substring (match-beginning 0) (point-max))
207 ;; frame))
208 ;; (message "live-icon...... done"))))
209 ;; nil)
210
211 ;;(defun live-icon-goto-position (x y)
212 ;; (let (window edges)
213 ;; (catch 'done
214 ;; (walk-windows
215 ;; #'(lambda (w)
216 ;; (setq edges (window-edges w))
217 ;; (if (and (>= x (nth 0 edges))
218 ;; (<= x (nth 2 edges))
219 ;; (>= y (nth 1 edges))
220 ;; (<= y (nth 3 edges)))
221 ;; (throw 'done (setq window w))))
222 ;; nil t))
223 ;; (if (not window)
224 ;; nil
225 ;; (select-window window)
226 ;; (move-to-window-line (- y (nth 1 edges)))
227 ;; (move-to-column (- x (nth 0 edges)))
228 ;; )))
229
230 ;;(defun live-icon-make-image (width height)
231 ;; (let* ((text-aspect 1.5)
232 ;; (xscale (/ (/ (* (frame-width) 1.0) width) text-aspect))
233 ;; (yscale (/ (* (frame-height) 1.0) height))
234 ;; (x 0)
235 ;; (y 0)
236 ;; (cmv (vector nil 0 ?A))
237 ;; (default-fg (live-icon-alloc-colour
238 ;; cmv (color-name (face-foreground 'default))))
239 ;; (default-bg (live-icon-alloc-colour
240 ;; cmv (color-name (face-background 'default))))
241 ;; (modeline-bg (live-icon-alloc-colour
242 ;; cmv (color-name (face-background 'modeline))))
243 ;; (lines (make-vector height nil)))
244 ;; ;;
245 ;; ;; Put in the text.
246 ;; ;;
247 ;; (save-excursion
248 ;; (save-window-excursion
249 ;; (while (< y height)
250 ;; (aset lines y (make-string width default-bg))
251 ;; (setq x 0)
252 ;; (while (< x width)
253 ;; (let ((sx (floor (* x xscale)))
254 ;; (sy (floor (* y yscale))))
255 ;; (live-icon-goto-position sx sy)
256 ;; (let* ((extent (extent-at (point) (current-buffer) 'face))
257 ;; (face (if extent (extent-face extent)))
258 ;; (name (if face (live-icon-colour-name-from-face
259 ;; face (<= (char-after (point)) 32))))
260 ;; (color (if name
261 ;; (live-icon-alloc-colour cmv name)
262 ;; (if (<= (or (char-after (point)) 0) 32)
263 ;; default-bg default-fg))))
264 ;; (aset (aref lines y) x color)))
265 ;; (setq x (1+ x)))
266 ;; (setq y (1+ y)))))
267 ;; ;;
268 ;; ;; Now put in the modelines.
269 ;; ;;
270 ;; (let (sx sy)
271 ;; (walk-windows
272 ;; #'(lambda (w)
273 ;; (let ((edges (window-edges w)))
274 ;; (setq x (nth 0 edges)
275 ;; y (nth 3 edges)
276 ;; sx (floor (/ x xscale))
277 ;; sy (floor (/ y yscale)))
278 ;; (while (and (< x (1- (nth 2 edges)))
279 ;; (< sx (length (aref lines 0))))
280 ;; (aset (aref lines sy) sx modeline-bg)
281 ;; (if (> sy 0)
282 ;; (aset (aref lines (1- sy)) sx modeline-bg))
283 ;; (setq x (1+ x)
284 ;; sx (floor (/ x xscale))))
285 ;; (if (>= sx (length (aref lines 0)))
286 ;; (setq sx (1- sx)))
287 ;; (while (>= y (nth 1 edges))
288 ;; (aset (aref lines sy) sx modeline-bg)
289 ;; (setq y (1- y)
290 ;; sy (floor (/ y yscale))))))
291 ;; nil nil))
292 ;; ;;
293 ;; ;; Now put in the top and left edges
294 ;; ;;
295 ;; (setq x 0)
296 ;; (while (< x width)
297 ;; (aset (aref lines 0) x modeline-bg)
298 ;; (setq x (1+ x)))
299 ;; (setq y 0)
300 ;; (while (< y height)
301 ;; (aset (aref lines y) 0 modeline-bg)
302 ;; (setq y (1+ y)))
303 ;; ;;
304 ;; ;; Now make the XPM
305 ;; ;;
306 ;; (concat "/* XPM */\nstatic char icon[] = {\n"
307 ;; (format "\"%d %d %d 1\",\n"
308 ;; width
309 ;;;; (* height 2)
310 ;; height
311 ;; (aref cmv 1))
312 ;; (mapconcat #'(lambda (colour-entry)
313 ;; (format "\"%c c %s\""
314 ;; (cdr colour-entry)
315 ;; (car colour-entry)))
316 ;; (aref cmv 0)
317 ;; ",\n")
318 ;; ",\n"
319 ;; (mapconcat #'(lambda (scan-line)
320 ;; (concat "\"" scan-line "\"," "\n"
321 ;;;; "\"" scan-line "\""
322 ;;;; "\"" (make-string width default-bg)
323 ;;;; "\","
324 ;; ))
325 ;; lines
326 ;; ",\n")
327 ;; "};\n")))