Mercurial > hg > xemacs-beta

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