Download
(eval-when-compile (require 'cl))
(require 'frame-fns)
(require 'strings nil t)
(require 'misc-fns nil t)
(defvar mac-tool-bar-display-mode)
(defgroup Frame-Commands nil
"Miscellaneous frame and window commands."
:group 'frames
:link `(url-link :tag "Send Bug Report"
,(concat "mailto:" "drew.adams" "@" "oracle" ".com?subject=\
frame-cmds.el bug: \
&body=Describe bug here, starting with `emacs -q'. \
Don't forget to mention your Emacs and library versions."))
:link '(url-link :tag "Other Libraries by Drew"
"http://www.emacswiki.org/cgi-bin/wiki/DrewsElispLibraries")
:link '(url-link :tag "Download"
"http://www.emacswiki.org/cgi-bin/wiki/frame-cmds.el")
:link '(url-link :tag "Description - `delete-window'"
"http://www.emacswiki.org/cgi-bin/wiki/FrameModes")
:link '(url-link :tag "Description - Frame Renaming"
"http://www.emacswiki.org/cgi-bin/wiki/FrameTitle")
:link '(url-link :tag "Description - Frame Resizing"
"http://www.emacswiki.org/cgi-bin/wiki/Shrink-Wrapping_Frames")
:link '(url-link :tag "Description - Frame Customization"
"http://www.emacswiki.org/cgi-bin/wiki/CustomizingAndSaving")
:link '(url-link :tag "Description - Frame Tiling"
"http://www.emacswiki.org/cgi-bin/wiki/Frame_Tiling_Commands")
:link '(url-link :tag "Description - General"
"http://www.emacswiki.org/cgi-bin/wiki/FrameModes")
:link '(emacs-commentary-link :tag "Commentary" "frame-cmds")
)
(defcustom rename-frame-when-iconify-flag t
"*Non-nil means frames are renamed when iconified.
The new name is the name of the current buffer."
:type 'boolean :group 'Frame-Commands)
(defcustom frame-config-register ?\C-l
"*Character naming register for saving/restoring frame configuration."
:type 'character :group 'Frame-Commands)
(defcustom show-hide-show-function 'jump-to-frame-config-register
"*Function to show stuff that is hidden or iconified by `show-hide'.
Candidates include `jump-to-frame-config-register' and `show-buffer-menu'."
:type '(choice (const :tag "Restore frame configuration" jump-to-frame-config-register)
(function :tag "Another function"))
:group 'Frame-Commands)
(defcustom window-mgr-title-bar-pixel-height (if (eq window-system 'mac) 22 27)
"*Height of frame title bar provided by the window manager, in pixels.
You might alternatively call this constant the title-bar \"width\" or
\"thickness\". There is no way for Emacs to determine this, so you
must set it."
:type 'integer :group 'Frame-Commands)
(defcustom enlarge-font-tries 100
"*Number of times to try to change font-size, when looking for a font.
The font-size portion of a font name is incremented or decremented at
most this many times, before giving up and raising an error."
:type 'integer :group 'Frame-Commands)
(defcustom frame-parameters-to-exclude '((window-id) (buffer-list) (name) (title) (icon-name))
"*Parameters to exclude in `set-all-frame-alist-parameters-from-frame'.
An alist of the same form as that returned by `frame-parameters'.
The cdr of each alist element is ignored.
These frame parameters are not copied to the target alist."
:type '(repeat (cons symbol sexp)) :group 'Frame-Commands)
(defcustom move-frame-wrap-within-display-flag t
"*Non-nil means wrap frame movements within the display.
Commands `move-frame-up', `move-frame-down', `move-frame-left', and
`move-frame-right' then move the frame back onto the display when it
moves off of it.
If nil, you can move the frame as far off the display as you like."
:type 'boolean :group 'Frame-Commands)
(defcustom available-screen-pixel-bounds nil
"*Upper left and lower right of available screen space for tiling frames.
Integer list: (x0 y0 x1 y1), where (x0, y0) is the upper left position
and (x1, y1) is the lower right position. Coordinates are in pixels,
measured from the screen absolute origin, (0, 0), at the upper left.
If this is nil, then the available space is calculated. That should
give good results in most cases."
:type '(list
(integer :tag "X0 (upper left) - pixels from screen left")
(integer :tag "Y0 (upper left) - pixels from screen top")
(integer :tag "X1 (lower right) - pixels from screen left" )
(integer :tag "Y1 (lower right) - pixels from screen top"))
:group 'Frame-Commands)
(defun save-frame-config ()
"Save current frame configuration.
You can restore it with \\[jump-to-frame-config-register]."
(interactive)
(frame-configuration-to-register frame-config-register)
(when (fboundp 'doremi-push-current-frame-config)
(doremi-push-current-frame-config))
(message
(substitute-command-keys
(if (fboundp 'doremi-frame-configs)
(format "Use `\\[jump-to-frame-config-register]' (`C-x r j %c') or \
`\\[doremi-frame-configs]' to restore frames as before (undo)." frame-config-register)
"Use `\\[jump-to-frame-config-register]' to restore frames as before (undo)."))))
(defun jump-to-frame-config-register ()
"Restore frame configuration saved in `frame-config-register'."
(interactive)
(jump-to-register frame-config-register))
(defun deiconify-everything ()
"Deiconify any iconified frames."
(interactive)
(frame-configuration-to-register frame-config-register)
(dolist (frame (frame-list))
(when (eq 'icon (frame-visible-p frame)) (make-frame-visible frame))))
(defun iconify-everything ()
"Iconify all frames of session at once.
Remembers frame configuration in register `C-l' (Control-L).
To restore this frame configuration, use `\\[jump-to-register] C-l'."
(interactive)
(frame-configuration-to-register frame-config-register)
(let ((thumfr-thumbify-dont-iconify-flag nil))
(dolist (frame (visible-frame-list))
(when rename-frame-when-iconify-flag (rename-non-minibuffer-frame frame))
(iconify-frame frame))))
(defun hide-everything ()
"Hide all frames of session at once.
Iconify minibuffer frame
Remembers frame configuration in register `C-l' (Control-L).
To restore this frame configuration, use `\\[jump-to-register] C-l'."
(interactive)
(frame-configuration-to-register frame-config-register)
(let ((minibuf-frame-name
(and (boundp '1on1-minibuffer-frame)
(cdr (assq 'name (frame-parameters 1on1-minibuffer-frame)))))
(thumfr-thumbify-dont-iconify-flag nil))
(dolist (frame (frame-list))
(if (eq minibuf-frame-name (cdr (assq 'name (frame-parameters frame))))
(iconify-frame frame)
(make-frame-invisible frame t)))))
(defun show-hide ()
"1 frame visible: `show-hide-show-function'
This acts as a toggle between showing all frames and showing only an
iconified minibuffer frame."
(interactive)
(if (< (length (visible-frame-list)) 2)
(funcall show-hide-show-function)
(hide-everything)))
(defun show-buffer-menu ()
"Call `buffer-menu' after making all frames visible.
Useful after using `hide-everything' because of a Windows bug that
doesn't let you display frames that have been made visible after
being made invisible."
(interactive)
(let ((minibuf-frame-name
(and (boundp '1on1-minibuffer-frame)
(cdr (assq 'name (frame-parameters 1on1-minibuffer-frame))))))
(dolist (frame (frame-list))
(if (eq minibuf-frame-name
(cdr (assq 'name (frame-parameters frame))))
(make-frame-visible frame)
(iconify-frame frame)))
(buffer-menu)))
(defun mouse-show-hide-mark-unmark (event)
"In minibuffer: `show-hide'. In dired: mark/unmark
(interactive "e")
(if (window-minibuffer-p (posn-window (event-start event)))
(show-hide)
(or (and (memq major-mode '(dired-mode vc-dired-mode))
(fboundp 'diredp-mouse-mark/unmark)
(diredp-mouse-mark/unmark event))
(mouse-buffer-menu event))))
(defalias 'iconify/map-frame 'iconify/show-frame)
(defun iconify/show-frame (&optional all-action)
"Iconify selected frame if now shown. Show it if now iconified.
A non-negative prefix arg iconifies all shown frames.
A negative prefix arg deiconifies all iconified frames."
(interactive "P")
(cond ((not all-action)
(when rename-frame-when-iconify-flag (rename-non-minibuffer-frame))
(iconify-or-deiconify-frame))
((natnump (prefix-numeric-value all-action))
(iconify-everything))
(t
(deiconify-everything))))
(defalias 'mouse-iconify/map-frame 'mouse-iconify/show-frame)
(defun mouse-iconify/show-frame (event)
"Iconify frame you click, if now shown. Show it if now iconified."
(interactive "e")
(select-window (posn-window (event-start event)))
(when rename-frame-when-iconify-flag (rename-non-minibuffer-frame))
(iconify-or-deiconify-frame))
(or (fboundp 'old-delete-window)
(fset 'old-delete-window (symbol-function 'delete-window)))
(defun delete-window (&optional window)
"Remove WINDOW from the display. Default is `selected-window'.
If WINDOW is the only one in its frame, then `delete-frame' too."
(interactive)
(save-current-buffer
(setq window (or window (selected-window)))
(select-window window)
(if (one-window-p t) (delete-frame) (old-delete-window (selected-window)))))
(defun delete-windows-for (&optional buffer)
"`delete-window' or prompt for buffer and delete its windows.
With no prefix arg, delete the selected window.
With a prefix arg, prompt for a buffer and delete all windows, on any
frame, that show that buffer."
(interactive (list (and current-prefix-arg (read-buffer-for-delete-windows))))
(if buffer (delete-windows-on buffer) (delete-window)))
(defun delete-windows-on (&optional buffer frame)
"Delete windows showing BUFFER.
Optional arg BUFFER defaults to the current buffer.
Optional second arg FRAME controls which frames are considered.
If nil or omitted, delete all windows showing BUFFER in any frame.
If t, delete only windows showing BUFFER in the selected frame.
If `visible', delete all windows showing BUFFER in any visible frame.
If a frame, delete only windows showing BUFFER in that frame.
Interactively, FRAME depends on the prefix arg, as follows:
Without a prefix arg (prefix = nil), FRAME is nil (all frames).
With prefix arg >= 0, FRAME is t (this frame only).
With prefix arg < 0, FRAME is `visible' (all visible frames)."
(interactive
(list (read-buffer-for-delete-windows)
(and current-prefix-arg
(or (natnump (prefix-numeric-value current-prefix-arg))
'visible))))
(unless buffer (setq buffer (current-buffer)))
(setq frame (if (eq t frame) nil (if (eq nil frame) t frame)))
(let (win)
(and (get-buffer buffer)
(while (setq win (get-buffer-window buffer frame))
(delete-window win))
nil)))
(defun read-buffer-for-delete-windows ()
"Read buffer name for delete-windows commands.
Only displayed buffers are completion candidates."
(completing-read "Delete windows on buffer: "
(let ((all-bufs (buffer-list))
(cand-bufs ()))
(dolist (buf all-bufs)
(when (get-buffer-window buf t)
(push (list (buffer-name buf)) cand-bufs)))
cand-bufs)
nil t nil 'minibuffer-history (buffer-name (current-buffer)) t))
(defsubst frame-iconified-p (frame)
"Return non-nil if FRAME is `frame-live-p' and `frame-visible-p'."
(and (frame-live-p frame) (eq (frame-visible-p frame) 'icon)))
(defalias 'remove-window 'delete-window)
(defun remove-windows-on (buffer)
"Remove all windows showing BUFFER. This calls `remove-window'
on each window showing BUFFER."
(interactive
(list (read-buffer "Remove all windows showing buffer: " (current-buffer) 'existing)))
(setq buffer (get-buffer buffer))
(when buffer
(dolist (fr (frames-on buffer t))
(remove-window (get-buffer-window buffer t)))))
(defun mouse-remove-window (event)
"Remove the window you click on. (This calls `remove-window'.)
This command must be bound to a mouse click."
(interactive "e")
(mouse-minibuffer-check event)
(remove-window (posn-window (event-start event))))
(defun delete/iconify-window (&optional window frame-p)
"Delete or iconify WINDOW (default: `selected-window').
If WINDOW is the only one in its frame (`one-window-p'), then optional
arg FRAME-P determines the behavior regarding the frame, as follows:
If FRAME-P is nil, then the frame is deleted (with the window).
If FRAME-P is t, then the frame is iconified.
If FRAME-P is a symbol naming a function, the function is applied
to WINDOW as its only arg.
If the result is nil, then the frame is deleted.
If the result is non-nil, then the frame is iconified.
If FRAME-P is anything else, then behavior is as if FRAME-P were the
symbol `window-dedicated-p': the frame is iconified if
WINDOW is dedicated, otherwise the frame is deleted.
Interactively, FRAME-P depends on the prefix arg, as follows:
Without a prefix arg (prefix = nil), FRAME-P is `window-dedicated-p'.
With prefix arg < 0, FRAME-P is t. The frame is iconified.
With prefix arg >= 0, FRAME-P is nil. The frame is deleted."
(interactive
(list nil (if current-prefix-arg
(not (natnump (prefix-numeric-value current-prefix-arg)))
'window-dedicated-p)))
(setq window (or window (selected-window)))
(let ((one-win-p t))
(save-window-excursion
(select-window window)
(if (one-window-p)
(if frame-p
(if (eq t frame-p)
(iconify-frame)
(unless (and (symbolp frame-p) (fboundp frame-p))
(setq frame-p 'window-dedicated-p))
(if (funcall frame-p window) (iconify-frame) (delete-frame)))
(delete-frame))
(setq one-win-p nil)))
(unless one-win-p (old-delete-window window))))
(defun delete/iconify-windows-on (buffer &optional frame frame-p)
"For each window showing BUFFER: delete it or iconify its frame.
\(This calls `delete/iconify-window' on each window showing BUFFER.)
Optional second arg FRAME controls which frames are considered.
If nil or omitted, treat all windows showing BUFFER in any frame.
If t, treat only windows showing BUFFER in the selected frame.
If `visible', treat all windows showing BUFFER in any visible frame.
If a frame, treat only windows showing BUFFER in that frame.
Optional third arg FRAME-P controls what to do with one-window frames.
If FRAME-P is nil, then one-window frames showing BUFFER are deleted.
If FRAME-P is t, then one-window frames are iconified.
If FRAME-P is a symbol naming a function, the function is applied
to each window showing buffer in a frame by itself.
If the result is nil, then the frame is deleted.
If the result is non-nil, then the frame is iconified.
If FRAME-P is anything else, then behavior is as if FRAME-P were the
symbol `window-dedicated-p': One-window frames are
iconified if window is dedicated, else they are deleted.
Interactively, FRAME is nil, and FRAME-P depends on the prefix arg:
Without a prefix arg (prefix = nil), FRAME-P is `window-dedicated-p'.
With prefix arg < 0, FRAME-P is t. The frame is iconified.
With prefix arg >= 0, FRAME-P is nil. The frame is deleted."
(interactive
(list (read-buffer "Delete windows on buffer: " (current-buffer) 'existing)
nil
(if current-prefix-arg
(not (natnump (prefix-numeric-value current-prefix-arg)))
'window-dedicated-p)))
(setq buffer (get-buffer buffer))
(when buffer
(setq frame (if (eq t frame) nil (if (eq nil frame) t frame)))
(dolist (fr (frames-on buffer frame))
(delete/iconify-window (get-buffer-window buffer frame) frame-p))))
(defun rename-frame (&optional old-name new-name all-named)
"Rename a frame named OLD-NAME to NEW-NAME.
Prefix arg ALL-NAMED non-nil means rename all frames named FRAME to NEWNAME.
OLD-NAME may be a frame, its name, or nil. Default is `selected-frame'.
NEW-NAME is a string or nil. Default NEW-NAME is current `buffer-name'."
(interactive
(list (read-frame (concat "Rename " (and current-prefix-arg "all ")
"frame" (and current-prefix-arg "s named") ": ")
nil t)
(read-from-minibuffer "Rename to (new name): " (cons (buffer-name) 1))
current-prefix-arg))
(setq old-name (or old-name (get-frame-name)))
(setq new-name (or new-name (buffer-name)))
(let ((fr (get-a-frame old-name)))
(if all-named
(while fr
(modify-frame-parameters fr (list (cons 'name new-name)))
(setq fr (get-a-frame old-name)))
(when (string= (get-frame-name fr) (get-frame-name))
(setq fr (selected-frame)))
(modify-frame-parameters fr (list (cons 'name new-name))))))
(defun rename-non-minibuffer-frame (&optional old-name new-name all-named)
"Unless OLD-NAME names the minibuffer frame, use `rename-frame'
to rename a frame named OLD-NAME to NEW-NAME.
Prefix arg ALL-NAMED non-nil => Rename all frames named FRAME to NEWNAME.
OLD-NAME may be a frame, its name, or nil. Default is `selected-frame'.
NEW-NAME is a string or nil. Default NEW-NAME is current `buffer-name'."
(interactive
(list (read-frame (concat "Rename " (and current-prefix-arg "all ")
"frame" (and current-prefix-arg "s named") ": ")
nil t)
(read-from-minibuffer "Rename to (new name): " (cons (buffer-name) 1))
current-prefix-arg))
(setq old-name (or old-name (get-frame-name)))
(setq new-name (or new-name (buffer-name)))
(let ((fr (get-a-frame old-name)))
(if (and (boundp '1on1-minibuffer-frame)
(eq (cdr (assq 'name (frame-parameters 1on1-minibuffer-frame)))
(cdr (assq 'name (frame-parameters fr)))))
(and (interactive-p)
(error "Use `rename-frame' if you really want to rename minibuffer"))
(rename-frame))))
(defun show-frame (frame)
"Make FRAME visible and raise it, without selecting it.
FRAME may be a frame or its name."
(interactive (list (read-frame "Frame to make visible: ")))
(setq frame (get-a-frame frame))
(make-frame-visible frame)
(raise-frame frame))
(defun hide-frame (frame &optional prefix)
"Make FRAME invisible. Like `make-frame-invisible', but reads frame name.
Non-nil PREFIX makes it invisible even if all other frames are invisible."
(interactive (list (read-frame "Frame to make invisible: ")))
(make-frame-invisible (get-a-frame frame) prefix))
(defun show-a-frame-on (buffer)
"Make visible and raise a frame showing BUFFER, if there is one.
Neither the frame nor the BUFFER are selected.
BUFFER may be a buffer or its name (a string)."
(interactive
(list (read-buffer "Show a frame showing buffer: "
(if (fboundp 'another-buffer)
(another-buffer nil t)
(other-buffer (current-buffer)))
'existing)))
(when buffer
(let ((fr (car (frames-on buffer)))) (when fr (show-frame fr)))))
(defun show-*Help*-buffer ()
"Raise a frame showing buffer *Help*, without selecting it."
(interactive) (show-a-frame-on "*Help*"))
(defun delete-1-window-frames-on (buffer)
"Delete all visible 1-window frames showing BUFFER."
(interactive
(list (read-buffer "Delete all visible 1-window frames showing buffer: "
(current-buffer) 'existing)))
(setq buffer (get-buffer buffer))
(save-excursion
(when (buffer-live-p buffer)
(dolist (fr (frames-on buffer))
(save-window-excursion
(select-frame fr)
(when (one-window-p t fr) (delete-frame)))))))
(defun delete-other-frames (&optional frame)
"Delete all frames except FRAME (default: selected frame).
Interactively, use a prefix arg (`\\[universal-argument]') to be prompted for FRAME."
(interactive (list (if current-prefix-arg
(get-a-frame (read-frame "Frame to make invisible: "))
(selected-frame))))
(when frame
(dolist (fr (frame-list))
(unless (eq fr frame) (condition-case nil (delete-frame fr) (error nil))))))
(defun maximize-frame-horizontally (&optional frame)
"Maximize selected frame horizontally."
(interactive (list (selected-frame)))
(maximize-frame 'horizontal frame))
(defun maximize-frame-vertically (&optional frame)
"Maximize selected frame vertically."
(interactive (list (selected-frame)))
(maximize-frame 'vertical frame))
(defun maximize-frame (&optional direction frame)
"Maximize selected frame horizontally, vertically, or both.
With no prefix arg, maximize both directions.
With a non-negative prefix arg, maximize vertically.
With a negative prefix arg, maximize horizontally.
In Lisp code:
DIRECTION is the direction: `horizontal', `vertical', or `both'.
FRAME is the frame to maximize."
(interactive (list (if current-prefix-arg
(if (natnump (prefix-numeric-value current-prefix-arg))
'vertical
'horizontal)
'both)))
(unless frame (setq frame (selected-frame)))
(unless direction (setq direction 'both))
(let (
(fr-pixel-width (available-screen-pixel-width))
(fr-pixel-height (available-screen-pixel-height))
(fr-origin (if (eq direction 'horizontal)
(car (effective-screen-pixel-bounds))
(cadr (effective-screen-pixel-bounds))))
(orig-left (frame-parameter frame 'left))
(orig-top (frame-parameter frame 'top))
(orig-width (frame-parameter frame 'width))
(orig-height (frame-parameter frame 'height)))
(let* ((borders (* 2 (cdr (assq 'border-width (frame-parameters frame)))))
(new-left (if (memq direction '(horizontal both)) 0 orig-left))
(new-top (if (memq direction '(vertical both)) 0 orig-top))
(new-width (if (memq direction '(horizontal both))
(/ (- fr-pixel-width borders (frame-extra-pixels-width frame))
(frame-char-width frame))
orig-width))
(new-height (if (memq direction '(vertical both))
(- (/ (- fr-pixel-height borders
(frame-extra-pixels-height frame)
window-mgr-title-bar-pixel-height
(smart-tool-bar-pixel-height))
(frame-char-height frame))
(if (eq window-system 'mac)
0
(cdr (assq 'menu-bar-lines (frame-parameters frame)))))
orig-height)))
(modify-frame-parameters
frame
`((left . ,new-left)
(width . ,new-width)
(top . ,new-top)
(height . ,new-height)
,(and new-left (/= (frame-geom-value-numeric 'left orig-left) new-left)
(cons 'restore-left orig-left))
,(and new-top (/= (frame-geom-value-numeric 'top orig-top) new-top)
(cons 'restore-top orig-top))
,(and new-width (/= (frame-geom-value-numeric 'width orig-width) new-width)
(cons 'restore-width orig-width))
,(and new-height (/= (frame-geom-value-numeric 'height orig-height) new-height)
(cons 'restore-height orig-height)))))
(show-frame frame)
(incf fr-origin (if (eq direction 'horizontal) fr-pixel-width fr-pixel-height))))
(unless (fboundp 'restore-frame-horizontally)
(defalias 'restore-frame-horizontally 'toggle-max-frame-horizontally))
(defun toggle-max-frame-horizontally (&optional frame)
"Toggle maximization of FRAME horizontally.
If used once, this restores the frame. If repeated, it maximizes.
This affects the `left' and `width' frame parameters.
FRAME defaults to the selected frame."
(interactive (list (selected-frame)))
(toggle-max-frame 'horizontal frame))
(unless (fboundp 'restore-frame-vertically)
(defalias 'restore-frame-vertically 'toggle-max-frame-vertically))
(defun toggle-max-frame-vertically (&optional frame)
"Toggle maximization of FRAME vertically.
If used once, this restores the frame. If repeated, it maximizes.
This affects the `top' and `height' frame parameters.
FRAME defaults to the selected frame."
(interactive (list (selected-frame)))
(toggle-max-frame 'vertical frame))
(unless (fboundp 'restore-frame) (defalias 'restore-frame 'toggle-max-frame))
(defun toggle-max-frame (&optional direction frame)
"Toggle maximization of FRAME horizontally, vertically, or both.
Reverses or (if restored) repeats the effect of the Emacs maximize
commands. Does not restore from maximization effected outside Emacs.
With no prefix arg, toggle both directions.
With a non-negative prefix arg, toggle only vertically.
With a negative prefix arg, toggle horizontally.
When toggling both directions, each is toggled from its last maximize
or restore state. This means that using this after
`maximize-horizontal', `maximize-vertical', `toggle-max-horizontal',
or `toggle-max-vertical' does not necessarily just reverse the effect
of that command.
In Lisp code:
DIRECTION is the direction: `horizontal', `vertical', or `both'.
FRAME is the frame to change. It defaults to the selected frame."
(interactive (list (if current-prefix-arg
(if (natnump (prefix-numeric-value current-prefix-arg))
'vertical
'horizontal)
'both)))
(unless frame (setq frame (selected-frame)))
(unless direction (setq direction 'both))
(let ((restore-left (frame-parameter frame 'restore-left))
(restore-top (frame-parameter frame 'restore-top))
(restore-width (frame-parameter frame 'restore-width))
(restore-height (frame-parameter frame 'restore-height))
(orig-left (frame-parameter frame 'left))
(orig-top (frame-parameter frame 'top))
(orig-width (frame-parameter frame 'width))
(orig-height (frame-parameter frame 'height))
(horiz (memq direction '(horizontal both)))
(vert (memq direction '(vertical both))))
(case direction
(both (unless (and restore-left restore-width restore-top restore-height)
(maximize-frame 'both frame)))
(vertical (unless (and restore-top restore-height) (maximize-frame-vertically frame)))
(horizontal (unless (and restore-left restore-width) (maximize-frame-horizontally frame))))
(modify-frame-parameters
frame `(,(and horiz restore-left (cons 'left restore-left))
,(and horiz restore-width (cons 'width restore-width))
,(and vert restore-top (cons 'top restore-top))
,(and vert restore-height (cons 'height restore-height))
,(and horiz orig-left (cons 'restore-left orig-left))
,(and horiz orig-width (cons 'restore-width orig-width))
,(and vert orig-top (cons 'restore-top orig-top))
,(and vert orig-height (cons 'restore-height orig-height)))))
(show-frame frame))
(defun tile-frames-horizontally (&optional frames)
"Tile frames horizontally.
Interatively:
With prefix arg, you are prompted for names of two frames to tile.
With no prefix arg, all visible frames are tiled, except a
standalone minibuffer frame, if any.
If called from a program, all frames in list FRAMES are tiled."
(interactive (and current-prefix-arg (read-args-for-tile-frames)))
(tile-frames 'horizontal frames))
(defun tile-frames-vertically (&optional frames)
"Tile frames vertically.
Interatively:
With prefix arg, you are prompted for names of two frames to tile.
With no prefix arg, all visible frames are tiled, except a
standalone minibuffer frame, if any.
If called from a program, all frames in list FRAMES are tiled."
(interactive (and current-prefix-arg (read-args-for-tile-frames)))
(tile-frames 'vertical frames))
(defun tile-frames (direction frames)
"Tile visible frames horizontally or vertically, depending on DIRECTION.
Arg DIRECTION is `horizontal' or `vertical'.
Arg FRAMES is the list of frames to tile. If nil, then tile all visible
frames (except a standalone minibuffer frame, if any)."
(let ((visible-frames
(or frames
(filtered-frame-list
(function
(lambda (fr)
(and (eq t (frame-visible-p fr))
(or (not (fboundp 'thumfr-thumbnail-frame-p))
(not (thumfr-thumbnail-frame-p fr)))
(or (not (boundp '1on1-minibuffer-frame))
(not (eq (cdr (assq 'name (frame-parameters 1on1-minibuffer-frame)))
(cdr (assq 'name (frame-parameters fr))))))))))))
(fr-pixel-width (available-screen-pixel-width))
(fr-pixel-height (available-screen-pixel-height))
(fr-origin (if (eq direction 'horizontal)
(car (effective-screen-pixel-bounds))
(cadr (effective-screen-pixel-bounds)))))
(case direction
(horizontal (setq fr-pixel-width (/ fr-pixel-width (length visible-frames))))
(vertical (setq fr-pixel-height (/ fr-pixel-height (length visible-frames))))
(otherwise (error "Function tile-frames: DIRECTION must be `horizontal' or `vertical'")))
(dolist (fr visible-frames)
(let ((borders (* 2 (cdr (assq 'border-width (frame-parameters fr))))))
(set-frame-size
fr
(/ (- fr-pixel-width borders (frame-extra-pixels-width fr))
(frame-char-width fr))
(- (/ (- fr-pixel-height borders (frame-extra-pixels-height fr)
window-mgr-title-bar-pixel-height (smart-tool-bar-pixel-height))
(frame-char-height fr))
(if (eq window-system 'mac)
0
(cdr (assq 'menu-bar-lines (frame-parameters fr)))))))
(set-frame-position fr
(if (eq direction 'horizontal) fr-origin 0)
(if (eq direction 'horizontal) 0 fr-origin))
(show-frame fr)
(incf fr-origin (if (eq direction 'horizontal) fr-pixel-width fr-pixel-height)))))
(defun frame-extra-pixels-width (frame)
"Pixel difference between FRAME total width and its text area width."
(- (frame-pixel-width frame) (* (frame-char-width frame) (frame-width frame))))
(defun frame-extra-pixels-height (frame)
"Pixel difference between FRAME total height and its text area height."
(- (frame-pixel-height frame) (* (frame-char-height frame) (frame-height frame))))
(defun smart-tool-bar-pixel-height (&optional frame)
"Pixel height of Mac smart tool bar."
(if (and (boundp 'mac-tool-bar-display-mode) (> (frame-parameter frame 'tool-bar-lines) 0))
(if (eq mac-tool-bar-display-mode 'icons) 40 56)
0))
(defun read-args-for-tile-frames ()
"Read arguments for `tile-frames'."
(list
(list
(get-a-frame (read-frame "Tile two frames - First frame: " nil t))
(get-a-frame
(read-frame
"Second frame: "
(let ((fr-names (cdr frame-name-history))
(visible-p nil)
(fr nil))
(while (and (not fr) fr-names)
(setq fr (car fr-names))
(setq fr (get-a-frame fr))
(setq fr (and fr (eq t (frame-visible-p fr)) fr))
(setq fr-names (cdr fr-names)))
(unless fr
(setq fr (selected-frame))
(while (and (not visible-p)
(setq fr (next-frame fr))
(not (equal fr (selected-frame))))
(setq visible-p (eq t (frame-visible-p fr)))))
fr)
t)))))
(defun available-screen-pixel-bounds ()
"Returns a value of the same form as option `available-screen-pixel-bounds'.
This represents the currently available screen area."
(or available-screen-pixel-bounds
(if (fboundp 'mac-display-available-pixel-bounds)
(mac-display-available-pixel-bounds)
(list 0 0 (x-display-pixel-width) (x-display-pixel-height)))))
(unless (fboundp 'butlast)
(defun nbutlast (list &optional n)
"Modifies LIST to remove the last N elements."
(let ((m (length list)))
(or n (setq n 1))
(and (< n m) (progn (when (> n 0) (setcdr (nthcdr (- (1- m) n) list) ()))
list))))
(defun butlast (list &optional n)
"Return a copy of LIST with the last N elements removed."
(if (and n (<= n 0)) list (nbutlast (copy-sequence list) n))))
(defun effective-screen-pixel-bounds ()
"Upper left and lower right of available screen space for tiling frames.
This is `available-screen-pixel-bounds', possibly adjusted to allow
for the standalone minibuffer frame provided by `oneonone.el'."
(if (boundp '1on1-minibuffer-frame)
(append (butlast (available-screen-pixel-bounds))
(list (frame-geom-value-numeric 'top (cdr (assq 'top (frame-parameters
1on1-minibuffer-frame))))))
(available-screen-pixel-bounds)))
(defun available-screen-pixel-width (&optional include-mini-p)
"Width of the usable screen, in pixels.
Non-nil optional argument `include-mini-p' means include the space
occupied by a standalone minibuffer, if any."
(let ((bounds (if include-mini-p
(available-screen-pixel-bounds)
(effective-screen-pixel-bounds))))
(- (caddr bounds) (car bounds))))
(defun available-screen-pixel-height (&optional include-mini-p)
"Height of the usable screen, in pixels.
Non-nil optional argument `include-mini-p' means include the
space occupied by a standalone minibuffer, if any."
(let ((bounds (if include-mini-p
(available-screen-pixel-bounds)
(effective-screen-pixel-bounds))))
(- (cadddr bounds) (cadr bounds))))
(defun enlarge-frame (&optional increment frame)
"Increase the height of FRAME (default: selected-frame) by INCREMENT.
INCREMENT is in lines (characters).
Interactively, it is given by the prefix argument."
(interactive "p")
(set-frame-height frame (+ (frame-height frame) increment)))
(defun enlarge-frame-horizontally (&optional increment frame)
"Increase the width of FRAME (default: selected-frame) by INCREMENT.
INCREMENT is in columns (characters).
Interactively, it is given by the prefix argument."
(interactive "p")
(set-frame-width frame (+ (frame-width frame) increment)))
(defun shrink-frame (&optional increment frame)
"Decrease the height of FRAME (default: selected-frame) by INCREMENT.
INCREMENT is in lines (characters).
Interactively, it is given by the prefix argument."
(interactive "p")
(set-frame-height frame (- (frame-height frame) increment)))
(defun shrink-frame-horizontally (&optional increment frame)
"Decrease the width of FRAME (default: selected-frame) by INCREMENT.
INCREMENT is in columns (characters).
Interactively, it is given by the prefix argument."
(interactive "p")
(set-frame-width frame (- (frame-width frame) increment)))
(defun move-frame-down (&optional n frame)
"Move selected frame down.
Move it N times `frame-char-height', where N is the prefix arg.
In Lisp code, FRAME is the frame to move."
(interactive "p")
(unless n (setq n 1))
(setq n (* n (frame-char-height frame)))
(modify-frame-parameters frame (list (list 'top '+ (new-frame-position frame 'top n)))))
(defun move-frame-up (&optional n frame)
"Move selected frame up.
Same as `move-frame-down', except movement is up."
(interactive "p")
(unless n (setq n 1))
(move-frame-down (- n)))
(defun move-frame-right (&optional n frame)
"Move frame to the right.
Move it N times `frame-char-width', where N is the prefix arg.
In Lisp code, FRAME is the frame to move."
(interactive "p")
(unless n (setq n 1))
(setq n (* n (frame-char-width frame)))
(modify-frame-parameters frame (list (list 'left '+ (new-frame-position frame 'left n)))))
(defun move-frame-left (&optional n frame)
"Move frame to the left.
Same as `move-frame-right', except movement is to the left."
(interactive "p")
(unless n (setq n 1))
(move-frame-right (- n)))
(defun new-frame-position (frame type incr)
"Return the new TYPE position of FRAME, incremented by INCR.
TYPE is `left' or `top'.
INCR is the increment to use when changing the position."
(let ((new-pos
(+ incr (cadr (frame-geom-value-cons type (cdr (assq type (frame-parameters frame)))))))
(display-dimension
(if (eq 'left type)
(available-screen-pixel-width t)
(available-screen-pixel-height t)))
(frame-dimension
(if (eq 'left type) (frame-pixel-width frame) (frame-pixel-height frame))))
(if (not move-frame-wrap-within-display-flag)
new-pos
(when (< new-pos (- frame-dimension)) (setq new-pos display-dimension))
(when (> new-pos display-dimension) (setq new-pos (- frame-dimension)))
new-pos)))
(defun move-frame-to-screen-top (arg &optional frame)
"Move FRAME (default: selected-frame) to the top of the screen.
With a prefix arg, offset it that many char heights from the top."
(interactive (list (if current-prefix-arg
(* (frame-char-height) (prefix-numeric-value current-prefix-arg))
0)))
(modify-frame-parameters frame `((top . ,arg))))
(defun move-frame-to-screen-bottom (arg &optional frame)
"Move FRAME (default: selected-frame) to the bottom of the screen.
With a prefix arg, offset it that many char heights from the bottom."
(interactive (list (if current-prefix-arg
(* (frame-char-height) (prefix-numeric-value current-prefix-arg))
0)))
(let* ((borders (* 2 (cdr (assq 'border-width (frame-parameters frame)))))
(avail-height (- (/ (- (available-screen-pixel-height) borders
(frame-extra-pixels-height frame)
window-mgr-title-bar-pixel-height
(smart-tool-bar-pixel-height))
(frame-char-height frame))
(if (eq window-system 'mac)
0
(cdr (assq 'menu-bar-lines (frame-parameters frame)))))))
(modify-frame-parameters frame `((top . ,(- (+ avail-height arg)))))))
(defun move-frame-to-screen-left (arg &optional frame)
"Move FRAME (default: selected-frame) to the left side of the screen.
With a prefix arg, offset it that many char widths from the left."
(interactive (list (if current-prefix-arg
(* (frame-char-width) (prefix-numeric-value current-prefix-arg))
0)))
(modify-frame-parameters frame `((left . ,arg))))
(defun move-frame-to-screen-right (arg &optional frame)
"Move FRAME (default: selected-frame) to the right side of the screen.
With a prefix arg, offset it that many char widths from the right."
(interactive (list (if current-prefix-arg
(* (frame-char-width) (prefix-numeric-value current-prefix-arg))
0)))
(modify-frame-parameters
frame
`((left . ,(- (x-display-pixel-width) (+ (frame-pixel-width) 7 arg))))))
(defun enlarge-font (&optional increment frame)
"Increase size of font in FRAME by INCREMENT.
Interactively, INCREMENT is given by the prefix argument.
Optional FRAME parameter defaults to current frame."
(interactive "p")
(setq frame (or frame (selected-frame)))
(let ((fontname (cdr (assq 'font (frame-parameters frame))))
(count enlarge-font-tries))
(setq fontname (enlarged-font-name fontname frame increment))
(while (and (not (x-list-fonts fontname)) (wholenump (setq count (1- count))))
(setq fontname (enlarged-font-name fontname frame increment)))
(unless (x-list-fonts fontname) (error "Cannot change font size"))
(modify-frame-parameters frame (list (cons 'font fontname)))
(when (< emacs-major-version 21) (frame-update-faces frame))))
(put 'font-too-small 'error-conditions '(error font-size font-too-small))
(put 'font-too-small 'error-message "Font size is too small")
(put 'font-size 'error-conditions '(error font-size))
(put 'font-size 'error-message "Bad font size")
(defun enlarged-font-name (fontname frame increment)
"FONTNAME, after enlarging font size of FRAME by INCREMENT.
FONTNAME is the font of FRAME."
(when (query-fontset fontname)
(let ((ascii (assq 'ascii (aref (fontset-info fontname frame) 2))))
(when ascii (setq fontname (nth 2 ascii)))))
(let ((xlfd-fields (x-decompose-font-name fontname)))
(unless xlfd-fields (error "Cannot decompose font name"))
(let ((new-size (+ (string-to-number (aref xlfd-fields xlfd-regexp-pixelsize-subnum))
increment)))
(unless (> new-size 0) (signal 'font-too-small (list new-size)))
(aset xlfd-fields xlfd-regexp-pixelsize-subnum (number-to-string new-size)))
(aset xlfd-fields xlfd-regexp-pointsize-subnum "*")
(aset xlfd-fields xlfd-regexp-avgwidth-subnum "*")
(x-compose-font-name xlfd-fields)))
(defun set-frame-alist-parameter-from-frame (alist parameter &optional frame)
"Set PARAMETER of frame alist ALIST to its current value in FRAME.
FRAME defaults to the selected frame. ALIST is a variable (symbol)
whose value is an alist of frame parameters."
(interactive
(let ((symb (or (and (fboundp 'symbol-nearest-point)(symbol-nearest-point))
(and (symbolp (variable-at-point)))))
(enable-recursive-minibuffers t))
(list (intern (completing-read "Frame alist to change (variable): "
(frame-alist-var-names) nil t nil nil 'default-frame-alist t))
(intern (completing-read "Parameter to set:"
(frame-parameter-names) nil t nil nil 'left t))
(get-a-frame (read-frame "Frame to copy parameter value from: " nil t)))))
(unless (boundp alist)
(error "Not a defined Emacs variable: `%s'" alist))
(set alist (assq-delete-all parameter (copy-alist (eval alist))))
(set alist (cons (assq parameter (frame-parameters frame)) (eval alist)))
(tell-customize-var-has-changed alist))
(unless (fboundp 'assq-delete-all)
(defun assq-delete-all (key alist)
"Delete from ALIST all elements whose car is `eq' to KEY.
Return the modified alist.
Elements of ALIST that are not conses are ignored."
(while (and (consp (car alist)) (eq (car (car alist)) key)) (setq alist (cdr alist)))
(let ((tail alist) tail-cdr)
(while (setq tail-cdr (cdr tail))
(if (and (consp (car tail-cdr)) (eq (car (car tail-cdr)) key))
(setcdr tail (cdr tail-cdr))
(setq tail tail-cdr))))
alist))
(defun frame-cmds-set-difference (list1 list2 &optional key)
"Combine LIST1 and LIST2 using a set-difference operation.
Optional arg KEY is a function used to extract the part of each list
item to compare.
The result list contains all items that appear in LIST1 but not LIST2.
This is non-destructive
avoid corrupting the original LIST1 and LIST2."
(if (or (null list1) (null list2)) list1
(let ((keyed-list2 (and key (mapcar key list2)))
(result ()))
(while list1
(unless (if key
(member (funcall key (car list1)) keyed-list2)
(member (car list1) list2))
(setq result (cons (car list1) result)))
(setq list1 (cdr list1)))
result)))
(defun set-all-frame-alist-parameters-from-frame (alist &optional frame really-all-p)
"Set frame parameters of ALIST to their current values in FRAME.
Unless optional argument REALLY-ALL-P (prefix arg) is non-nil, the
frame parameters in list `frame-parameters-to-exclude' are
excluded: they are not copied from FRAME to ALIST.
ALIST is a variable (symbol) whose value is an alist of frame parameters.
FRAME defaults to the selected frame."
(interactive
(let ((symb (or (and (fboundp 'symbol-nearest-point)(symbol-nearest-point))
(and (symbolp (variable-at-point)))))
(enable-recursive-minibuffers t))
(list (intern (completing-read "Frame alist to change (variable): "
(frame-alist-var-names) nil t nil nil 'default-frame-alist t))
(get-a-frame (read-frame "Frame to copy parameter values from: " nil t))
current-prefix-arg)))
(unless (boundp alist)
(error "Not a defined Emacs variable: `%s'" alist))
(set alist (frame-cmds-set-difference (frame-parameters frame)
(and (not really-all-p) frame-parameters-to-exclude)
#'car))
(tell-customize-var-has-changed alist))
(defun frame-alist-var-names ()
"Return an alist of all variable names that end in \"frame-alist\".
The CAR of each list item is a string variable name.
The CDR is nil."
(let ((vars nil))
(mapatoms (lambda (sym) (and (boundp sym)
(setq sym (symbol-name sym))
(string-match "frame-alist$" sym)
(push (list sym) vars))))
vars))
(defun frame-parameter-names ()
"Return an alist of all available frame-parameter names.
The CAR of each list item is a string parameter name.
The CDR is nil."
(let ((params '(("display") ("title") ("name") ("left") ("top") ("icon-left") ("icon-top")
("user-position") ("height") ("width") ("window-id") ("minibuffer")
("buffer-predicate") ("buffer-list") ("font") ("auto-raise") ("auto-lower")
("vertical-scroll-bars") ("horizontal-scroll-bars") ("scroll-bar-width")
("icon-type") ("icon-name") ("foreground-color") ("background-color")
("background-mode") ("mouse-color") ("cursor-color") ("border-color")
("display-type") ("cursor-type") ("border-width") ("internal-border-width")
("unsplittable") ("visibility") ("menu-bar-lines"))))
(when (> emacs-major-version 20)
(setq params (nconc params '("fullscreen" "outer-window-id" "tty-color-mode" "left-fringe"
"right-fringe" "tool-bar-lines" "screen-gamma" "line-spacing"
"wait-for-wm" "scroll-bar-foreground" "scroll-bar-background"))))
(when (> emacs-major-version 21) (setq params (nconc params '("user-size"))))
(when (> emacs-major-version 22)
(setq params (nconc params '("display-environment-variable" "term-environment-variable"))))
params))
(defun tell-customize-var-has-changed (variable)
"Tell Customize to recognize that VARIABLE has been set (changed).
VARIABLE is a symbol that names a user option."
(interactive "vVariable: ")
(put variable 'customized-value (list (custom-quote (eval variable)))))
(defun other-window-or-frame (arg)
"`other-frame', if `one-window-p'
(interactive "p")
(if (one-window-p) (other-frame arg) (other-window arg)))
(provide 'frame-cmds)