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
|
;; live-icon.el --- make frame icons represent the current frame contents
;; Copyright (C) 1995 Rich Williams <rdw@hplb.hpl.hp.com>
;; Copyright (C) 1995 Jamie Zawinski <jwz@netscape.com>
;; Authors: Rich Williams <rdw@hplb.hpl.hp.com>
;; Jamie Zawinski <jwz@netscape.com>
;; Minor cleanups and conversion from obsolete functions by
;; Karl M. Hegbloom <karlheg@inetarena.com>
;; Version 1.3
;; 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.
;; Generates little pixmaps representing the contents of your frames.
(defun live-icon-alloc-colour (cmv colour)
"Allocate a colour and a char from the magic vector"
(let ((bob (assoc colour (aref cmv 0)))
(jim (aref cmv 2)))
(if bob
(cdr bob)
(aset cmv 0 (cons (cons colour jim) (aref cmv 0)))
(aset cmv 1 (1+ (aref cmv 1)))
(aset cmv 2 (1+ jim))
jim)))
(defun live-icon-from-frame (&optional frame)
"Calculates the live-icon XPM of FRAME."
(if (not frame)
(setq frame (selected-frame)))
(save-excursion
(select-frame frame)
(let* ((w (frame-width))
(h (frame-height))
(pix (make-vector h nil))
(ny 0)
(cmv (vector nil 0 ?A))
(d (live-icon-alloc-colour
cmv (color-name (face-background 'default))))
(m (live-icon-alloc-colour
cmv (color-name (face-background 'modeline))))
(x (live-icon-alloc-colour
cmv (color-name (face-foreground 'default))))
y)
(let ((loop 0))
(while (< loop h)
(aset pix loop (make-string w d))
(setq loop (1+ loop))))
(mapcar #'(lambda (win)
(save-excursion
(save-window-excursion
(select-window win)
(save-restriction
(setq y ny
ny (+ ny (1- (window-height))))
(aset pix (- ny 2) (make-string w m))
(widen)
(if (> (window-end) (window-start))
(narrow-to-region (window-start)
(1- (window-end))))
(goto-char (point-min))
(while (and (not (eobp))
(< y (1- ny)))
(while (and (not (eolp))
(< (current-column) w))
(if (> (char-after (point)) 32)
(let* ((ex (extent-at (point) (current-buffer) 'face))
(f (if ex (let ((f (extent-face ex)))
(if (not (consp f))
f
(car f)))))
(z (if f (color-name (face-foreground f))))
(c (if z (live-icon-alloc-colour cmv z) x)))
(aset (aref pix y) (current-column) c)))
(forward-char 1))
(setq y (1+ y))
(forward-line 1))))))
(sort (if (fboundp 'window-list)
(window-list)
(let* ((w (frame-root-window))
(ws nil))
(while (not (memq (setq w (next-window w)) ws))
(setq ws (cons w ws)))
ws))
#'(lambda (won woo)
(< (nth 1 (window-pixel-edges won))
(nth 1 (window-pixel-edges woo))))))
(concat "/* XPM */\nstatic char icon[] = {\n"
(format "\"%d %d %d 1\",\n" w (* h 2) (aref cmv 1))
(mapconcat #'(lambda (colour-entry)
(format "\"%c c %s\""
(cdr colour-entry)
(car colour-entry)))
(aref cmv 0)
",\n")
",\n"
(mapconcat #'(lambda (scan-line)
(concat "\"" scan-line "\"," "\n"
"\"" (make-string w d) "\","
))
pix
",\n")
"};\n"))))
(defun live-icon-one-frame (&optional frame)
"Gives FRAME (defaulting to (selected-frame)) a live icon."
(interactive)
(unless frame
(setq frame (selected-frame)))
(unless (frame-property frame 'balloon-help)
(set-glyph-image frame-icon-glyph (live-icon-from-frame frame) frame)))
;;(defun live-icon-all-frames ()
;; "Gives all your frames live-icons."
;; (interactive)
;; (mapcar #'(lambda (fr)
;; (set-glyph-image frame-icon-glyph
;; (live-icon-from-frame fr)
;; fr))
;; (frame-list)))
(add-hook 'unmap-frame-hook 'live-icon-one-frame)
;;(start-itimer "live-icon" 'live-icon-all-frames 120 120)
(provide 'live-icon)
;;; live-icon.el ends here
;;;; Spare parts and leftovers department:
;; #### This thing is somewhat of a mess and could stand some clean-up.
;;(defun live-icon-colour-name-from-face (face &optional bg-p)
;; "Do backward compatible things to faces and colours"
;; (if (and (boundp 'emacs-major-version)
;; (or (> emacs-major-version 19)
;; (and (= emacs-major-version 19)
;; (>= emacs-minor-version 12))))
;; (let* ((face (if (consp face) (car face) face))
;; (colour (if bg-p
;; (face-background face)
;; (face-foreground face))))
;; (if (consp colour)
;; (setq colour (cdr (car colour))))
;; (if (color-instance-p colour)
;; (setq colour (color-instance-name colour)))
;; (if (specifierp colour)
;; (setq colour (color-name colour)))
;; (if colour
;; (let ((hack (format "%s" colour)))
;; (if (string-match "(?\\([^)]*\\))?" hack)
;; (substring hack (match-beginning 1) (match-end 1))
;; hack))))
;; (let ((p (if bg-p (face-background face) (face-foreground face))))
;; (and (pixelp p)
;; ;; ** The following functions are not known to be defined: pixelp
;; (pixel-name p)))))
;;;; ** pixel-name is an obsolete function; use color-name instead.
;;(defun live-icon-start-ppm-stuff (&optional frame)
;; "Start a live icon conversion going"
;; (interactive)
;; (if (not frame)
;; (setq frame (selected-frame)))
;; (let ((buf (get-buffer-create " *live-icon*")))
;; (message "live-icon...(backgrounding)")
;; (save-excursion
;; (set-buffer buf)
;; (erase-buffer))
;; (set-process-sentinel
;; (start-process-shell-command "live-icon"
;; buf
;; "xwd"
;; "-id" (format "%s" (x-window-id frame)) "|"
;; "xwdtopnm" "|"
;; "pnmscale" "-xysize" "64" "64" "|"
;; "ppmquant" "256" "|"
;; "ppmtoxpm")
;; #'(lambda (p s)
;; (message "live-icon...(munching)")
;; (save-excursion
;; (set-buffer " *live-icon*")
;; (goto-char (point-min))
;; (search-forward "/* XPM */")
;; (set-glyph-image frame-icon-glyph
;; (buffer-substring (match-beginning 0) (point-max))
;; frame))
;; (message "live-icon...... done"))))
;; nil)
;;(defun live-icon-goto-position (x y)
;; (let (window edges)
;; (catch 'done
;; (walk-windows
;; #'(lambda (w)
;; (setq edges (window-edges w))
;; (if (and (>= x (nth 0 edges))
;; (<= x (nth 2 edges))
;; (>= y (nth 1 edges))
;; (<= y (nth 3 edges)))
;; (throw 'done (setq window w))))
;; nil t))
;; (if (not window)
;; nil
;; (select-window window)
;; (move-to-window-line (- y (nth 1 edges)))
;; (move-to-column (- x (nth 0 edges)))
;; )))
;;(defun live-icon-make-image (width height)
;; (let* ((text-aspect 1.5)
;; (xscale (/ (/ (* (frame-width) 1.0) width) text-aspect))
;; (yscale (/ (* (frame-height) 1.0) height))
;; (x 0)
;; (y 0)
;; (cmv (vector nil 0 ?A))
;; (default-fg (live-icon-alloc-colour
;; cmv (color-name (face-foreground 'default))))
;; (default-bg (live-icon-alloc-colour
;; cmv (color-name (face-background 'default))))
;; (modeline-bg (live-icon-alloc-colour
;; cmv (color-name (face-background 'modeline))))
;; (lines (make-vector height nil)))
;; ;;
;; ;; Put in the text.
;; ;;
;; (save-excursion
;; (save-window-excursion
;; (while (< y height)
;; (aset lines y (make-string width default-bg))
;; (setq x 0)
;; (while (< x width)
;; (let ((sx (floor (* x xscale)))
;; (sy (floor (* y yscale))))
;; (live-icon-goto-position sx sy)
;; (let* ((extent (extent-at (point) (current-buffer) 'face))
;; (face (if extent (extent-face extent)))
;; (name (if face (live-icon-colour-name-from-face
;; face (<= (char-after (point)) 32))))
;; (color (if name
;; (live-icon-alloc-colour cmv name)
;; (if (<= (or (char-after (point)) 0) 32)
;; default-bg default-fg))))
;; (aset (aref lines y) x color)))
;; (setq x (1+ x)))
;; (setq y (1+ y)))))
;; ;;
;; ;; Now put in the modelines.
;; ;;
;; (let (sx sy)
;; (walk-windows
;; #'(lambda (w)
;; (let ((edges (window-edges w)))
;; (setq x (nth 0 edges)
;; y (nth 3 edges)
;; sx (floor (/ x xscale))
;; sy (floor (/ y yscale)))
;; (while (and (< x (1- (nth 2 edges)))
;; (< sx (length (aref lines 0))))
;; (aset (aref lines sy) sx modeline-bg)
;; (if (> sy 0)
;; (aset (aref lines (1- sy)) sx modeline-bg))
;; (setq x (1+ x)
;; sx (floor (/ x xscale))))
;; (if (>= sx (length (aref lines 0)))
;; (setq sx (1- sx)))
;; (while (>= y (nth 1 edges))
;; (aset (aref lines sy) sx modeline-bg)
;; (setq y (1- y)
;; sy (floor (/ y yscale))))))
;; nil nil))
;; ;;
;; ;; Now put in the top and left edges
;; ;;
;; (setq x 0)
;; (while (< x width)
;; (aset (aref lines 0) x modeline-bg)
;; (setq x (1+ x)))
;; (setq y 0)
;; (while (< y height)
;; (aset (aref lines y) 0 modeline-bg)
;; (setq y (1+ y)))
;; ;;
;; ;; Now make the XPM
;; ;;
;; (concat "/* XPM */\nstatic char icon[] = {\n"
;; (format "\"%d %d %d 1\",\n"
;; width
;;;; (* height 2)
;; height
;; (aref cmv 1))
;; (mapconcat #'(lambda (colour-entry)
;; (format "\"%c c %s\""
;; (cdr colour-entry)
;; (car colour-entry)))
;; (aref cmv 0)
;; ",\n")
;; ",\n"
;; (mapconcat #'(lambda (scan-line)
;; (concat "\"" scan-line "\"," "\n"
;;;; "\"" scan-line "\""
;;;; "\"" (make-string width default-bg)
;;;; "\","
;; ))
;; lines
;; ",\n")
;; "};\n")))
|
