Mercurial > hg > xemacs-beta

comparison lisp/vm/tapestry.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 859a2309aef8
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
1 ;;; Tools to configure your GNU Emacs windows
2 ;;; Copyright (C) 1991, 1993, 1994, 1995 Kyle E. Jones
3 ;;;
4 ;;; This program is free software; you can redistribute it and/or modify
5 ;;; it under the terms of the GNU General Public License as published by
6 ;;; the Free Software Foundation; either version 1, or (at your option)
7 ;;; any later version.
8 ;;;
9 ;;; This program is distributed in the hope that it will be useful,
10 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12 ;;; GNU General Public License for more details.
13 ;;;
14 ;;; A copy of the GNU General Public License can be obtained from this
15 ;;; program's author (send electronic mail to kyle@uunet.uu.net) or from
16 ;;; the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA
17 ;;; 02139, USA.
18 ;;;
19 ;;; Send bug reports to kyle@uunet.uu.net.
20
21 (provide 'tapestry)
22
23 (defvar tapestry-version "1.07")
24
25 (defun tapestry (&optional frame-list)
26 "Returns a list containing complete information about the current
27 configuration of Emacs frames, windows, buffers and cursor
28 positions. Call the function set-tapestry with the list that this function
29 returns to restore the configuration.
30
31 Optional first arg FRAME-LIST should be a list of frames; only
32 configuration information about these frames will be returned.
33
34 The configuration information is returned in a form that can be saved and
35 restored across multiple Emacs sessions."
36 (let ((frames (or frame-list (tapestry-frame-list)))
37 (frame-map (tapestry-frame-map))
38 (sf (tapestry-selected-frame))
39 (other-maps nil))
40 (unwind-protect
41 (while frames
42 (tapestry-select-frame (car frames))
43 (setq other-maps (cons (list (tapestry-window-map)
44 (tapestry-buffer-map)
45 (tapestry-position-map))
46 other-maps)
47 frames (cdr frames)))
48 (tapestry-select-frame sf))
49 (list frame-map other-maps)))
50
51 (defun set-tapestry (map &optional n root-window-edges)
52 "Restore the frame/window/buffer configuration described by MAP,
53 which should be a list previously returned by a call to
54 tapestry.
55
56 Optional second arg N causes frame reconfiguration to be skipped
57 and the windows of the current frame will configured according to
58 the window map of the Nth frame in MAP.
59
60 Optional third arg ROOT-WINDOW-EDGES non-nil should be a list
61 containing the edges of a window in the current frame. This list
62 should be in the same form as returned by the `window-edges'
63 function. The window configuration from MAP will be restored in
64 this window. If no window with these exact edges exists, a
65 window that lies entirely within the edge coordinates will be
66 expanded until the edge coordinates match or the window bounded by
67 ROOT-WINDOW-EDGES is entirely contained within the expanded
68 window. If no window entirely within the ROOT-WINDOW-EDGES edge
69 coordinates can be found, the window with the greatest overlap of
70 ROOT-WINDOW-EDGES will be used."
71 (let ((sf (tapestry-selected-frame))
72 frame-list frame-map other-maps other-map)
73 (setq frame-map (nth 0 map)
74 other-maps (nth 1 map))
75 (if (and root-window-edges (null n))
76 (setq n 1))
77 (if n
78 (let (first-window)
79 (setq other-map (nth (1- n) other-maps))
80 (if (null other-map)
81 (error "No such map, %d" n))
82 (setq first-window
83 (tapestry-set-window-map (nth 0 other-map) root-window-edges))
84 (tapestry-set-buffer-map (nth 1 other-map) first-window)
85 (tapestry-set-position-map (nth 2 other-map) first-window))
86 (tapestry-set-frame-map frame-map)
87 ;; frame list is reversed relative to the map order because
88 ;; created frames are added to the head of the list instead
89 ;; of the tail.
90 (setq frame-list (nreverse (tapestry-frame-list)))
91 (unwind-protect
92 (while other-maps
93 (tapestry-select-frame (car frame-list))
94 (tapestry-set-window-map (nth 0 (car other-maps)))
95 (tapestry-set-buffer-map (nth 1 (car other-maps)))
96 (tapestry-set-position-map (nth 2 (car other-maps)))
97 (setq other-maps (cdr other-maps)
98 frame-list (cdr frame-list)))
99 (and (tapestry-frame-live-p sf) (tapestry-select-frame sf))))))
100
101 (defun tapestry-frame-map ()
102 (let ((map (mapcar 'tapestry-frame-parameters (tapestry-frame-list)))
103 list cell frame-list)
104 (setq list map
105 frame-list (tapestry-frame-list))
106 (while list
107 (setq cell (assq 'minibuffer (car list)))
108 (if (and cell (windowp (cdr cell)))
109 (if (eq (tapestry-window-frame (cdr cell)) (car frame-list))
110 (setcdr cell t)
111 (setcdr cell 'none)))
112 (setq list (cdr list)
113 frame-list (cdr frame-list)))
114 map ))
115
116 (defun tapestry-set-frame-map (map)
117 ;; some parameters can only be set only at frame creation time.
118 ;; so all existing frames must die.
119 (let ((doomed-frames (tapestry-frame-list)))
120 (while map
121 (tapestry-make-frame (car map))
122 (setq map (cdr map)))
123 (while doomed-frames
124 (tapestry-delete-frame (car doomed-frames))
125 (setq doomed-frames (cdr doomed-frames)))))
126
127 (defun tapestry-window-map ()
128 (let (maps map0 map1 map0-edges map1-edges x-unchanged y-unchanged)
129 (setq maps (mapcar 'tapestry-window-edges (tapestry-window-list)))
130 (while (cdr maps)
131 (setq map0 maps)
132 (while (cdr map0)
133 (setq map1 (cdr map0)
134 map0-edges (tapestry-find-window-map-edges (car map0))
135 map1-edges (tapestry-find-window-map-edges (car map1))
136 x-unchanged (and (= (car map0-edges) (car map1-edges))
137 (= (nth 2 map0-edges) (nth 2 map1-edges)))
138 y-unchanged (and (= (nth 1 map0-edges) (nth 1 map1-edges))
139 (= (nth 3 map0-edges) (nth 3 map1-edges))))
140 (cond ((and (not x-unchanged) (not y-unchanged))
141 (setq map0 (cdr map0)))
142 ((or (and x-unchanged (eq (car (car map0)) '-))
143 (and y-unchanged (eq (car (car map0)) '|)))
144 (nconc (car map0) (list (car map1)))
145 (setcdr map0 (cdr map1)))
146 (t
147 (setcar map0 (list (if x-unchanged '- '|)
148 (car map0)
149 (car map1)))
150 (setcdr map0 (cdr map1))))))
151 (car maps)))
152
153 (defun tapestry-set-window-map (map &optional root-window-edges)
154 (let ((map-width (tapestry-compute-map-width map))
155 (map-height (tapestry-compute-map-height map))
156 (root-window nil))
157 (if root-window-edges
158 (let (w-list w-edges w-area
159 exact-w inside-w overlap-w max-overlap overlap)
160 (while (null root-window)
161 (setq exact-w nil
162 inside-w nil
163 overlap-w nil
164 max-overlap -1
165 w-list (tapestry-window-list))
166 (while w-list
167 (setq w-edges (tapestry-window-edges (car w-list))
168 w-area (tapestry-window-area w-edges))
169 (if (equal w-edges root-window-edges)
170 (setq exact-w (car w-list)
171 w-list nil)
172 (setq overlap (tapestry-window-overlap w-edges
173 root-window-edges)
174 overlap (if overlap (tapestry-window-area overlap) 0)
175 w-area (tapestry-window-area w-edges))
176 (if (< max-overlap overlap)
177 (setq max-overlap overlap
178 overlap-w (car w-list)))
179 ;; set inside-w each time we find a window inside
180 ;; the root window edges. FSF Emacs gives space
181 ;; to the window above or to the left if there is
182 ;; such a window. therefore we want to find the
183 ;; inside window that is bottom-most or right-most so that
184 ;; when we delete it, its space will be given to
185 ;; what will be the root window.
186 (if (= w-area overlap)
187 (setq inside-w (car w-list)))
188 (setq w-list (cdr w-list))))
189 (cond (exact-w (setq root-window exact-w))
190 (inside-w
191 ;; how could a window be inside the root window
192 ;; edges and there only be one window? a
193 ;; multi-line minibuffer, that's how!
194 (if (not (one-window-p t))
195 (delete-window inside-w)))
196 (t (setq root-window overlap-w))))
197 (tapestry-apply-window-map map map-width map-height root-window)
198 root-window )
199 (if (tapestry-windows-match-map map map-width map-height)
200 (tapestry-first-window)
201 (delete-other-windows)
202 (setq root-window (selected-window))
203 (tapestry-apply-window-map map map-width map-height root-window)
204 root-window ))))
205
206 (defun tapestry-buffer-map ()
207 (let ((w-list (tapestry-window-list))
208 b list)
209 (while w-list
210 (setq b (window-buffer (car w-list))
211 list (cons (list (buffer-file-name b)
212 (buffer-name b))
213 list)
214 w-list (cdr w-list)))
215 (nreverse list)))
216
217 (defun tapestry-set-buffer-map (buffer-map &optional first-window)
218 (let ((w-list (tapestry-window-list first-window)) wb)
219 (while (and w-list buffer-map)
220 (setq wb (car buffer-map))
221 (set-window-buffer
222 (car w-list)
223 (if (car wb)
224 (or (get-file-buffer (car wb))
225 (find-file-noselect (car wb)))
226 (get-buffer-create (nth 1 wb))))
227 (setq w-list (cdr w-list)
228 buffer-map (cdr buffer-map)))))
229
230 (defun tapestry-position-map ()
231 (let ((sw (selected-window))
232 (w-list (tapestry-window-list))
233 list)
234 (while w-list
235 (setq list (cons (list (window-start (car w-list))
236 (window-point (car w-list))
237 (window-hscroll (car w-list))
238 (eq (car w-list) sw))
239 list)
240 w-list (cdr w-list)))
241 (nreverse list)))
242
243 (defun tapestry-set-position-map (position-map &optional first-window)
244 (let ((w-list (tapestry-window-list first-window))
245 (osw (selected-window))
246 sw p)
247 (while (and w-list position-map)
248 (setq p (car position-map))
249 (and (car p) (set-window-start (car w-list) (car p)))
250 (and (nth 1 p) (set-window-point (car w-list) (nth 1 p)))
251 (and (nth 2 p) (set-window-hscroll (car w-list) (nth 2 p)))
252 (and (nth 3 p) (setq sw (car w-list)))
253 ;; move this buffer up in the buffer-list
254 (select-window (car w-list))
255 (setq w-list (cdr w-list)
256 position-map (cdr position-map)))
257 (select-window (or sw osw))))
258
259 (defun tapestry-apply-window-map (map map-width map-height current-window
260 &optional
261 root-window-width
262 root-window-height)
263 (let ((window-min-height 1)
264 (window-min-width 1)
265 horizontal)
266 (if (null root-window-width)
267 (setq root-window-height (window-height current-window)
268 root-window-width (window-width current-window)))
269 (while map
270 (cond
271 ((numberp (car map)) (setq map nil))
272 ((eq (car map) '-) (setq horizontal nil))
273 ((eq (car map) '|) (setq horizontal t))
274 (t
275 (if (cdr map)
276 (split-window
277 current-window
278 (if horizontal
279 (/ (* (tapestry-compute-map-width (car map))
280 root-window-width)
281 map-width)
282 (/ (* (tapestry-compute-map-height (car map))
283 root-window-height)
284 map-height))
285 horizontal))
286 (if (not (numberp (car (car map))))
287 (setq current-window
288 (tapestry-apply-window-map (car map)
289 map-width map-height
290 current-window
291 root-window-width
292 root-window-height)))
293 (and (cdr map) (setq current-window (next-window current-window 0)))))
294 (setq map (cdr map)))
295 current-window ))
296
297 (defun tapestry-windows-match-map (map
298 &optional
299 map-width map-height
300 window-map
301 window-map-width
302 window-map-height)
303 (or map-width
304 (setq map-width (tapestry-compute-map-width map)
305 map-height (tapestry-compute-map-height map)))
306 (or window-map
307 (setq window-map (tapestry-window-map)
308 window-map-height (tapestry-compute-map-height window-map)
309 window-map-width (tapestry-compute-map-width window-map)))
310 (let ((result t))
311 (cond ((numberp (car map))
312 (and (numberp (car window-map))
313 (= (/ (* (nth 0 map) window-map-width)
314 map-width)
315 (nth 0 window-map))
316 (= (/ (* (nth 1 map) window-map-height)
317 map-height)
318 (nth 1 window-map))
319 (= (/ (* (nth 2 map) window-map-width)
320 map-width)
321 (nth 2 window-map))
322 (= (/ (* (nth 3 map) window-map-height)
323 map-height)
324 (nth 3 window-map))))
325 ((eq (car map) '-)
326 (if (not (eq (car window-map) '-))
327 nil
328 (setq map (cdr map)
329 window-map (cdr window-map))
330 (while (and result map window-map)
331 (setq result (tapestry-windows-match-map (car map)
332 map-width
333 map-height
334 (car window-map)
335 window-map-width
336 window-map-height)
337 map (cdr map)
338 window-map (cdr window-map)))
339 (and result (null map) (null window-map))))
340 ((eq (car map) '|)
341 (if (not (eq (car window-map) '|))
342 nil
343 (setq map (cdr map)
344 window-map (cdr window-map))
345 (while (and result map window-map)
346 (setq result (tapestry-windows-match-map (car map)
347 map-width
348 map-height
349 (car window-map)
350 window-map-width
351 window-map-height)
352 map (cdr map)
353 window-map (cdr window-map)))
354 (and result (null map) (null window-map)))))))
355
356 (defun tapestry-find-window-map-edges (map)
357 (let (nw-edges se-edges)
358 (setq nw-edges map)
359 (while (and (consp nw-edges) (not (numberp (car nw-edges))))
360 (setq nw-edges (car (cdr nw-edges))))
361 (setq se-edges map)
362 (while (and (consp se-edges) (not (numberp (car se-edges))))
363 (while (cdr se-edges)
364 (setq se-edges (cdr se-edges)))
365 (setq se-edges (car se-edges)))
366 (if (eq nw-edges se-edges)
367 nw-edges
368 (setq nw-edges (copy-sequence nw-edges))
369 (setcdr (nthcdr 1 nw-edges) (nthcdr 2 se-edges))
370 nw-edges )))
371
372 (defun tapestry-compute-map-width (map)
373 (let ((edges (tapestry-find-window-map-edges map)))
374 (- (nth 2 edges) (car edges))))
375
376 (defun tapestry-compute-map-height (map)
377 (let ((edges (tapestry-find-window-map-edges map)))
378 (- (nth 3 edges) (nth 1 edges))))
379
380 ;; delq is to memq as delassq is to assq
381 (defun tapestry-delassq (elt list)
382 (let ((prev nil)
383 (curr list))
384 (while curr
385 (if (eq elt (car (car curr)))
386 (if (null prev)
387 (setq list (cdr list) curr list)
388 (setcdr prev (cdr curr))
389 (setq curr (cdr curr)))
390 (setq prev curr curr (cdr curr))))
391 list ))
392
393 (defun tapestry-remove-frame-parameters (map params)
394 (let (frame-map)
395 (while params
396 (setq frame-map (nth 0 map))
397 (while frame-map
398 (setcar frame-map (tapestry-delassq (car params) (car frame-map)))
399 (setq frame-map (cdr frame-map)))
400 (setq params (cdr params)))))
401
402 (defun tapestry-nullify-tapestry-elements (map &optional buf-file-name buf-name
403 window-start window-point
404 window-hscroll selected-window)
405 (let (p)
406 (setq map (nth 1 map))
407 (while map
408 (setq p (nth 1 (car map)))
409 (while p
410 (and buf-file-name (setcar (car p) nil))
411 (and buf-name (setcar (cdr (car p)) nil))
412 (setq p (cdr p)))
413 (setq p (nth 2 (car map)))
414 (while p
415 (and window-start (setcar (car p) nil))
416 (and window-point (setcar (cdr (car p)) nil))
417 (and window-hscroll (setcar (nthcdr 2 (car p)) nil))
418 (and selected-window (setcar (nthcdr 3 (car p)) nil))
419 (setq p (cdr p)))
420 (setq map (cdr map)))))
421
422 (defun tapestry-replace-tapestry-element (map what function)
423 (let (mapi mapj p old new)
424 (cond ((eq what 'buffer-file-name)
425 (setq mapi 1 mapj 0))
426 ((eq what 'buffer-name)
427 (setq mapi 1 mapj 1))
428 ((eq what 'window-start)
429 (setq mapi 2 mapj 0))
430 ((eq what 'window-point)
431 (setq mapi 2 mapj 1))
432 ((eq what 'window-hscroll)
433 (setq mapi 2 mapj 2))
434 ((eq what 'selected-window)
435 (setq mapi 2 mapj 3)))
436 (setq map (nth 1 map))
437 (while map
438 (setq p (nth mapi (car map)))
439 (while p
440 (setq old (nth mapj (car p))
441 new (funcall function old))
442 (if (not (equal old new))
443 (setcar (nthcdr mapj (car p)) new))
444 (setq p (cdr p)))
445 (setq map (cdr map)))))
446
447 (defun tapestry-window-list (&optional first-window)
448 (let* ((first-window (or first-window (tapestry-first-window)))
449 (windows (cons first-window nil))
450 (current-cons windows)
451 (w (next-window first-window 'nomini)))
452 (while (not (eq w first-window))
453 (setq current-cons (setcdr current-cons (cons w nil)))
454 (setq w (next-window w 'nomini)))
455 windows ))
456
457 (defun tapestry-first-window ()
458 (if (eq (tapestry-selected-frame)
459 (tapestry-window-frame (minibuffer-window)))
460 (next-window (minibuffer-window))
461 (let ((w (selected-window))
462 (top (or (cdr (assq 'menu-bar-lines (tapestry-frame-parameters))) 0))
463 edges)
464 (while (or (not (= 0 (car (setq edges (tapestry-window-edges w)))))
465 ;; >= instead of = because in FSF Emacs 19.2x
466 ;; (whenever the Lucid menubar code was added) the
467 ;; menu-bar-lines frame parameter == 1 when the
468 ;; Lucid menubar is enabled even though the
469 ;; menubar doesn't steal the first line from the
470 ;; window.
471 (not (>= top (nth 1 edges))))
472 (setq w (next-window w 'nomini)))
473 w )))
474
475 (defun tapestry-window-area (edges)
476 (* (- (nth 3 edges) (nth 1 edges))
477 (- (nth 2 edges) (nth 0 edges))))
478
479 (defun tapestry-window-overlap (e0 e1)
480 (let (top left bottom right)
481 (cond ((and (<= (nth 0 e0) (nth 0 e1)) (< (nth 0 e1) (nth 2 e0)))
482 (setq left (nth 0 e1)))
483 ((and (<= (nth 0 e1) (nth 0 e0)) (< (nth 0 e0) (nth 2 e1)))
484 (setq left (nth 0 e0))))
485 (cond ((and (< (nth 0 e0) (nth 2 e1)) (<= (nth 2 e1) (nth 2 e0)))
486 (setq right (nth 2 e1)))
487 ((and (< (nth 0 e1) (nth 2 e0)) (<= (nth 2 e0) (nth 2 e1)))
488 (setq right (nth 2 e0))))
489 (cond ((and (<= (nth 1 e0) (nth 1 e1)) (< (nth 1 e1) (nth 3 e0)))
490 (setq top (nth 1 e1)))
491 ((and (<= (nth 1 e1) (nth 1 e0)) (< (nth 1 e0) (nth 3 e1)))
492 (setq top (nth 1 e0))))
493 (cond ((and (< (nth 1 e0) (nth 3 e1)) (<= (nth 3 e1) (nth 3 e0)))
494 (setq bottom (nth 3 e1)))
495 ((and (< (nth 1 e1) (nth 3 e0)) (<= (nth 3 e0) (nth 3 e1)))
496 (setq bottom (nth 3 e0))))
497 (and left top right bottom (list left top right bottom))))
498
499 (defun tapestry-window-edges (&optional window)
500 (if (fboundp 'window-pixel-edges)
501 (let ((edges (window-pixel-edges window))
502 tmp)
503 (setq tmp edges)
504 (setcar tmp (/ (car tmp) (face-width 'default)))
505 (setq tmp (cdr tmp))
506 (setcar tmp (/ (car tmp) (face-height 'default)))
507 (setq tmp (cdr tmp))
508 (setcar tmp (/ (car tmp) (face-width 'default)))
509 (setq tmp (cdr tmp))
510 (setcar tmp (/ (car tmp) (face-height 'default)))
511 edges )
512 (window-edges window)))
513
514 ;; We call these functions instead of calling the Emacs 19 frame
515 ;; functions directly to let this package work with v18 Emacs.
516
517 (defun tapestry-frame-list ()
518 (if (fboundp 'frame-list)
519 (frame-list)
520 (list nil)))
521
522 (defun tapestry-frame-parameters (&optional f)
523 (if (fboundp 'frame-parameters)
524 (frame-parameters f)
525 nil ))
526
527 (defun tapestry-window-frame (w)
528 (if (fboundp 'window-frame)
529 (window-frame w)
530 nil ))
531
532 (defun tapestry-modify-frame-parameters (f alist)
533 (if (fboundp 'modify-frame-parameters)
534 (modify-frame-parameters f alist)
535 nil ))
536
537 (defun tapestry-select-frame (f)
538 (if (fboundp 'select-frame)
539 (select-frame f)
540 nil ))
541
542 (defun tapestry-selected-frame ()
543 (if (fboundp 'selected-frame)
544 (selected-frame)
545 nil ))
546
547 (defun tapestry-next-frame (&optional f all)
548 (if (fboundp 'next-frame)
549 (next-frame f all)
550 nil ))
551
552 (defun tapestry-make-frame (&optional alist)
553 (if (fboundp 'make-frame)
554 (make-frame alist)
555 nil ))
556
557 (defun tapestry-delete-frame (&optional f)
558 (if (fboundp 'delete-frame)
559 (delete-frame f)
560 nil ))
561
562 (defun tapestry-frame-live-p (f)
563 (if (fboundp 'frame-live-p)
564 (frame-live-p f)
565 t ))