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