From af1cc4a8b430b83c392e5e221397a44f0e713ec5 Mon Sep 17 00:00:00 2001 From: Ivy Foster Date: Sun, 16 Mar 2008 12:09:44 -0400 Subject: [PATCH] Replanted code from user.lisp into new files. Separated out frame.lisp, group.lisp, resize.lisp, and window.lisp, shortening user.lisp by several hundred lines and putting together several related pieces of code that were not grouped together in user.lisp. --- frame.lisp | 306 ++++++++++++++++++++++ group.lisp | 199 ++++++++++++++ resize.lisp | 133 ++++++++++ user.lisp | 833 ----------------------------------------------------------- window.lisp | 341 ++++++++++++++++++++++++ 5 files changed, 979 insertions(+), 833 deletions(-) create mode 100644 frame.lisp create mode 100644 group.lisp create mode 100644 resize.lisp create mode 100644 window.lisp diff --git a/frame.lisp b/frame.lisp new file mode 100644 index 0000000..15325f2 --- /dev/null +++ b/frame.lisp @@ -0,0 +1,306 @@ +;; Copyright (C) 2003, 2008 * +;; +;; This file is part of stumpwm. +;; +;; stumpwm is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; stumpwm is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this software; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;; Boston, MA 02111-1307 USA +;; +;; Commentary: +;; +;; Commands for manipulating frames, extracted from user.lisp. +;; +;; * user.lisp Copyright (C) 2003 Shawn Betts +;; +;; Code: + +;;; Frame splitting + +(in-package :stumpwm) + +(defun split-frame-in-dir (group dir) + (let ((f (tile-group-current-frame group))) + (if (split-frame group dir) + (progn + (when (frame-window f) + (update-window-border (frame-window f))) + (show-frame-indicator group)) + (message "Cannot split smaller than minimum size.")))) + +(defcommand hsplit () () +"Split the current frame into 2 side-by-side frames." + (split-frame-in-dir (current-group) :column)) + +(defcommand vsplit () () +"Split the current frame into 2 frames, one on top of the other." + (split-frame-in-dir (current-group) :row)) + +;;; Frame un-splitting + +(defcommand remove-split (&optional (group (current-group))) () +"Remove the current frame in the specified group (defaults to current +group). Windows in the frame are migrated to the frame taking up its +space." + (let* ((frame (tile-group-current-frame group)) + (head (frame-head group frame)) + (tree (tile-group-frame-head group head)) + (s (closest-sibling (list tree) frame)) + ;; grab a leaf of the siblings. The siblings doesn't have to be + ;; a frame. + (l (tree-accum-fn s + (lambda (&rest siblings) + (car siblings)) + #'identity))) + ;; Only remove the current frame if it has a sibling + (if (atom tree) + (message "No more frames!") + (when s + (when (frame-is-head group frame) + (setf (frame-number l) (frame-number frame))) + ;; Move the windows from the removed frame to its sibling + (migrate-frame-windows group frame l) + ;; If the frame has no window, give it the current window of + ;; the current frame. + (unless (frame-window l) + (setf (frame-window l) + (frame-window frame))) + ;; Unsplit + (setf (tile-group-frame-head group head) (remove-frame tree frame)) + ;; update the current frame and sync all windows + (setf (tile-group-current-frame group) l) + (tree-iterate tree + (lambda (leaf) + (sync-frame-windows group leaf))) + (frame-raise-window group l (frame-window l)) + (when (frame-window l) + (update-window-border (frame-window l))) + (show-frame-indicator group))))) + +(defcommand-alias remove remove-split) + +(defcommand only () () + "Delete all the frames but the current one and grow it to take up the entire head." + (let* ((screen (current-screen)) + (group (screen-current-group screen)) + (win (frame-window (tile-group-current-frame group))) + (head (current-head group)) + (frame (copy-frame head))) + (if (atom (tile-group-frame-head group head)) + (message "There's only one frame.") + (progn + (mapc (lambda (w) + ;; windows in other frames disappear + (unless (eq (window-frame w) (tile-group-current-frame group)) + (hide-window w)) + (setf (window-frame w) frame)) + (head-windows group head)) + (setf (frame-window frame) win + (tile-group-frame-head group head) frame + (tile-group-current-frame group) frame) + (focus-frame group frame) + (if (frame-window frame) + (update-window-border (frame-window frame)) + (show-frame-indicator group)) + (sync-frame-windows group (tile-group-current-frame group)))))) + +(defun clear-frame (frame group) + "Clear the given frame." + (frame-raise-window group frame nil (eq (tile-group-current-frame group) frame))) + +(defcommand fclear () () +"Clear the current frame." + (clear-frame (tile-group-current-frame (current-group)) (current-group))) + +;;; Fullscreen + +(defcommand fullscreen () () + "Toggle the fullscreen mode of the current window. Use this for clients +with broken (non-NETWM) fullscreen implementations, such as any program +using SDL." + (update-fullscreen (current-window) 2)) + +;;; Frame focus + +(defcommand curframe () () +"Display a window indicating which frame is focused." + (show-frame-indicator (current-group) t)) + +(defun focus-frame-next-sibling (group) + (let* ((sib (next-sibling (tile-group-frame-tree group) + (tile-group-current-frame group)))) + (when sib + (focus-frame group (tree-accum-fn sib + (lambda (x y) + (declare (ignore y)) + x) + 'identity)) + (show-frame-indicator group)))) + +(defun focus-last-frame (group) + ;; make sure the last frame still exists in the frame tree + (when (and (tile-group-last-frame group) + (find (tile-group-last-frame group) (group-frames group))) + (focus-frame group (tile-group-last-frame group)))) + +(defun focus-frame-after (group frames) + "Given a list of frames focus the next one in the list after +the current frame." + (let ((rest (cdr (member (tile-group-current-frame group) frames :test 'eq)))) + (focus-frame group + (if (null rest) + (car frames) + (car rest))))) + +(defun focus-next-frame (group) + (focus-frame-after group (group-frames group))) + +(defun focus-prev-frame (group) + (focus-frame-after group (nreverse (group-frames group)))) + +(defcommand fnext () () +"Cycle through the frame tree to the next frame." + (focus-next-frame (current-group))) + +(defcommand sibling () () +"Jump to the frame's sibling. If a frame is split into twe frames, +these two frames are siblings." + (focus-frame-next-sibling (current-group))) + +(defcommand fother () () +"Jump to the last frame that had focus." + (focus-last-frame (current-group))) + +(defun choose-frame-by-number (group) + "show a number in the corner of each frame and wait for the user to +select one. Returns the selected frame or nil if aborted." + (let* ((wins (progn + (draw-frame-outlines group) + (draw-frame-numbers group))) + (ch (read-one-char (group-screen group))) + (num (read-from-string (string ch) nil nil))) + (dformat 3 "read ~S ~S~%" ch num) + (mapc #'xlib:destroy-window wins) + (clear-frame-outlines group) + (find ch (group-frames group) + :test 'char= + :key 'get-frame-number-translation))) + +(defcommand fselect (frame-number) ((:frame t)) +"Display a number in the corner of each frame and let the user to +select a frame by number. If @var{frame-number} is specified, just +jump to that frame." + (let ((group (current-group))) + (focus-frame group frame-number))) + +;;; Frame cooperation + +(defun get-edge (frame edge) + "Returns the specified edge of FRAME. Valid values for EDGE are :TOP, :BOTTOM, :LEFT, and :RIGHT. + An edge is a START, END, and OFFSET. For horizontal edges, START is the left coordinate, END is + the right coordinate, and OFFSET is the Y coordinate. Similarly, for vertical lines, START is + top, END is bottom, and OFFSET is X coordinate." + (let* ((x1 (frame-x frame)) + (y1 (frame-y frame)) + (x2 (+ x1 (frame-width frame))) + (y2 (+ y1 (frame-height frame)))) + (ecase edge + (:top + (values x1 x2 y1)) + (:bottom + (values x1 x2 y2)) + (:left + (values y1 y2 x1)) + (:right + (values y1 y2 x2))))) + +(defun neighbour (direction frame frameset) + "Returns the best neighbour of FRAME in FRAMESET on the DIRECTION edge. + Valid directions are :UP, :DOWN, :LEFT, :RIGHT. + eg: (NEIGHBOUR :UP F FS) finds the frame in FS that is the 'best' + neighbour above F." + (let ((src-edge (ecase direction + (:up :top) + (:down :bottom) + (:left :left) + (:right :right))) + (opposite (ecase direction + (:up :bottom) + (:down :top) + (:left :right) + (:right :left))) + (best-frame nil) + (best-overlap 0)) + (multiple-value-bind (src-s src-e src-offset) + (get-edge frame src-edge) + (dolist (f frameset) + (multiple-value-bind (s e offset) + (get-edge f opposite) + (let ((overlap (- (min src-e e) + (max src-s s)))) + ;; Two edges are neighbours if they have the same offset and their starts and ends + ;; overlap. We want to find the neighbour that overlaps the most. + (when (and (= src-offset offset) + (>= overlap best-overlap)) + (setf best-frame f) + (setf best-overlap overlap)))))) + best-frame)) + +;;; Frame movement + +(defun move-focus-and-or-window (dir &optional win-p) + (let* ((group (current-group)) + (direction (intern (string-upcase dir) :keyword)) + (new-frame (neighbour direction (tile-group-current-frame group) (group-frames group))) + (window (current-window))) + (when new-frame + (if (and win-p window) + (pull-window window new-frame) + (focus-frame group new-frame))))) + +(defcommand move-focus (dir) ((:string "Direction: ")) +"Focus the frame adjacent to the current one in the specified +direction. The following are valid directions: address@hidden @asis address@hidden up address@hidden down address@hidden left address@hidden right address@hidden table" + (move-focus-and-or-window dir)) + +(defcommand move-window (dir) ((:string "Direction: ")) +"Just like move-focus except that the current is pulled along." + (move-focus-and-or-window dir t)) + +;;; Windows in frames + +(defcommand next-in-frame () () +"Go to the next window in the current frame." + (let ((group (current-group))) + (if (group-current-window group) + (focus-forward group (frame-sort-windows group (tile-group-current-frame group))) + (other-window-in-frame group)))) + +(defcommand prev-in-frame () () +"Go to the previous window in the current frame." + (let ((group (current-group))) + (if (group-current-window group) + (focus-forward group (reverse (frame-sort-windows group (tile-group-current-frame group)))) + (other-window-in-frame group)))) + +(defcommand other-in-frame () () +"Go to the last accessed window in the current frame." + (other-window-in-frame (current-group))) + +;;; frame.lisp ends here diff --git a/group.lisp b/group.lisp new file mode 100644 index 0000000..b110c4d --- /dev/null +++ b/group.lisp @@ -0,0 +1,199 @@ +;; Copyright (C) 2003, 2008 * +;; +;; This file is part of stumpwm. +;; +;; stumpwm is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; stumpwm is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this software; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;; Boston, MA 02111-1307 USA +;; +;; Commentary: +;; +;; Commands for manipulating groups, extracted from user.lisp. +;; +;; * user.lisp Copyright (C) 2003 Shawn Betts +;; +;; Code: + +(in-package :stumpwm) + +(defun select-group (screen query) + "Attempt to match string QUERY against group number or partial name." + (let (match + (num (ignore-errors (parse-integer query)))) + (labels ((match (grp) + (let* ((name (group-name grp)) + (end (min (length name) (length query)))) + ;; try by name or number + (or (string-equal name query :end1 end :end2 end) + (eql (group-number grp) num))))) + (unless (null query) + (setf match (find-if #'match (screen-groups screen)))) + match))) + +;; FIXME: groups are to screens exactly as windows are to +;; groups. There is a lot of duplicate code that could be globbed +;; together. + +(defvar *groups-map* nil + "The keymap that group related key bindings sit on. It is bound to @kbd{C-t g} by default.") + +(when (null *groups-map*) + (setf *groups-map* + (let ((m (make-sparse-keymap))) + (define-key m (kbd "g") "groups") + (define-key m (kbd "c") "gnew") + (define-key m (kbd "n") "gnext") + (define-key m (kbd "C-n") "gnext") + (define-key m (kbd "SPC") "gnext") + (define-key m (kbd "C-SPC") "gnext") + (define-key m (kbd "p") "gprev") + (define-key m (kbd "C-p") "gprev") + (define-key m (kbd "o") "gother") + (define-key m (kbd "'") "gselect") + (define-key m (kbd "m") "gmove") + (define-key m (kbd "M") "gmove-marked") + (define-key m (kbd "k") "gkill") + (define-key m (kbd "A") "grename") + (define-key m (kbd "r") "grename") + (define-key m (kbd "1") "gselect 1") + (define-key m (kbd "2") "gselect 2") + (define-key m (kbd "3") "gselect 3") + (define-key m (kbd "4") "gselect 4") + (define-key m (kbd "5") "gselect 5") + (define-key m (kbd "6") "gselect 6") + (define-key m (kbd "7") "gselect 7") + (define-key m (kbd "8") "gselect 8") + (define-key m (kbd "9") "gselect 9") + (define-key m (kbd "0") "gselect 10") + m))) + +(defun group-forward (current list) + (let ((ng (next-group current list))) + (when ng + (switch-to-group ng)))) + +(defcommand gnew (name) ((:string "Group Name: ")) +"Create a new group with the specified name. The new group becomes the +current group. If @var{name} begins with a dot (``.'') the group new +group will be created in the hidden state. Hidden groups have group +numbers less than one and are invisible to from gprev, gnext, and, optionally, +groups and vgroups commands." + (let ((group (add-group (current-screen) name))) + (if group + (switch-to-group group) + (message "^B^3*Groups must have a name!")))) + +(defcommand gnewbg (name) ((:string "Group Name: ")) +"Create a new group but do not switch to it." + (unless (find-group (current-screen) name) + (add-group (current-screen) name))) + +(defcommand gnext () () +"Cycle to the next group in the group list." + (group-forward (current-group) + (sort-groups (current-screen)))) + +(defcommand gprev () () +"Cycle to the previous group in the group list." + (group-forward (current-group) + (reverse (sort-groups (current-screen))))) + +(defcommand gother () () + "Go back to the last group." + (let ((groups (screen-groups (current-screen)))) + (when (> (length groups) 1) + (switch-to-group (second groups))))) + +(defcommand grename (name) ((:string "New name for group: ")) + "Rename the current group." + (let ((group (current-group))) + (cond ((find-group (current-screen) name) + (message "^1*^BError: Name already exists")) + ((or (zerop (length name)) + (string= name ".")) + (message "^1*^BError: empty name")) + (t + (cond ((and (char= (char name 0) #\.) ;change to hidden group + (not (char= (char (group-name group) 0) #\.))) + (setf (group-number group) (find-free-hidden-group-number (current-screen)))) + ((and (not (char= (char name 0) #\.)) ;change from hidden group + (char= (char (group-name group) 0) #\.)) + (setf (group-number group) (find-free-group-number (current-screen))))) + (setf (group-name group) name))))) + +(defun echo-groups (screen fmt &optional verbose (wfmt *window-format*)) + "Print a list of the windows to the screen." + (let* ((groups (sort-groups screen)) + (names (mapcan (lambda (g) + (list* + (format-expand *group-formatters* fmt g) + (when verbose + (mapcar (lambda (w) + (format-expand *window-formatters* + (concatenate 'string " " wfmt) + w)) + (sort-windows g))))) + (if *list-hidden-groups* groups (non-hidden-groups groups))))) + (echo-string-list screen names))) + +(defcommand groups (&optional (fmt *group-format*)) (:rest) +"Display the list of groups with their number and +name. @var{*group-format*} controls the formatting. The optional +argument @var{fmt} can be used to override the default group +formatting." + (echo-groups (current-screen) fmt)) + +(defcommand vgroups (&optional gfmt wfmt) (:string :rest) +"Like @command{groups} but also display the windows in each group. The +optional arguments @var{gfmt} and @var{wfmt} can be used to override +the default group formatting and window formatting, respectively." + (echo-groups (current-screen) + (or gfmt *group-format*) + t (or wfmt *window-format*))) + +(defcommand gselect (to-group) ((:group "Select Group: ")) +"Select the first group that starts with address@hidden @var{substring} can also be a number, in which case address@hidden selects the group with that number." + (when to-group + (switch-to-group to-group))) + +(defcommand gmove (to-group) ((:group "To Group: ")) +"Move the current window to the specified group." + (when (and to-group + (current-window)) + (move-window-to-group (current-window) to-group))) + +(defcommand gmove-marked (to-group) ((:group "To Group: ")) + (when to-group + (let ((group (current-group))) + (dolist (i (marked-windows group)) + (setf (window-marked i) nil) + (move-window-to-group i to-group))))) + +(defcommand gkill () () +"Kill the current group. All windows in the current group are migrated +to the next group." + (let ((dead-group (current-group)) + (to-group (next-group (current-group)))) + (switch-to-group to-group) + (kill-group dead-group to-group))) + +(defcommand gmerge (from) ((:group "From Group: ")) +"Merge @var{from} into the current group. @var{from} is not deleted." + (if (eq from (current-group)) + (message "^B^3*Cannot merge group with itself!") + (merge-groups from (current-group)))) + +;;; group.lisp ends here diff --git a/resize.lisp b/resize.lisp new file mode 100644 index 0000000..f6586bc --- /dev/null +++ b/resize.lisp @@ -0,0 +1,133 @@ +;; Copyright (C) 2003, 2008 * +;; +;; This file is part of stumpwm. +;; +;; stumpwm is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; stumpwm is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this software; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;; Boston, MA 02111-1307 USA +;; +;; Commentary: +;; +;; Commands for resizing windows and frames; all code so far extracted +;; from user.lisp. +;; +;; * user.lisp Copyright (C) 2003 Shawn Betts +;; +;; Code: + +(in-package :stumpwm) + +(defcommand resize (width height) ((:number "+ Width: ") + (:number "+ Height: ")) + "Resize the current frame by @var{width} and @var{height} pixels" + (let* ((group (current-group)) + (f (tile-group-current-frame group))) + (if (atom (tile-group-frame-tree group)) + (message "No more frames!") + (progn + (clear-frame-outlines group) + (resize-frame group f width :width) + (resize-frame group f height :height) + (draw-frame-outlines group (current-head)))))) + +(defcommand balance-frames () () + "Make frames the same height or width in the current frame's subtree." + (let* ((group (current-group)) + (tree (tree-parent (tile-group-frame-head group (current-head)) + (tile-group-current-frame group)))) + (if tree + (balance-frames-internal (current-group) tree) + (message "There's only one frame.")))) + +;;; A resize minor mode. Something a bit better should probably be +;;; written. But it's an interesting way of doing it. + +(defvar *resize-backup* nil) + +(defvar *resize-increment* 10 + "Number of pixels to increment by when interactively resizing frames.") + +(defun set-resize-increment (val) + (setf *resize-increment* val) + (update-resize-map)) + +(defun update-resize-map () + (let ((m (or *resize-map* (setf *resize-map* (make-sparse-keymap))))) + (let ((i *resize-increment*)) + (labels ((dk (m k c) + (define-key m k (format nil c i)))) + (dk m (kbd "Up") "resize 0 -~D") + (dk m (kbd "C-p") "resize 0 -~D") + (dk m (kbd "p") "resize 0 -~D") + (dk m (kbd "k") "resize 0 -~D") + + (dk m (kbd "Down") "resize 0 ~D") + (dk m (kbd "C-n") "resize 0 ~D") + (dk m (kbd "n") "resize 0 ~D") + (dk m (kbd "j") "resize 0 ~D") + + (dk m (kbd "Left") "resize -~D 0") + (dk m (kbd "C-b") "resize -~D 0") + (dk m (kbd "b") "resize -~D 0") + (dk m (kbd "h") "resize -~D 0") + + (dk m (kbd "Right") "resize ~D 0") + (dk m (kbd "C-f") "resize ~D 0") + (dk m (kbd "f") "resize ~D 0") + (dk m (kbd "l") "resize ~D 0") + (define-key m (kbd "RET") "exit-iresize") + (define-key m (kbd "C-g") "abort-iresize") + (define-key m (kbd "ESC") "abort-iresize"))))) + +(update-resize-map) + +(defcommand iresize () () + (let ((frame (tile-group-current-frame (current-group)))) + (if (atom (tile-group-frame-head (current-group) (frame-head (current-group) frame))) + (message "There's only 1 frame!") + (progn + (when *resize-hides-windows* + (dolist (f (head-frames (current-group) (current-head))) + (clear-frame f (current-group)))) + (message "Resize Frame") + (push-top-map *resize-map*) + (draw-frame-outlines (current-group) (current-head))) + ;; (setf *resize-backup* (copy-frame-tree (current-group))) + ))) + +(defun resize-unhide () + (clear-frame-outlines (current-group)) + (when *resize-hides-windows* + (let ((group (current-group)) + (head (current-head))) + (dolist (f (head-frames group head)) + (sync-frame-windows group f)) + (dolist (w (reverse (head-windows group head))) + (setf (frame-window (window-frame w)) w) + (raise-window w)) + (when (current-window) + (focus-window (current-window)))))) + +(defcommand abort-iresize () () + (resize-unhide) + (message "Abort resize") + ;; TODO: actually revert the frames + (pop-top-map)) + +(defcommand exit-iresize () () + (resize-unhide) + (message "Resize Complete") + (pop-top-map)) + +;;; resize.lisp ends here diff --git a/user.lisp b/user.lisp index 6a0b347..86d3e31 100644 --- a/user.lisp +++ b/user.lisp @@ -219,92 +219,6 @@ menu, the error is re-signalled." (when restart (invoke-restart (second restart))))) -(defun focus-next-window (group) - (focus-forward group (sort-windows group))) - -(defun focus-prev-window (group) - (focus-forward group - (reverse - (sort-windows group)))) - -(defcommand next () () - "Go to the next window in the window list." - (let ((group (current-group))) - (if (group-current-window group) - (focus-next-window group) - (other-window group)))) - -(defcommand prev () () - "Go to the previous window in the window list." - (let ((group (current-group))) - (if (group-current-window group) - (focus-prev-window group) - (other-window group)))) - -(defun pull-window (win &optional (to-frame (tile-group-current-frame (window-group win)))) - (let ((f (window-frame win)) - (group (window-group win))) - (unless (eq (frame-window to-frame) win) - (xwin-hide win) - (setf (window-frame win) to-frame) - (maximize-window win) - (when (eq (window-group win) (current-group)) - (xwin-unhide (window-xwin win) (window-parent win))) - ;; We have to restore the focus after hiding. - (when (eq win (screen-focus (window-screen win))) - (screen-set-focus (window-screen win) win)) - (frame-raise-window group to-frame win) - ;; if win was focused in its old frame then give the old - ;; frame the frame's last focused window. - (when (eq (frame-window f) win) - ;; the current value is no longer valid. - (setf (frame-window f) nil) - (frame-raise-window group f (first (frame-windows group f)) nil))))) - -;; In the future, this window will raise the window into the current -;; frame. -(defun focus-forward (group window-list &optional pull-p (predicate (constantly t))) - "Set the focus to the next item in window-list from the focused -window. If PULL-P is T then pull the window into the current -frame." - ;; The window with focus is the "current" window, so find it in the - ;; list and give that window focus - (let* ((w (group-current-window group)) - (wins (remove-if-not predicate (cdr (member w window-list)))) - (nw (if (null wins) - ;; If the last window in the list is focused, then - ;; focus the first one. - (car (remove-if-not predicate window-list)) - ;; Otherwise, focus the next one in the list. - (first wins)))) - ;; there's still the case when the window is the only one in the - ;; list, so make sure its not the same as the current window. - (if (and nw - (not (eq w nw))) - (if pull-p - (pull-window nw) - (frame-raise-window group (window-frame nw) nw)) - (message "No other window.")))) - -(defcommand delete-current-window () () - "Delete the current window. This is a request sent to the window. The -window's client may decide not to grant the request or may not be able -to if it is unresponsive." - (let ((group (current-group))) - (when (group-current-window group) - (delete-window (group-current-window group))))) - -(defcommand-alias delete delete-current-window) - -(defcommand kill-current-window () () -"`Tell X to disconnect the client that owns the current window. if address@hidden didn't work, try this." - (let ((group (current-group))) - (when (group-current-window group) - (xwin-kill (window-xwin (group-current-window group)))))) - -(defcommand-alias kill kill-current-window) - (defun banish-pointer (&optional (where *banish-pointer-to*)) "Move the pointer to the lower right corner of the head, or WHEREever (one of :screen :head :frame or :window)" @@ -349,32 +263,6 @@ to if it is unresponsive." (when (current-window) (send-fake-click (current-window) button))) -(defun echo-windows (group fmt &optional (windows (group-windows group))) - "Print a list of the windows to the screen." - (let* ((wins (sort1 windows '< :key 'window-number)) - (highlight (position (group-current-window group) wins)) - (names (mapcar (lambda (w) - (format-expand *window-formatters* fmt w)) wins))) - (if (null wins) - (echo-string (group-screen group) "No Managed Windows") - (echo-string-list (group-screen group) names highlight)))) - -(defcommand windows (&optional (fmt *window-format*)) (:rest) - "Display a list of managed windows. The optional argument @var{fmt} can -be used to override the default window formatting." - (echo-windows (current-group) fmt)) - -(defcommand echo-frame-windows (&optional (fmt *window-format*)) (:rest) - (echo-windows (current-group) fmt (frame-windows (current-group) - (tile-group-current-frame (current-group))))) - -(defcommand-alias frame-windows echo-frame-windows) - -(defcommand title (title) ((:rest "Set window's title to: ")) - (if (current-window) - (setf (window-user-title (current-window)) title) - (message "No Focused Window"))) - ;;; (format-time-stringc ...) section (defmacro time-lambda (used-var &body body) `(lambda (sec min hour dom mon year dow dstp tz) @@ -504,43 +392,6 @@ the 'date' command options except the following ones: %g, %G, %j, %N, (defcommand-alias time echo-date) -(defun select-window (group query) - "Read input from the user and go to the selected window." - (let (match) - (labels ((match (win) - (let* ((wname (window-name win)) - (end (min (length wname) (length query)))) - (string-equal wname query :end1 end :end2 end)))) - (unless (null query) - (setf match (find-if #'match (group-windows group)))) - (when match - (frame-raise-window group (window-frame match) match))))) - -(defcommand select (win) ((:window-name "Select: ")) - "Switch to the first window that starts with @var{win}." - (select-window (current-group) win)) - -(defun select-window-number (group num) - (labels ((match (win) - (= (window-number win) num))) - (let ((win (find-if #'match (group-windows group)))) - (when win - (frame-raise-window group (window-frame win) win))))) - -(defun other-window (group) - (let* ((wins (group-windows group)) - ;; the frame could be empty - (win (if (group-current-window group) - (second wins) - (first wins)))) - (if win - (frame-raise-window group (window-frame win) win) - (echo-string (group-screen group) "No other window.")))) - -(defcommand other () () - "Switch to the window last focused." - (other-window (current-group))) - (defun programs-in-path (base &optional full-path (path (split-string (getenv "PATH") ":"))) "Return a list of programs in the path that start with @var{base}. if @var{full-path} is @var{t} then return the full path, otherwise just @@ -575,180 +426,6 @@ such a case, kill the shell command to resume StumpWM." (defcommand-alias exec run-shell-command) -(defun split-frame-in-dir (group dir) - (let ((f (tile-group-current-frame group))) - (if (split-frame group dir) - (progn - (when (frame-window f) - (update-window-border (frame-window f))) - (show-frame-indicator group)) - (message "Cannot split smaller than minimum size.")))) - -(defcommand hsplit () () -"Split the current frame into 2 side-by-side frames." - (split-frame-in-dir (current-group) :column)) - -(defcommand vsplit () () -"Split the current frame into 2 frames, one on top of the other." - (split-frame-in-dir (current-group) :row)) - -(defcommand remove-split (&optional (group (current-group))) () -"Remove the current frame in the specified group (defaults to current -group). Windows in the frame are migrated to the frame taking up its -space." - (let* ((frame (tile-group-current-frame group)) - (head (frame-head group frame)) - (tree (tile-group-frame-head group head)) - (s (closest-sibling (list tree) frame)) - ;; grab a leaf of the siblings. The siblings doesn't have to be - ;; a frame. - (l (tree-accum-fn s - (lambda (&rest siblings) - (car siblings)) - #'identity))) - ;; Only remove the current frame if it has a sibling - (if (atom tree) - (message "No more frames!") - (when s - (when (frame-is-head group frame) - (setf (frame-number l) (frame-number frame))) - ;; Move the windows from the removed frame to its sibling - (migrate-frame-windows group frame l) - ;; If the frame has no window, give it the current window of - ;; the current frame. - (unless (frame-window l) - (setf (frame-window l) - (frame-window frame))) - ;; Unsplit - (setf (tile-group-frame-head group head) (remove-frame tree frame)) - ;; update the current frame and sync all windows - (setf (tile-group-current-frame group) l) - (tree-iterate tree - (lambda (leaf) - (sync-frame-windows group leaf))) - (frame-raise-window group l (frame-window l)) - (when (frame-window l) - (update-window-border (frame-window l))) - (show-frame-indicator group))))) - -(defcommand-alias remove remove-split) - -(defcommand only () () - "Delete all the frames but the current one and grow it to take up the entire head." - (let* ((screen (current-screen)) - (group (screen-current-group screen)) - (win (frame-window (tile-group-current-frame group))) - (head (current-head group)) - (frame (copy-frame head))) - (if (atom (tile-group-frame-head group head)) - (message "There's only one frame.") - (progn - (mapc (lambda (w) - ;; windows in other frames disappear - (unless (eq (window-frame w) (tile-group-current-frame group)) - (hide-window w)) - (setf (window-frame w) frame)) - (head-windows group head)) - (setf (frame-window frame) win - (tile-group-frame-head group head) frame - (tile-group-current-frame group) frame) - (focus-frame group frame) - (if (frame-window frame) - (update-window-border (frame-window frame)) - (show-frame-indicator group)) - (sync-frame-windows group (tile-group-current-frame group)))))) - -(defcommand fullscreen () () - "Toggle the fullscreen mode of the current widnow. Use this for clients -with broken (non-NETWM) fullscreen implemenations, such as any program -using SDL." - (update-fullscreen (current-window) 2)) - -(defcommand curframe () () -"Display a window indicating which frame is focused." - (show-frame-indicator (current-group) t)) - -(defun focus-frame-next-sibling (group) - (let* ((sib (next-sibling (tile-group-frame-tree group) - (tile-group-current-frame group)))) - (when sib - (focus-frame group (tree-accum-fn sib - (lambda (x y) - (declare (ignore y)) - x) - 'identity)) - (show-frame-indicator group)))) - -(defun focus-last-frame (group) - ;; make sure the last frame still exists in the frame tree - (when (and (tile-group-last-frame group) - (find (tile-group-last-frame group) (group-frames group))) - (focus-frame group (tile-group-last-frame group)))) - -(defun focus-frame-after (group frames) - "Given a list of frames focus the next one in the list after -the current frame." - (let ((rest (cdr (member (tile-group-current-frame group) frames :test 'eq)))) - (focus-frame group - (if (null rest) - (car frames) - (car rest))))) - -(defun focus-next-frame (group) - (focus-frame-after group (group-frames group))) - -(defun focus-prev-frame (group) - (focus-frame-after group (nreverse (group-frames group)))) - -(defcommand fnext () () -"Cycle through the frame tree to the next frame." - (focus-next-frame (current-group))) - -(defcommand sibling () () -"Jump to the frame's sibling. If a frame is split into twe frames, -these two frames are siblings." - (focus-frame-next-sibling (current-group))) - -(defcommand fother () () -"Jump to the last frame that had focus." - (focus-last-frame (current-group))) - -(defun choose-frame-by-number (group) - "show a number in the corner of each frame and wait for the user to -select one. Returns the selected frame or nil if aborted." - (let* ((wins (progn - (draw-frame-outlines group) - (draw-frame-numbers group))) - (ch (read-one-char (group-screen group))) - (num (read-from-string (string ch) nil nil))) - (dformat 3 "read ~S ~S~%" ch num) - (mapc #'xlib:destroy-window wins) - (clear-frame-outlines group) - (find ch (group-frames group) - :test 'char= - :key 'get-frame-number-translation))) - - -(defcommand fselect (frame-number) ((:frame t)) -"Display a number in the corner of each frame and let the user to -select a frame by number. If @var{frame-number} is specified, just -jump to that frame." - (let ((group (current-group))) - (focus-frame group frame-number))) - -(defcommand resize (width height) ((:number "+ Width: ") - (:number "+ Height: ")) - "Resize the current frame by @var{width} and @var{height} pixels" - (let* ((group (current-group)) - (f (tile-group-current-frame group))) - (if (atom (tile-group-frame-tree group)) - (message "No more frames!") - (progn - (clear-frame-outlines group) - (resize-frame group f width :width) - (resize-frame group f height :height) - (draw-frame-outlines group (current-head)))))) - (defcommand eval-line (cmd) ((:rest "Eval: ")) (handler-case (message "^20~{~a~^~%~}" @@ -935,20 +612,6 @@ string between them." (or gravity (throw 'error "No matching gravity.")))) -(defun select-group (screen query) - "Attempt to match string QUERY against group number or partial name." - (let (match - (num (ignore-errors (parse-integer query)))) - (labels ((match (grp) - (let* ((name (group-name grp)) - (end (min (length name) (length query)))) - ;; try by name or number - (or (string-equal name query :end1 end :end2 end) - (eql (group-number grp) num))))) - (unless (null query) - (setf match (find-if #'match (screen-groups screen)))) - match))) - (define-stumpwm-type :group (input prompt) (let ((match (select-group (current-screen) (or (argument-pop input) @@ -1084,15 +747,6 @@ supplied, the text will appear in the prompt." (when (plusp (length cmd)) (interactive-command cmd)))) -(defcommand pull-window-by-number (n &optional (group (current-group))) - ((:window-number "Pull: ")) - "Pull window N from another frame into the current frame and focus it." - (let ((win (find n (group-windows group) :key 'window-number :test '=))) - (when win - (pull-window win)))) - -(defcommand-alias pull pull-window-by-number) - (defun send-meta-key (screen key) "Send the prefix key" (when (screen-current-window screen) @@ -1102,24 +756,6 @@ supplied, the text will appear in the prompt." "Send a fake key to the current window. @var{key} is a typical StumpWM key, like @kbd{C-M-o}." (send-meta-key (current-screen) key)) -(defcommand renumber (nt &optional (group (current-group))) ((:number "Number: ")) - "Change the current window's number to the specified number. If another window -is using the number, then the windows swap numbers. Defaults to current group." - (let ((nf (window-number (group-current-window group))) - (win (find-if #'(lambda (win) - (= (window-number win) nt)) - (group-windows group)))) - ;; Is it already taken? - (if win - (progn - ;; swap the window numbers - (setf (window-number win) nf) - (setf (window-number (group-current-window group)) nt)) - ;; Just give the window the number - (setf (window-number (group-current-window group)) nt)))) - -(defcommand-alias number renumber) - (defcommand gravity (gravity) ((:gravity "Gravity: ")) (when (current-window) (setf (window-gravity (current-window)) gravity) @@ -1226,90 +862,6 @@ differs from a theoretical hard restart, which would restart the unix process." (throw :top-level :restart)) -(defun clear-frame (frame group) - "Clear the given frame." - (frame-raise-window group frame nil (eq (tile-group-current-frame group) frame))) - -(defcommand fclear () () -"Clear the current frame." - (clear-frame (tile-group-current-frame (current-group)) (current-group))) - -(defun get-edge (frame edge) - "Returns the specified edge of FRAME. Valid values for EDGE are :TOP, :BOTTOM, :LEFT, and :RIGHT. - An edge is a START, END, and OFFSET. For horizontal edges, START is the left coordinate, END is - the right coordinate, and OFFSET is the Y coordinate. Similarly, for vertical lines, START is - top, END is bottom, and OFFSET is X coordinate." - (let* ((x1 (frame-x frame)) - (y1 (frame-y frame)) - (x2 (+ x1 (frame-width frame))) - (y2 (+ y1 (frame-height frame)))) - (ecase edge - (:top - (values x1 x2 y1)) - (:bottom - (values x1 x2 y2)) - (:left - (values y1 y2 x1)) - (:right - (values y1 y2 x2))))) - -(defun neighbour (direction frame frameset) - "Returns the best neighbour of FRAME in FRAMESET on the DIRECTION edge. - Valid directions are :UP, :DOWN, :LEFT, :RIGHT. - eg: (NEIGHBOUR :UP F FS) finds the frame in FS that is the 'best' - neighbour above F." - (let ((src-edge (ecase direction - (:up :top) - (:down :bottom) - (:left :left) - (:right :right))) - (opposite (ecase direction - (:up :bottom) - (:down :top) - (:left :right) - (:right :left))) - (best-frame nil) - (best-overlap 0)) - (multiple-value-bind (src-s src-e src-offset) - (get-edge frame src-edge) - (dolist (f frameset) - (multiple-value-bind (s e offset) - (get-edge f opposite) - (let ((overlap (- (min src-e e) - (max src-s s)))) - ;; Two edges are neighbours if they have the same offset and their starts and ends - ;; overlap. We want to find the neighbour that overlaps the most. - (when (and (= src-offset offset) - (>= overlap best-overlap)) - (setf best-frame f) - (setf best-overlap overlap)))))) - best-frame)) - -(defun move-focus-and-or-window (dir &optional win-p) - (let* ((group (current-group)) - (direction (intern (string-upcase dir) :keyword)) - (new-frame (neighbour direction (tile-group-current-frame group) (group-frames group))) - (window (current-window))) - (when new-frame - (if (and win-p window) - (pull-window window new-frame) - (focus-frame group new-frame))))) - -(defcommand move-focus (dir) ((:string "Direction: ")) -"Focus the frame adjacent to the current one in the specified -direction. The following are valid directions: address@hidden @asis address@hidden up address@hidden down address@hidden left address@hidden right address@hidden table" - (move-focus-and-or-window dir)) - -(defcommand move-window (dir) ((:string "Direction: ")) -"Just like move-focus except that the current is pulled along." - (move-focus-and-or-window dir t)) - (defun run-or-raise (cmd props &optional (all-groups *run-or-raise-all-groups*) (all-screens *run-or-raise-all-screens*)) "Run the shell command, @var{cmd}, unless an existing window matches @var{props}. @var{props} is a property list with the following keys: @@ -1386,243 +938,6 @@ escape C-z (echo-nth-last-message (current-screen) *lastmsg-nth*) (message "No last message."))) -;;; A resize minor mode. Something a bit better should probably be -;;; written. But it's an interesting way of doing it. - -(defvar *resize-backup* nil) - -(defvar *resize-increment* 10 - "Number of pixels to increment by when interactively resizing frames.") - -(defun set-resize-increment (val) - (setf *resize-increment* val) - (update-resize-map)) - -(defun update-resize-map () - (let ((m (or *resize-map* (setf *resize-map* (make-sparse-keymap))))) - (let ((i *resize-increment*)) - (labels ((dk (m k c) - (define-key m k (format nil c i)))) - (dk m (kbd "Up") "resize 0 -~D") - (dk m (kbd "C-p") "resize 0 -~D") - (dk m (kbd "p") "resize 0 -~D") - (dk m (kbd "k") "resize 0 -~D") - - (dk m (kbd "Down") "resize 0 ~D") - (dk m (kbd "C-n") "resize 0 ~D") - (dk m (kbd "n") "resize 0 ~D") - (dk m (kbd "j") "resize 0 ~D") - - (dk m (kbd "Left") "resize -~D 0") - (dk m (kbd "C-b") "resize -~D 0") - (dk m (kbd "b") "resize -~D 0") - (dk m (kbd "h") "resize -~D 0") - - (dk m (kbd "Right") "resize ~D 0") - (dk m (kbd "C-f") "resize ~D 0") - (dk m (kbd "f") "resize ~D 0") - (dk m (kbd "l") "resize ~D 0") - (define-key m (kbd "RET") "exit-iresize") - (define-key m (kbd "C-g") "abort-iresize") - (define-key m (kbd "ESC") "abort-iresize"))))) - -(update-resize-map) - -(defcommand iresize () () - (let ((frame (tile-group-current-frame (current-group)))) - (if (atom (tile-group-frame-head (current-group) (frame-head (current-group) frame))) - (message "There's only 1 frame!") - (progn - (when *resize-hides-windows* - (dolist (f (head-frames (current-group) (current-head))) - (clear-frame f (current-group)))) - (message "Resize Frame") - (push-top-map *resize-map*) - (draw-frame-outlines (current-group) (current-head))) - ;; (setf *resize-backup* (copy-frame-tree (current-group))) - ))) - -(defun resize-unhide () - (clear-frame-outlines (current-group)) - (when *resize-hides-windows* - (let ((group (current-group)) - (head (current-head))) - (dolist (f (head-frames group head)) - (sync-frame-windows group f)) - (dolist (w (reverse (head-windows group head))) - (setf (frame-window (window-frame w)) w) - (raise-window w)) - (when (current-window) - (focus-window (current-window)))))) - -(defcommand abort-iresize () () - (resize-unhide) - (message "Abort resize") - ;; TODO: actually revert the frames - (pop-top-map)) - -(defcommand exit-iresize () () - (resize-unhide) - (message "Resize Complete") - (pop-top-map)) - -;;; group commands - -;; FIXME: groups are to screens exactly as windows are to -;; groups. There is a lot of duplicate code that could be globbed -;; together. - -(defvar *groups-map* nil - "The keymap that group related key bindings sit on. It is bound to @kbd{C-t g} by default.") - -(when (null *groups-map*) - (setf *groups-map* - (let ((m (make-sparse-keymap))) - (define-key m (kbd "g") "groups") - (define-key m (kbd "c") "gnew") - (define-key m (kbd "n") "gnext") - (define-key m (kbd "C-n") "gnext") - (define-key m (kbd "SPC") "gnext") - (define-key m (kbd "C-SPC") "gnext") - (define-key m (kbd "p") "gprev") - (define-key m (kbd "C-p") "gprev") - (define-key m (kbd "o") "gother") - (define-key m (kbd "'") "gselect") - (define-key m (kbd "m") "gmove") - (define-key m (kbd "M") "gmove-marked") - (define-key m (kbd "k") "gkill") - (define-key m (kbd "A") "grename") - (define-key m (kbd "r") "grename") - (define-key m (kbd "1") "gselect 1") - (define-key m (kbd "2") "gselect 2") - (define-key m (kbd "3") "gselect 3") - (define-key m (kbd "4") "gselect 4") - (define-key m (kbd "5") "gselect 5") - (define-key m (kbd "6") "gselect 6") - (define-key m (kbd "7") "gselect 7") - (define-key m (kbd "8") "gselect 8") - (define-key m (kbd "9") "gselect 9") - (define-key m (kbd "0") "gselect 10") - m))) - -(defun group-forward (current list) - (let ((ng (next-group current list))) - (when ng - (switch-to-group ng)))) - -(defcommand gnew (name) ((:string "Group Name: ")) -"Create a new group with the specified name. The new group becomes the -current group. If @var{name} begins with a dot (``.'') the group new -group will be created in the hidden state. Hidden groups have group -numbers less than one and are invisible to from gprev, gnext, and, optionally, -groups and vgroups commands." - (let ((group (add-group (current-screen) name))) - (if group - (switch-to-group group) - (message "^B^3*Groups must have a name!")))) - -(defcommand gnewbg (name) ((:string "Group Name: ")) -"Create a new group but do not switch to it." - (unless (find-group (current-screen) name) - (add-group (current-screen) name))) - -(defcommand gnext () () -"Cycle to the next group in the group list." - (group-forward (current-group) - (sort-groups (current-screen)))) - -(defcommand gprev () () -"Cycle to the previous group in the group list." - (group-forward (current-group) - (reverse (sort-groups (current-screen))))) - -(defcommand gother () () - "Go back to the last group." - (let ((groups (screen-groups (current-screen)))) - (when (> (length groups) 1) - (switch-to-group (second groups))))) - -(defcommand grename (name) ((:string "New name for group: ")) - "Rename the current group." - (let ((group (current-group))) - (cond ((find-group (current-screen) name) - (message "^1*^BError: Name already exists")) - ((or (zerop (length name)) - (string= name ".")) - (message "^1*^BError: empty name")) - (t - (cond ((and (char= (char name 0) #\.) ;change to hidden group - (not (char= (char (group-name group) 0) #\.))) - (setf (group-number group) (find-free-hidden-group-number (current-screen)))) - ((and (not (char= (char name 0) #\.)) ;change from hidden group - (char= (char (group-name group) 0) #\.)) - (setf (group-number group) (find-free-group-number (current-screen))))) - (setf (group-name group) name))))) - -(defun echo-groups (screen fmt &optional verbose (wfmt *window-format*)) - "Print a list of the windows to the screen." - (let* ((groups (sort-groups screen)) - (names (mapcan (lambda (g) - (list* - (format-expand *group-formatters* fmt g) - (when verbose - (mapcar (lambda (w) - (format-expand *window-formatters* - (concatenate 'string " " wfmt) - w)) - (sort-windows g))))) - (if *list-hidden-groups* groups (non-hidden-groups groups))))) - (echo-string-list screen names))) - -(defcommand groups (&optional (fmt *group-format*)) (:rest) -"Display the list of groups with their number and -name. @var{*group-format*} controls the formatting. The optional -argument @var{fmt} can be used to override the default group -formatting." - (echo-groups (current-screen) fmt)) - -(defcommand vgroups (&optional gfmt wfmt) (:string :rest) -"Like @command{groups} but also display the windows in each group. The -optional arguments @var{gfmt} and @var{wfmt} can be used to override -the default group formatting and window formatting, respectively." - (echo-groups (current-screen) - (or gfmt *group-format*) - t (or wfmt *window-format*))) - -(defcommand gselect (to-group) ((:group "Select Group: ")) -"Select the first group that starts with address@hidden @var{substring} can also be a number, in which case address@hidden selects the group with that number." - (when to-group - (switch-to-group to-group))) - -(defcommand gmove (to-group) ((:group "To Group: ")) -"Move the current window to the specified group." - (when (and to-group - (current-window)) - (move-window-to-group (current-window) to-group))) - -(defcommand gmove-marked (to-group) ((:group "To Group: ")) - (when to-group - (let ((group (current-group))) - (dolist (i (marked-windows group)) - (setf (window-marked i) nil) - (move-window-to-group i to-group))))) - -(defcommand gkill () () -"Kill the current group. All windows in the current group are migrated -to the next group." - (let ((dead-group (current-group)) - (to-group (next-group (current-group)))) - (switch-to-group to-group) - (kill-group dead-group to-group))) - -(defcommand gmerge (from) ((:group "From Group: ")) -"Merge @var{from} into the current group. @var{from} is not deleted." - (if (eq from (current-group)) - (message "^B^3*Cannot merge group with itself!") - (merge-groups from (current-group)))) - ;;; interactive menu (defvar *menu-map* nil @@ -1706,24 +1021,6 @@ See *menu-map* for menu bindings." (funcall action menu))))) (unmap-all-message-windows))))) -(defcommand windowlist (&optional (fmt *window-format*)) (:rest) -"Allow the user to Select a window from the list of windows and focus -the selected window. For information of menu bindings address@hidden The optional argument @var{fmt} can be specified to -override the default window formatting." - (if (null (group-windows (current-group))) - (message "No Managed Windows") - (let* ((group (current-group)) - (window (second (select-from-menu - (current-screen) - (mapcar (lambda (w) - (list (format-expand *window-formatters* fmt w) w)) - (sort-windows group)))))) - - (if window - (frame-raise-window group (window-frame window) window) - (throw 'error :abort))))) - (defcommand reload () () "Reload StumpWM using @code{asdf}." (message "Reloading StumpWM...") @@ -1792,62 +1089,6 @@ know lisp very well. One might put the following in one's rc file: "Echo the X selection." (message "~a" (get-x-selection))) -(defun other-hidden-window (group) - "Return the last window that was accessed and that is hidden." - (let ((wins (remove-if (lambda (w) (eq (frame-window (window-frame w)) w)) (group-windows group)))) - (first wins))) - -(defun pull-other-hidden-window (group) - "pull the last accessed hidden window from any frame into the -current frame and raise it." - (let ((win (other-hidden-window group))) - (if win - (pull-window win) - (echo-string (group-screen group) "No other window.")))) - -(defun other-window-in-frame (group) - (let* ((f (tile-group-current-frame group)) - (wins (frame-windows group f)) - (win (if (frame-window f) - (second wins) - (first wins)))) - (if win - (frame-raise-window group (window-frame win) win) - (echo-string (group-screen group) "No other window.")))) - -(defcommand pull-hidden-next () () -"Pull the next hidden window into the current frame." - (let ((group (current-group))) - (focus-forward group (sort-windows group) t (lambda (w) (not (eq (frame-window (window-frame w)) w)))))) - -(defcommand pull-hidden-previous () () -"Pull the next hidden window into the current frame." - (let ((group (current-group))) - (focus-forward group (nreverse (sort-windows group)) t (lambda (w) (not (eq (frame-window (window-frame w)) w)))))) - -(defcommand pull-hidden-other () () -"Pull the last focused, hidden window into the current frame." - (let ((group (current-group))) - (pull-other-hidden-window group))) - -(defcommand next-in-frame () () -"Go to the next window in the current frame." - (let ((group (current-group))) - (if (group-current-window group) - (focus-forward group (frame-sort-windows group (tile-group-current-frame group))) - (other-window-in-frame group)))) - -(defcommand prev-in-frame () () -"Go to the previous window in the current frame." - (let ((group (current-group))) - (if (group-current-window group) - (focus-forward group (reverse (frame-sort-windows group (tile-group-current-frame group)))) - (other-window-in-frame group)))) - -(defcommand other-in-frame () () -"Go to the last accessed window in the current frame." - (other-window-in-frame (current-group))) - (defcommand command-mode () () "Command mode allows you to type ratpoison commands without needing the @key{C-t} prefix. Keys not bound in StumpWM will still get sent to the @@ -1855,36 +1096,6 @@ current window. To exit command mode, type @key{C-g}." (message "Press C-g to exit command-mode.") (push-top-map *root-map*)) -(defcommand mark () () -"Toggle the current window's mark." - (let ((win (current-window))) - (when win - (setf (window-marked win) (not (window-marked win))) - (message (if (window-marked win) - "Marked!" - "Unmarked!"))))) - -(defcommand clear-marks () () -"Clear all marks in the current group." - (let ((group (current-group))) - (clear-window-marks group))) - -(defcommand pull-marked () () -"Pull all marked windows into the current frame and clear the marks." - (let ((group (current-group))) - (dolist (i (marked-windows group)) - (pull-window i)) - (clear-window-marks group))) - -(defcommand balance-frames () () - "Make frames the same height or width in the current frame's subtree." - (let* ((group (current-group)) - (tree (tree-parent (tile-group-frame-head group (current-head)) - (tile-group-current-frame group)))) - (if tree - (balance-frames-internal (current-group) tree) - (message "There's only one frame.")))) - (defcommand describe-key (keys) ((:key-seq "Describe Key: ")) "Either interactively type the key sequence or supply it as text. This command prints the command bound to the specified key sequence." @@ -1917,50 +1128,6 @@ command prints the command bound to the specified key sequence." (mapcar 'print-key-seq (search-kmap cmd *top-map*)))) -;;; window placement commands - -(defun make-rule-for-window (window &optional lock title) - "Guess at a placement rule for WINDOW and add it to the current set." - (let* ((group (window-group window)) - (group-name (group-name group)) - (frame-number (frame-number (window-frame window))) - (role (window-role window))) - (push (list group-name frame-number t lock - :class (window-class window) - :instance (window-res window) - :title (and title (window-name window)) - :role (and (not (equal role "")) role)) - *window-placement-rules*))) - -(defcommand remember (lock title) - ((:y-or-n "Lock to group? ") - (:y-or-n "Use title? ")) - "Make a generic placement rule for the current window. Might be too specific/not specific enough!" - (make-rule-for-window (current-window) (first lock) (first title))) - -(defcommand forget () () - (let* ((window (current-window)) - (match (rule-matching-window window))) - (if match - (progn - (setf *window-placement-rules* (delete match *window-placement-rules*)) - (message "Rule forgotten")) - (message "No matching rule")))) - -(defun dump-window-placement-rules (file) - "Dump *window-placement-rules* to FILE." - (dump-to-file *window-placement-rules* file)) - -(defcommand dump-rules (file) ((:rest "Filename: ")) - (dump-window-placement-rules file)) - -(defun restore-window-placement-rules (file) - "Restore *window-placement-rules* from FILE." - (setf *window-placement-rules* (read-dump-from-file file))) - -(defcommand restore-rules (file) ((:rest "Filename: ")) - (restore-window-placement-rules file)) - (defcommand emacs () () "Start emacs unless it is already running, in which case focus it." (run-or-raise "emacs" '(:class "Emacs"))) diff --git a/window.lisp b/window.lisp new file mode 100644 index 0000000..95b72a4 --- /dev/null +++ b/window.lisp @@ -0,0 +1,341 @@ +;; Copyright (C) 2003, 2008 * +;; +;; This file is part of stumpwm. +;; +;; stumpwm is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; stumpwm is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this software; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;; Boston, MA 02111-1307 USA +;; +;; Commentary: +;; +;; Commands for manipulating windows, extracted from user.lisp. +;; +;; * user.lisp Copyright (C) 2003 Shawn Betts +;; +;; Code: + +;;; Window focus + +(in-package :stumpwm) + +(defun focus-next-window (group) + (focus-forward group (sort-windows group))) + +(defun focus-prev-window (group) + (focus-forward group + (reverse + (sort-windows group)))) + +(defcommand next () () + "Go to the next window in the window list." + (let ((group (current-group))) + (if (group-current-window group) + (focus-next-window group) + (other-window group)))) + +(defcommand prev () () + "Go to the previous window in the window list." + (let ((group (current-group))) + (if (group-current-window group) + (focus-prev-window group) + (other-window group)))) + +(defun pull-window (win &optional (to-frame (tile-group-current-frame (window-group win)))) + (let ((f (window-frame win)) + (group (window-group win))) + (unless (eq (frame-window to-frame) win) + (xwin-hide win) + (setf (window-frame win) to-frame) + (maximize-window win) + (when (eq (window-group win) (current-group)) + (xwin-unhide (window-xwin win) (window-parent win))) + ;; We have to restore the focus after hiding. + (when (eq win (screen-focus (window-screen win))) + (screen-set-focus (window-screen win) win)) + (frame-raise-window group to-frame win) + ;; if win was focused in its old frame then give the old + ;; frame the frame's last focused window. + (when (eq (frame-window f) win) + ;; the current value is no longer valid. + (setf (frame-window f) nil) + (frame-raise-window group f (first (frame-windows group f)) nil))))) + +;; In the future, this window will raise the window into the current +;; frame. +(defun focus-forward (group window-list &optional pull-p (predicate (constantly t))) + "Set the focus to the next item in window-list from the focused +window. If PULL-P is T then pull the window into the current +frame." + ;; The window with focus is the "current" window, so find it in the + ;; list and give that window focus + (let* ((w (group-current-window group)) + (wins (remove-if-not predicate (cdr (member w window-list)))) + (nw (if (null wins) + ;; If the last window in the list is focused, then + ;; focus the first one. + (car (remove-if-not predicate window-list)) + ;; Otherwise, focus the next one in the list. + (first wins)))) + ;; there's still the case when the window is the only one in the + ;; list, so make sure its not the same as the current window. + (if (and nw + (not (eq w nw))) + (if pull-p + (pull-window nw) + (frame-raise-window group (window-frame nw) nw)) + (message "No other window.")))) + +(defcommand pull-window-by-number (n &optional (group (current-group))) + ((:window-number "Pull: ")) + "Pull window N from another frame into the current frame and focus it." + (let ((win (find n (group-windows group) :key 'window-number :test '=))) + (when win + (pull-window win)))) + +(defcommand-alias pull pull-window-by-number) + +;;; Window deletion + +(defcommand delete-current-window () () + "Delete the current window. This is a request sent to the window. The +window's client may decide not to grant the request or may not be able +to if it is unresponsive." + (let ((group (current-group))) + (when (group-current-window group) + (delete-window (group-current-window group))))) + +(defcommand-alias delete delete-current-window) + +(defcommand kill-current-window () () +"`Tell X to disconnect the client that owns the current window. if address@hidden didn't work, try this." + (let ((group (current-group))) + (when (group-current-window group) + (xwin-kill (window-xwin (group-current-window group)))))) + +(defcommand-alias kill kill-current-window) + +;;; Window listing + +(defun echo-windows (group fmt &optional (windows (group-windows group))) + "Print a list of the windows to the screen." + (let* ((wins (sort1 windows '< :key 'window-number)) + (highlight (position (group-current-window group) wins)) + (names (mapcar (lambda (w) + (format-expand *window-formatters* fmt w)) wins))) + (if (null wins) + (echo-string (group-screen group) "No Managed Windows") + (echo-string-list (group-screen group) names highlight)))) + +(defcommand windows (&optional (fmt *window-format*)) (:rest) + "Display a list of managed windows. The optional argument @var{fmt} can +be used to override the default window formatting." + (echo-windows (current-group) fmt)) + +(defcommand echo-frame-windows (&optional (fmt *window-format*)) (:rest) + (echo-windows (current-group) fmt (frame-windows (current-group) + (tile-group-current-frame (current-group))))) + +(defcommand-alias frame-windows echo-frame-windows) + +(defcommand title (title) ((:rest "Set window's title to: ")) + (if (current-window) + (setf (window-user-title (current-window)) title) + (message "No Focused Window"))) + +(defcommand renumber (nt &optional (group (current-group))) ((:number "Number: ")) + "Change the current window's number to the specified number. If another window +is using the number, then the windows swap numbers. Defaults to current group." + (let ((nf (window-number (group-current-window group))) + (win (find-if #'(lambda (win) + (= (window-number win) nt)) + (group-windows group)))) + ;; Is it already taken? + (if win + (progn + ;; swap the window numbers + (setf (window-number win) nf) + (setf (window-number (group-current-window group)) nt)) + ;; Just give the window the number + (setf (window-number (group-current-window group)) nt)))) + +(defcommand-alias number renumber) + +;;; Window selection + +(defun select-window (group query) + "Read input from the user and go to the selected window." + (let (match) + (labels ((match (win) + (let* ((wname (window-name win)) + (end (min (length wname) (length query)))) + (string-equal wname query :end1 end :end2 end)))) + (unless (null query) + (setf match (find-if #'match (group-windows group)))) + (when match + (frame-raise-window group (window-frame match) match))))) + +(defcommand select (win) ((:window-name "Select: ")) + "Switch to the first window that starts with @var{win}." + (select-window (current-group) win)) + +(defun select-window-number (group num) + (labels ((match (win) + (= (window-number win) num))) + (let ((win (find-if #'match (group-windows group)))) + (when win + (frame-raise-window group (window-frame win) win))))) + +(defcommand windowlist (&optional (fmt *window-format*)) (:rest) +"Allow the user to Select a window from the list of windows and focus +the selected window. For information of menu bindings address@hidden The optional argument @var{fmt} can be specified to +override the default window formatting." + (if (null (group-windows (current-group))) + (message "No Managed Windows") + (let* ((group (current-group)) + (window (second (select-from-menu + (current-screen) + (mapcar (lambda (w) + (list (format-expand *window-formatters* fmt w) w)) + (sort-windows group)))))) + + (if window + (frame-raise-window group (window-frame window) window) + (throw 'error :abort))))) + +;;; The Other Window + +(defun other-window (group) + (let* ((wins (group-windows group)) + ;; the frame could be empty + (win (if (group-current-window group) + (second wins) + (first wins)))) + (if win + (frame-raise-window group (window-frame win) win) + (echo-string (group-screen group) "No other window.")))) + +(defcommand other () () + "Switch to the window last focused." + (other-window (current-group))) + +(defun other-window-in-frame (group) + (let* ((f (tile-group-current-frame group)) + (wins (frame-windows group f)) + (win (if (frame-window f) + (second wins) + (first wins)))) + (if win + (frame-raise-window group (window-frame win) win) + (echo-string (group-screen group) "No other window.")))) + +;;; Hidden windows + +(defun other-hidden-window (group) + "Return the last window that was accessed and that is hidden." + (let ((wins (remove-if (lambda (w) (eq (frame-window (window-frame w)) w)) (group-windows group)))) + (first wins))) + +(defun pull-other-hidden-window (group) + "pull the last accessed hidden window from any frame into the +current frame and raise it." + (let ((win (other-hidden-window group))) + (if win + (pull-window win) + (echo-string (group-screen group) "No other window.")))) + +(defcommand pull-hidden-next () () +"Pull the next hidden window into the current frame." + (let ((group (current-group))) + (focus-forward group (sort-windows group) t (lambda (w) (not (eq (frame-window (window-frame w)) w)))))) + +(defcommand pull-hidden-previous () () +"Pull the next hidden window into the current frame." + (let ((group (current-group))) + (focus-forward group (nreverse (sort-windows group)) t (lambda (w) (not (eq (frame-window (window-frame w)) w)))))) + +(defcommand pull-hidden-other () () +"Pull the last focused, hidden window into the current frame." + (let ((group (current-group))) + (pull-other-hidden-window group))) + +;;; Window marks + +(defcommand mark () () +"Toggle the current window's mark." + (let ((win (current-window))) + (when win + (setf (window-marked win) (not (window-marked win))) + (message (if (window-marked win) + "Marked!" + "Unmarked!"))))) + +(defcommand clear-marks () () +"Clear all marks in the current group." + (let ((group (current-group))) + (clear-window-marks group))) + +(defcommand pull-marked () () +"Pull all marked windows into the current frame and clear the marks." + (let ((group (current-group))) + (dolist (i (marked-windows group)) + (pull-window i)) + (clear-window-marks group))) + +;;; window placement commands + +(defun make-rule-for-window (window &optional lock title) + "Guess at a placement rule for WINDOW and add it to the current set." + (let* ((group (window-group window)) + (group-name (group-name group)) + (frame-number (frame-number (window-frame window))) + (role (window-role window))) + (push (list group-name frame-number t lock + :class (window-class window) + :instance (window-res window) + :title (and title (window-name window)) + :role (and (not (equal role "")) role)) + *window-placement-rules*))) + +(defcommand remember (lock title) + ((:y-or-n "Lock to group? ") + (:y-or-n "Use title? ")) + "Make a generic placement rule for the current window. Might be too specific/not specific enough!" + (make-rule-for-window (current-window) (first lock) (first title))) + +(defcommand forget () () + (let* ((window (current-window)) + (match (rule-matching-window window))) + (if match + (progn + (setf *window-placement-rules* (delete match *window-placement-rules*)) + (message "Rule forgotten")) + (message "No matching rule")))) + +(defun dump-window-placement-rules (file) + "Dump *window-placement-rules* to FILE." + (dump-to-file *window-placement-rules* file)) + +(defcommand dump-rules (file) ((:rest "Filename: ")) + (dump-window-placement-rules file)) + +(defun restore-window-placement-rules (file) + "Restore *window-placement-rules* from FILE." + (setf *window-placement-rules* (read-dump-from-file file))) + +(defcommand restore-rules (file) ((:rest "Filename: ")) + (restore-window-placement-rules file)) + +;;; window.lisp ends here -- 1.5.3.7