home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / gnu / lucid / lemacs-19.6 / lisp / prim / screen.el < prev    next >
Encoding:
Text File  |  1993-03-13  |  19.9 KB  |  532 lines
  1. ;; Multi-screen management that is independent of window systems.
  2. ;; Copyright (C) 1990-1993 Free Software Foundation, Inc.
  3.  
  4. ;; This file is part of GNU Emacs.
  5.  
  6. ;; GNU Emacs is free software; you can redistribute it and/or modify
  7. ;; it under the terms of the GNU General Public License as published by
  8. ;; the Free Software Foundation; either version 2, or (at your option)
  9. ;; any later version.
  10.  
  11. ;; GNU Emacs is distributed in the hope that it will be useful,
  12. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14. ;; GNU General Public License for more details.
  15.  
  16. ;; You should have received a copy of the GNU General Public License
  17. ;; along with GNU Emacs; see the file COPYING.  If not, write to
  18. ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  19.  
  20. (provide 'screen)
  21.  
  22. ;; these are called from select_screen()
  23.  
  24. (defvar select-screen-hook nil
  25.   "Function or functions to run just after a new screen is selected.")
  26.  
  27. (defvar deselect-screen-hook nil
  28.   "Function or functions to run just before selecting another screen.")
  29.  
  30.  
  31. ;; Creation of the first screen.  Two styles are provided for, although a
  32. ;; third is possible.  They are:  Separate minibuffer screen, and one
  33. ;; minibuffer per screen.  Default is the latter.
  34.  
  35.  
  36. (defvar screen-default-alist nil
  37.   "Alist of default values for screen creation, other than the first one.
  38. These may be set in your init file, like this:
  39.   (setq screen-default-alist '((width . 80) (height . 55)))
  40. For values specific to the first emacs screen, you must use X resources.")
  41.  
  42. (defvar minibuffer-alist '((minibuffer . only)
  43.                (height . 1)
  44.                (width . 80)
  45.                ;;(top . -1)
  46.                ;;(left . 1)
  47.                (vertical-scroll-bar . nil)
  48.                (horizontal-scroll-bar . nil)
  49.                (unsplittable . t))
  50.   "Alist of switches for the appearance of the detached minibuffer screen.")
  51.  
  52. (defvar initial-screen-hooks nil
  53.   "Hook to run after initial screen startup." )
  54.  
  55. (defvar screen-creation-func '-no-window-system-yet-
  56.   "Window-system dependent function for creating new screens.")
  57.  
  58. ;; Try to use screen colors and font for the minibuffer, if none were
  59. ;; specified.  Also make sure the screen defaults include no minibuffer,
  60. ;; as well as having the same name--this is so they will all be treated
  61. ;; the same by the window manager.
  62.  
  63. (defun detached-minibuffer-startup (window-system-switches)
  64.   (let ((mini-type (assq 'minibuffer screen-default-alist))
  65.     (screen-names (assq 'name screen-default-alist))
  66.     (extras))
  67.     (or (assq 'foreground-color minibuffer-alist)
  68.     (setq extras (list (assq 'foreground-color window-system-switches))))
  69.     (or (assq 'background-color minibuffer-alist)
  70.     (setq extras (append extras
  71.                  (list (assq 'background-color
  72.                      window-system-switches)))))
  73.     (or (assq 'font minibuffer-alist)
  74.     (setq extras (append extras
  75.                  (list (assq 'font
  76.                      window-system-switches)))))
  77.     (if extras
  78.     (setq minibuffer-alist (append extras minibuffer-alist)))
  79.     (if mini-type
  80.     (rplacd mini-type 'none)
  81.       (setq screen-default-alist (append screen-default-alist
  82.                      '((minibuffer . none)))))
  83.     (if screen-names
  84.     (rplacd screen-names "*emacs screen*")
  85.       (setq screen-default-alist (append screen-default-alist
  86.                      '((name . "*emacs screen*"))))))
  87.   (setq    global-minibuffer-screen (funcall screen-creation-func
  88.                       minibuffer-alist))
  89.   (select-screen (funcall screen-creation-func
  90.               (append
  91.                '((minibuffer . none)
  92.                  (name . "*emacs screen*"))
  93.                window-system-switches))))
  94.  
  95. ;; Setup for single attached minibuffer screen style
  96.  
  97. (defun attached-minibuffer-startup (window-system-switches)
  98.        (select-screen (setq global-minibuffer-screen
  99.                (funcall screen-creation-func
  100.                 window-system-switches))))
  101.  
  102. ;; Setup for minibuffer/screen style
  103.  
  104. (defun multi-minibuffer-startup (window-system-switches)
  105.   (select-screen
  106.    (funcall screen-creation-func window-system-switches)))
  107.  
  108. ;; This is called from the window-system specific function which is attached
  109. ;; to window-setup-hook.
  110.  
  111. (defvar first-screen-user-positioned nil)
  112. (defvar separate-minibuffer-screen nil)
  113.  
  114. (defun pop-initial-screen (window-system-switches)
  115.   (let ((mini (assq 'minibuffer window-system-switches)))
  116.     (setq first-screen-user-positioned
  117.       (and (assq 'top window-system-switches)
  118.            (assq 'left window-system-switches)))
  119.     ;; jwz: disabled this, because it crashes too often.
  120. ;    (if (or separate-minibuffer-screen
  121. ;        (and mini (eq (cdr mini) 'none)))
  122. ;    (detached-minibuffer-startup window-system-switches)
  123.       (multi-minibuffer-startup window-system-switches))
  124. ;    )
  125.   ;; I think this isn't useful, because .emacs hasn't been loaded yet.
  126.   (run-hooks 'initial-screen-hooks))
  127.  
  128.  
  129. ;; Creation of additional screens.  If the user specified the position
  130. ;; of the initial screen, then specify placement of new screens as well.
  131. ;; The default function merely offsets them from the selected screen
  132. ;; by the values of new-screen-x-delta and new-screen-y-delta.
  133.  
  134. (defvar new-screen-x-delta 50
  135.   "Horizontal displacement (in pixels) for position of new screen.")
  136. (defvar new-screen-y-delta 50
  137.   "Vertical displacement (in pixels) for position of new screen.")
  138.  
  139. ;; This just adds the deltas to the position of the selected screen.
  140.  
  141. (defun new-screen-position (top left width height)
  142.   (let ((new-top (+ top new-screen-y-delta))
  143.     (new-left (+ left new-screen-x-delta))
  144.     (top (assq 'top screen-default-alist))
  145.     (left (assq 'left screen-default-alist)))
  146.     (or (and top left (rplacd top new-top) (rplacd left new-left)
  147.          screen-default-alist)
  148.     (setq screen-default-alist (append (list (cons 'top new-top)
  149.                          (cons 'left new-left))
  150.                        screen-default-alist)))))
  151.  
  152. (defun new-screen ()
  153.   (if first-screen-user-positioned
  154.       (let* ((s (selected-screen))
  155.          (this-top (assq 'top (screen-parameters s)))
  156.          (this-left (assq 'left (screen-parameters s)))
  157.          (this-width (x-pixel-width s))
  158.          (this-height (x-pixel-height s)))
  159.     (and this-top this-left (new-screen-position (cdr this-top)
  160.                              (cdr this-left)
  161.                              this-width this-height))))
  162.   (funcall screen-creation-func screen-default-alist))
  163.  
  164. ;; Return some screen other than the current screen,
  165. ;; creating one if neccessary.  Note that the minibuffer screen, if
  166. ;; separate, is not considered (see next-screen).
  167.  
  168. (defun get-screen ()
  169.   (let ((s (if (equal (next-screen (selected-screen)) (selected-screen))
  170.            (new-screen)
  171.          (next-screen (selected-screen)))))
  172.     s))
  173.  
  174. ;;  (defun next-multiscreen-window (arg)
  175. ;;    "Select the next window, regardless of which screen it is on."
  176. ;;    (interactive "p")
  177. ;;    (select-window (next-window (selected-window)
  178. ;;                    (> (minibuffer-depth) 0)
  179. ;;                    t)))
  180.  
  181. ;;; Iconifying emacs.
  182. ;;;
  183. ;;; The function iconify-emacs replaces every non-iconified emacs window
  184. ;;; with a *single* icon.  Iconified emacs windows are left alone.  When
  185. ;;; emacs is in this globally-iconified state, de-iconifying any emacs icon
  186. ;;; will uniconify all screens that were visible, and iconify all screens
  187. ;;; that were not.  This is done by temporarily changing the value of
  188. ;;; `map-screen-hook' to `deiconify-emacs' (which should never be called 
  189. ;;; except from the map-screen-hook while emacs is iconified.)
  190. ;;;
  191. ;;; The title of the icon representing all emacs screens is controlled by
  192. ;;; the variable `icon-name'.  This is done by temporarily changing the
  193. ;;; value of `screen-icon-title-format'.  Unfortunately, this changes the
  194. ;;; titles of all emacs icons, not just the "big" icon.
  195. ;;;
  196. ;;; It would be nice if existing icons were removed and restored by
  197. ;;; iconifying the emacs process, but I couldn't make that work yet.
  198.  
  199. (defvar icon-name (concat "emacs @ " system-name))
  200.  
  201. (defvar iconification-data nil)
  202.  
  203. (defun iconify-emacs ()
  204.   (interactive)
  205.   (if iconification-data (error "already iconified?"))
  206.   (let* ((screens (screen-list))
  207.      (rest screens)
  208.      (me (selected-screen))
  209.      screen)
  210.     (while rest
  211.       (setq screen (car rest))
  212.       (setcar rest (cons screen (screen-visible-p screen)))
  213. ;      (if (memq (cdr (car rest)) '(icon nil))
  214. ;      (progn
  215. ;        (make-screen-visible screen) ; deiconify, and process the X event
  216. ;        (sleep-for 500 t) ; process X events; I really want to XSync() here
  217. ;        ))
  218.       (or (eq screen me) (make-screen-invisible screen))
  219.       (setq rest (cdr rest)))
  220.     (or (boundp 'map-screen-hook) (setq map-screen-hook nil))
  221.     (setq iconification-data
  222.         (list screen-icon-title-format map-screen-hook screens)
  223.       screen-icon-title-format icon-name
  224.       map-screen-hook 'deiconify-emacs)
  225.     (iconify-screen me)))
  226.  
  227. (defun deiconify-emacs (&optional ignore)
  228.   (or iconification-data (error "not iconified?"))
  229.   (setq screen-icon-title-format (car iconification-data)
  230.     map-screen-hook (car (cdr iconification-data))
  231.     iconification-data (car (cdr (cdr iconification-data))))
  232.   (while iconification-data
  233.     (let ((visibility (cdr (car iconification-data))))
  234.       (cond ((eq visibility 't)
  235.          (make-screen-visible (car (car iconification-data))))
  236. ;        (t ;; (eq visibility 'icon)
  237. ;         (make-screen-visible (car (car iconification-data)))
  238. ;         (sleep-for 500 t) ; process X events; I really want to XSync() here
  239. ;         (iconify-screen (car (car iconification-data))))
  240.         ;; (t nil)
  241.         ))
  242.     (setq iconification-data (cdr iconification-data))))
  243.  
  244.  
  245. ;;
  246. ;; Screen-Window functions
  247. ;;
  248.  
  249. (defun other-window-any-screen (n)
  250.   "Select the ARG'th different window on any screen.
  251. All windows on current screen are arranged in a cyclic order.
  252. This command selects the window ARG steps away in that order.
  253. A negative ARG moves in the opposite order.  However, unlike
  254. `other-window', this command will select a window on the next
  255. \(or previous) screen instead of wrapping around to the top
  256. \(or bottom) of this screen, when there are no more windows."
  257.   (interactive "p")
  258.   (other-window n t)
  259.   ;; Click-to-type window managers do this automatically, but twm doesn't
  260.   ;; unless you are in auto-raise mode.  It's not unreasonable to want M-o
  261.   ;; to raise the screen without mouse-motion raising the windows the mouse
  262.   ;; passes over, so we make raising the screen be the policy of M-o...
  263.   ;; I think it's probably wrong for select-window to raise the screen,
  264.   ;; that's too severe; but this is just one command.
  265.   (raise-screen (selected-screen))
  266.   )
  267.  
  268. (defun single-window-screen (&optional screen)
  269.   (let* ((s (or screen (selected-screen)))
  270.      (w (screen-selected-window s)))
  271.     (eq w (next-window w 0 nil))))
  272.  
  273. (defun one-screen (&optional screen)
  274.   "Delete all screens but SCREEN (default is current screen).
  275. Also delete all windows but the selected one on SCREEN."
  276.   (interactive)
  277.   (let* ((s (or screen (selected-screen)))
  278.      (this (next-screen s)))
  279.     (while (not (eq this s))
  280.       (delete-screen this)
  281.       (setq this (next-screen s)))
  282.     (delete-other-windows (screen-selected-window s))))
  283.  
  284. ;; (define-key ctl-x-map "1" 'one-screen)
  285.  
  286. (define-key esc-map "o" 'other-window-any-screen)
  287. (define-key global-map "\^Z" 'iconify-emacs)
  288. ;;(define-function-key global-function-map 'xk-f2 'buffer-in-other-screen)
  289.  
  290.  
  291.  
  292. (defun find-file-new-screen (filename)
  293.   "Just like find-file, but creates a new screen for it first."
  294.   (interactive "FFind file in new screen: ")
  295.   (let* ((buf (find-file-noselect filename))
  296.      (scr (and screen-creation-func
  297.            (funcall screen-creation-func nil))))
  298.     (if scr (select-screen scr))
  299.     (switch-to-buffer buf)))
  300.  
  301. (defun switch-to-buffer-new-screen (buffer)
  302.   "Just like switch-to-buffer, but creates a new screen for it first."
  303.   (interactive "BSwitch to buffer in new screen: ")
  304.   (if screen-creation-func
  305.       (select-screen (funcall screen-creation-func nil)))
  306.   (switch-to-buffer buffer))
  307.  
  308.  
  309. ;;
  310. ;;
  311. ;; Convenience functions for dynamically changing screen parameters
  312. ;;
  313. (defun set-screen-height (h)
  314.   (interactive "NHeight: ")
  315.   (let* ((screen (selected-screen))
  316.      (width (cdr (assoc 'width (screen-parameters (selected-screen))))))
  317.     (set-screen-size (selected-screen) width h)))
  318.  
  319. (defun set-screen-width (w)
  320.   (interactive "NWidth: ")
  321.   (let* ((screen (selected-screen))
  322.      (height (cdr (assoc 'height (screen-parameters (selected-screen))))))
  323.     (set-screen-size (selected-screen) w height)))
  324.  
  325. (defun set-default-font (font-name)
  326.   (interactive "sFont name: ")
  327.   (modify-screen-parameters (selected-screen)
  328.                 (list (cons 'font font-name))))
  329.  
  330. (defun set-screen-background (color-name)
  331.   (interactive "sColor: ")
  332.   (modify-screen-parameters (selected-screen)
  333.                 (list (cons 'background-color color-name))))
  334.  
  335. (defun set-screen-foreground (color-name)
  336.   (interactive "sColor: ")
  337.   (modify-screen-parameters (selected-screen)
  338.                 (list (cons 'foreground-color color-name))))
  339.  
  340. (defun set-cursor-color (color-name)
  341.   (interactive "sColor: ")
  342.   (modify-screen-parameters (selected-screen)
  343.                 (list (cons 'cursor-color color-name))))
  344.  
  345. (defun set-pointer-color (color-name)
  346.   (interactive "sColor: ")
  347.   (modify-screen-parameters (selected-screen)
  348.                 (list (cons 'mouse-color color-name))))
  349.  
  350. (defun set-auto-raise (toggle)
  351.   (interactive)
  352.   (let* ((screen (selected-screen))
  353.      (bar (cdr (assoc 'auto-lower (screen-parameters screen)))))
  354.     (modify-screen-parameters screen
  355.                   (list (cons 'auto-lower (not bar))))))
  356.  
  357. (defun toggle-auto-lower ()
  358.   (interactive)
  359.   (let* ((screen (selected-screen))
  360.      (bar (cdr (assoc 'auto-lower (screen-parameters screen)))))
  361.     (modify-screen-parameters screen
  362.                   (list (cons 'auto-lower (not bar))))))
  363.  
  364. ;(defun toggle-vertical-bar ()
  365. ;  (interactive)
  366. ;  (let* ((screen (selected-screen))
  367. ;     (bar (cdr (assoc 'vertical-scroll-bar (screen-parameters screen)))))
  368. ;    (modify-screen-parameters screen
  369. ;                  (list (cons 'vertical-scroll-bar (not bar))))))
  370.  
  371. ;(defun toggle-horizontal-bar ()
  372. ;  (interactive)
  373. ;  (let* ((screen (selected-screen))
  374. ;     (bar (cdr (assoc 'horizontal-scroll-bar (screen-parameters screen)))))
  375. ;    (modify-screen-parameters screen
  376. ;                  (list (cons 'horizontal-scroll-bar (not bar))))))
  377.  
  378.  
  379. ;;; auto-raise and auto-lower
  380.  
  381. (defvar auto-raise-screen nil
  382.   "*If true, screens will be raised to the top when selected.
  383. Under X, most ICCCM-compliant window managers will have an option to do this 
  384. for you, but this variable is provided in case you're using a broken WM.")
  385.  
  386. (defvar auto-lower-screen nil
  387.   "*If true, screens will be lowered to the bottom when no longer selected.
  388. Under X, most ICCCM-compliant window managers will have an option to do this 
  389. for you, but this variable is provided in case you're using a broken WM.")
  390.  
  391. (defun default-select-screen-hook ()
  392.   "Implements the `auto-raise-screen' variable.
  393. For use as the value of `select-screen-hook'."
  394.   (if auto-raise-screen (raise-screen (selected-screen))))
  395.  
  396. (defun default-deselect-screen-hook ()
  397.   "Implements the `auto-lower-screen' variable.
  398. For use as the value of `deselect-screen-hook'."
  399.   (if auto-lower-screen (lower-screen (selected-screen))))
  400.  
  401. (or select-screen-hook
  402.     (add-hook 'select-screen-hook 'default-select-screen-hook))
  403.  
  404. (or deselect-screen-hook
  405.     (add-hook 'deselect-screen-hook 'default-deselect-screen-hook))
  406.  
  407.  
  408. ;;; Application-specific screen-management
  409.  
  410. (defvar get-screen-for-buffer-default-screen-name nil
  411.   "The default screen to select; see doc of `get-screen-for-buffer'.")
  412.  
  413. (defun get-screen-name-for-buffer (buffer)
  414.   (let ((mode (save-excursion (set-buffer buffer) major-mode)))
  415.     (or (get mode 'screen-name)
  416.     get-screen-for-buffer-default-screen-name)))
  417.  
  418. (defun get-screen-for-buffer (buffer &optional not-this-window-p on-screen)
  419.   "Select and return a screen in which to display BUFFER.
  420. Normally, the buffer will simply be displayed in the current screen.
  421. But if the symbol naming the major-mode of the buffer has a 'screen-name
  422. property (which should be a symbol), then the buffer will be displayed in
  423. a screen of that name.  If there is no screen of that name, then one is
  424. created.  
  425.  
  426. If the major-mode doesn't have a 'screen-name property, then the screen
  427. named by `get-screen-for-buffer-default-screen-name' will be used.  If
  428. that is nil (the default) then the currently selected screen will used.
  429.  
  430. If the screen-name symbol has an 'instance-limit property (an integer)
  431. then each time a buffer of the mode in question is displayed, a new screen
  432. with that name will be created, until there are `instance-limit' of them.
  433. If instance-limit is 0, then a new screen will be created each time.
  434.  
  435. If a buffer is already displayed in a screen, then `instance-limit' is 
  436. ignored, and that screen is used.
  437.  
  438. If the screen-name symbol has a 'screen-defaults property, then that is
  439. prepended to the `screen-default-alist' when creating a screen for the
  440. first time.
  441.  
  442. This function may be used as the value of `pre-display-buffer-hook', to 
  443. cause the display-buffer function and its callers to exhibit the above
  444. behavior."
  445.   (if (or on-screen (eq (selected-window) (minibuffer-window)))
  446.       ;; don't switch screens if a screen was specified, or to list
  447.       ;; completions from the minibuffer, etc.
  448.       nil
  449.     ;; else
  450.   (let ((name (get-screen-name-for-buffer buffer)))
  451.     (if (null name)
  452.     (selected-screen)
  453.       (let ((limit (get name 'instance-limit))
  454.         (defaults (get name 'screen-defaults))
  455.         (screens (screen-list))
  456.         (matching-screens '())
  457.         screen already-visible)
  458.     ;; Sort the list so that iconic screens will be found last.  They
  459.     ;; will be used too, but mapped screens take prescedence.  And
  460.     ;; fully visible screens come before occluded screens.
  461.     (setq screens
  462.           (sort screens
  463.             (function
  464.              (lambda (s1 s2)
  465.                (cond ((screen-totally-visible-p s2)
  466.                   nil)
  467.                  ((not (screen-visible-p s2))
  468.                   (screen-visible-p s1))
  469.                  ((not (screen-totally-visible-p s2))
  470.                   (and (screen-visible-p s1)
  471.                    (screen-totally-visible-p s1))))))))
  472.     ;; but the selected screen should come first, even if it's occluded,
  473.     ;; to minimize thrashing.
  474.     (setq screens (cons (selected-screen)
  475.                 (delq (selected-screen) screens)))
  476.  
  477.     (setq name (symbol-name name))
  478.     (while screens
  479.       (setq screen (car screens))
  480.       (if (equal name (screen-name screen))
  481.           (if (get-buffer-window buffer screen)
  482.           (setq already-visible screen
  483.             screens nil)
  484.         (setq matching-screens (cons screen matching-screens))))
  485.       (setq screens (cdr screens)))
  486.     (cond (already-visible
  487.            (select-screen already-visible)
  488.            (make-screen-visible already-visible)
  489.            already-visible)
  490.           ((or (null matching-screens)
  491.            (eq limit 0) ; means create with reckless abandon
  492.            (and limit (< (length matching-screens) limit)))
  493.            (let ((sc (funcall screen-creation-func
  494.                   (cons (cons 'name name)
  495.                     (append defaults
  496.                         screen-default-alist)))))
  497.          (select-screen sc)
  498.          (make-screen-visible sc)
  499.          ;; make the one buffer being displayed in this newly created
  500.          ;; screen be the buffer of interest, instead of something
  501.          ;; random, so that it won't be shown in two-window mode.
  502.          (switch-to-buffer buffer)
  503.          sc))
  504.           (t
  505.            (select-screen (car matching-screens))
  506.            (make-screen-visible (car matching-screens))
  507.            ;; do not switch any of the window/buffer associations in an
  508.            ;; existing screen; this function only picks a screen; the
  509.            ;; determination of which windows on it get reused is up to
  510.            ;; display-buffer itself.
  511. ;;           (or (window-dedicated-p (selected-window))
  512. ;;           (switch-to-buffer buffer))
  513.            (car matching-screens))))))))
  514.  
  515. (defun show-temp-buffer-in-current-screen (buffer)
  516.   "For use as the value of temp-buffer-show-function:
  517. always displays the buffer in the current screen, regardless of the behavior
  518. that would otherwise be introduced by the `pre-display-buffer-function', which
  519. is normally set to `get-screen-for-buffer' (which see.)"
  520.   (let ((pre-display-buffer-function nil)) ; turn it off, whatever it is
  521.     (let ((window (display-buffer buffer)))
  522.       (if (not (eq (selected-screen) (window-screen window)))
  523.       ;; only the pre-display-buffer-function should ever do this.
  524.       (error "display-buffer switched screens on its own!!"))
  525.       (setq minibuffer-scroll-window window)
  526.       (set-window-start window 1) ; obeys narrowing
  527.       (set-window-point window 1)
  528.       nil)))
  529.  
  530. (setq pre-display-buffer-function 'get-screen-for-buffer)
  531. (setq temp-buffer-show-function 'show-temp-buffer-in-current-screen)
  532.