home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / elisp / misc / screen.el < prev    next >
Encoding:
Text File  |  1993-02-06  |  8.9 KB  |  263 lines
  1. ;;; Tools to configure your GNU Emacs windows
  2. ;;; Copyright (C) 1991 Kyle E. Jones 
  3. ;;;
  4. ;;; LCD Archive Entry:
  5. ;;; screen|Kyle E. Jones|kyle@uunet.uu.net|
  6. ;;; Tools to configure your GNU Emacs windows.|
  7. ;;; 1991||~/misc/screen.el.Z|
  8. ;;;
  9. ;;; This program is free software; you can redistribute it and/or modify
  10. ;;; it under the terms of the GNU General Public License as published by
  11. ;;; the Free Software Foundation; either version 1, or (at your option)
  12. ;;; any later version.
  13. ;;;
  14. ;;; This program is distributed in the hope that it will be useful,
  15. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17. ;;; GNU General Public License for more details.
  18. ;;;
  19. ;;; A copy of the GNU General Public License can be obtained from this
  20. ;;; program's author (send electronic mail to kyle@uunet.uu.net) or from
  21. ;;; the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA
  22. ;;; 02139, USA.
  23. ;;;
  24. ;;; Send bug reports to kyle@uunet.uu.net.
  25.  
  26. (provide 'screen)
  27.  
  28. (defun screen-map ()
  29.   "Returns a list containing complete information about the current
  30. configuration of windows and buffers.  Call the function
  31. set-screen-map with this list to restore the current
  32. window/buffer configuration.
  33.  
  34. This is much like the function window-configuration except that
  35. the informatoin is returned in a form that can be saved and
  36. restored across multiple Emacs sessions."
  37.   (list (window-map) (buffer-map) (position-map)))
  38.  
  39. (defun set-screen-map (map)
  40.   "Restore the window/buffer configuration described by MAP,
  41. which should be a list previously returned by a call to
  42. screen-map."
  43.   (set-window-map (nth 0 map))
  44.   (set-buffer-map (nth 1 map))
  45.   (set-position-map (nth 2 map)))
  46.  
  47. (defun window-map ()
  48.   (let (w maps map0 map1 map0-edges map1-edges x-unchanged y-unchanged)
  49.     (setq maps (mapcar 'window-edges (screen-window-list)))
  50.     (while (cdr maps)
  51.       (setq map0 maps)
  52.       (while (cdr map0)
  53.     (setq map1 (cdr map0)
  54.           map0-edges (screen-find-window-map-edges (car map0))
  55.           map1-edges (screen-find-window-map-edges (car map1))
  56.           x-unchanged (and (= (car map0-edges) (car map1-edges))
  57.                    (= (nth 2 map0-edges) (nth 2 map1-edges)))
  58.           y-unchanged (and (= (nth 1 map0-edges) (nth 1 map1-edges))
  59.                    (= (nth 3 map0-edges) (nth 3 map1-edges))))
  60.     (cond ((and (not x-unchanged) (not y-unchanged))
  61.            (setq map0 (cdr map0)))
  62.           ((or (and x-unchanged (eq (car (car map0)) '-))
  63.            (and y-unchanged (eq (car (car map0)) '|)))
  64.            (nconc (car map0) (list (car map1)))
  65.            (setcdr map0 (cdr map1)))
  66.           (t
  67.            (setcar map0 (list (if x-unchanged '- '|)
  68.                   (car map0)
  69.                   (car map1)))
  70.            (setcdr map0 (cdr map1))))))
  71.     (car maps)))
  72.  
  73. (defun set-window-map (map)
  74.   (if (eq (selected-window) (minibuffer-window))
  75.       (delete-other-windows (next-window (minibuffer-window)))
  76.     (delete-other-windows))
  77.   (let (map-width map-height)
  78.     (setq map-width (screen-compute-map-width map)
  79.       map-height (screen-compute-map-height map))
  80.     (screen-apply-window-map map (next-window (minibuffer-window)))))
  81.  
  82. (defun buffer-map ()
  83.   (let ((w-list (screen-window-list))
  84.     b list)
  85.     (while w-list
  86.       (setq b (window-buffer (car w-list))
  87.         list (cons (list (buffer-file-name b)
  88.                  (buffer-name b))
  89.                list)
  90.         w-list (cdr w-list)))
  91.     (nreverse list)))
  92.  
  93. (defun set-buffer-map (buffer-map)
  94.   (let ((w-list (screen-window-list)) wb)
  95.     (while (and w-list buffer-map)
  96.       (setq wb (car buffer-map))
  97.       (set-window-buffer
  98.        (car w-list)
  99.        (if (car wb)
  100.        (or (get-file-buffer (car wb))
  101.            (find-file-noselect (car wb)))
  102.      (get-buffer-create (nth 1 wb))))
  103.       (setq w-list (cdr w-list)
  104.         buffer-map (cdr buffer-map)))))
  105.  
  106. (defun position-map ()
  107.   (let ((sw (selected-window))
  108.     (w-list (screen-window-list))
  109.     list)
  110.     (while w-list
  111.       (setq list (cons (list (window-start (car w-list))
  112.                  (window-point (car w-list))
  113.                  (window-hscroll (car w-list))
  114.                  (eq (car w-list) sw))
  115.                list)
  116.         w-list (cdr w-list)))
  117.     (nreverse list)))
  118.  
  119. (defun set-position-map (position-map)
  120.   (let ((w-list (screen-window-list)) (osw (selected-window)) sw p)
  121.     ;; select a window we don't care about so that when we select
  122.     ;; another window its buffer will be moved up in the buffer
  123.     ;; list.
  124.     (select-window (minibuffer-window))
  125.     (while (and w-list position-map)
  126.       (setq p (car position-map))
  127.       (and (car p) (set-window-start (car w-list) (car p)))
  128.       (and (nth 1 p) (set-window-point (car w-list) (nth 1 p)))
  129.       (and (nth 2 p) (set-window-hscroll (car w-list) (nth 2 p)))
  130.       (and (nth 3 p) (setq sw (car w-list)))
  131.       ;; move this buffer up in the buffer-list
  132.       (select-window (car w-list))
  133.       (setq w-list (cdr w-list)
  134.         position-map (cdr position-map)))
  135.     (select-window (or sw osw))))
  136.  
  137. (defun screen-window-list (&optional mini)
  138.   "Returns a list of Lisp window objects for all Emacs windows.
  139. Optional first arg MINIBUF t means include the minibuffer window
  140. in the list, even if it is not active.  If MINIBUF is neither t
  141. nor nil it means to not count the minibuffer window even if it is active."
  142.   (let* ((first-window (next-window (minibuffer-window)))
  143.      (windows (cons first-window nil))
  144.      (current-cons windows)
  145.      (w (next-window first-window mini)))
  146.     (while (not (eq w first-window))
  147.       (setq current-cons (setcdr current-cons (cons w nil)))
  148.       (setq w (next-window w mini)))
  149.     windows))
  150.  
  151. (defun screen-apply-window-map (map)
  152.   (let (horizontal)
  153.     (while map
  154.       (cond
  155.        ((numberp (car map)) (setq map nil))
  156.        ((eq (car map) '-) (split-window-vertically))
  157.        ((eq (car map) '|) (split-window-horizontally) (setq horizontal t))
  158.        (t
  159.     (if (cdr map)
  160.         (enlarge-window
  161.          (if horizontal
  162.          (- (/ (* (screen-compute-map-width (car map)) (screen-width))
  163.                map-width)
  164.             (1+ (window-width))) ;; 1+ cuz | is part of window
  165.            (- (/ (* (screen-compute-map-height (car map))
  166.             (1- (screen-height)))
  167.              map-height)
  168.           (window-height)))
  169.          horizontal))
  170.     (if (not (numberp (car (car map))))
  171.         (screen-apply-window-map (car map)))
  172.     (and (cdr map) (select-window (next-window)))
  173.     (and (cdr (cdr map)) (split-window nil nil horizontal))))
  174.       (setq map (cdr map)))))
  175.  
  176. (defun screen-apply-window-map (map current-window)
  177.   (let (horizontal)
  178.     (while map
  179.       (cond
  180.        ((numberp (car map)) (setq map nil))
  181.        ((eq (car map) '-))
  182.        ((eq (car map) '|) (setq horizontal t))
  183.        (t
  184.     (if (cdr map)
  185.         (split-window
  186.          current-window
  187.          (if horizontal
  188.          (1- (/ (* (screen-compute-map-width (car map)) (screen-width))
  189.                map-width))
  190.            (/ (* (screen-compute-map-height (car map))
  191.              (- (screen-height) (window-height (minibuffer-window))))
  192.           map-height))
  193.          horizontal))
  194.     (if (not (numberp (car (car map))))
  195.         (setq current-window
  196.           (screen-apply-window-map (car map) current-window)))
  197.     (and (cdr map) (setq current-window (next-window current-window)))))
  198.       (setq map (cdr map)))
  199.     current-window ))
  200.  
  201. (defun screen-find-window-map-edges (map)
  202.   (let (nw-edges se-edges)
  203.     (setq nw-edges map)
  204.     (while (and (consp nw-edges) (not (numberp (car nw-edges))))
  205.       (setq nw-edges (car (cdr nw-edges))))
  206.     (setq se-edges map)
  207.     (while (and (consp se-edges) (not (numberp (car se-edges))))
  208.       (while (cdr se-edges)
  209.     (setq se-edges (cdr se-edges)))
  210.       (setq se-edges (car se-edges)))
  211.     (if (eq nw-edges se-edges)
  212.     nw-edges
  213.       (setq nw-edges (copy-sequence nw-edges))
  214.       (setcdr (nthcdr 1 nw-edges) (nthcdr 2 se-edges))
  215.       nw-edges )))
  216.  
  217. (defun screen-compute-map-width (map)
  218.   (let ((edges (screen-find-window-map-edges map)))
  219.     (- (nth 2 edges) (car edges))))
  220.  
  221. (defun screen-compute-map-height (map)
  222.   (let ((edges (screen-find-window-map-edges map)))
  223.     (- (nth 3 edges) (nth 1 edges))))
  224.  
  225. (defun screen-nullify-map-elements (map &optional buffer-file-name buffer-name
  226.                     window-start window-point
  227.                     window-hscroll selected-window)
  228.   (let (p)
  229.     (setq p (nth 1 map))
  230.     (while p
  231.       (and buffer-file-name (setcar (car p) nil))
  232.       (and buffer-name (setcar (cdr (car p)) nil))
  233.       (setq p (cdr p)))
  234.     (setq p (nth 2 map))
  235.     (while p
  236.       (and window-start (setcar (car p) nil))
  237.       (and window-point (setcar (cdr (car p)) nil))
  238.       (and window-hscroll (setcar (nthcdr 2 (car p)) nil))
  239.       (and selected-window (setcar (nthcdr 3 (car p)) nil))
  240.       (setq p (cdr p)))))
  241.  
  242. (defun screen-replace-map-element (map what function)
  243.   (let (mapi mapj p old new)
  244.     (cond ((eq what 'buffer-file-name)
  245.        (setq mapi 1 mapj 0))
  246.        ((eq what 'buffer-name)
  247.         (setq mapi 1 mapj 1))
  248.        ((eq what 'window-start)
  249.         (setq mapi 2 mapj 0))
  250.        ((eq what 'window-point)
  251.         (setq mapi 2 mapj 1))
  252.        ((eq what 'window-hscroll)
  253.         (setq mapi 2 mapj 2))
  254.        ((eq what 'selected-window)
  255.         (setq mapi 2 mapj 3)))
  256.     (setq p (nth mapi map))
  257.     (while p
  258.       (setq old (nth mapj (car p))
  259.         new (funcall function old))
  260.       (if (not (equal old new))
  261.       (setcar (nthcdr mapj (car p)) new))
  262.       (setq p (cdr p)))))
  263.