[clfswm-cvs] [clfswm-git]CLFSWM - A(nother) Common Lisp FullScreen Window Manager branch test updated. R-1106-45-g0eb8c34
Philippe Brochard
pbrochard at common-lisp.net
Fri May 18 20:35:18 UTC 2012
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "CLFSWM - A(nother) Common Lisp FullScreen Window Manager".
The branch, test has been updated
via 0eb8c3465bd8baadeeef7ca426eba63f74e35400 (commit)
from 32642a72d744e6cca2f6196c9fda1fbc7eee4d5f (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 0eb8c3465bd8baadeeef7ca426eba63f74e35400
Author: Philippe Brochard <pbrochard at common-lisp.net>
Date: Fri May 18 22:35:12 2012 +0200
src/clfswm-util.lisp (change-current-root-geometry): New efunction.
diff --git a/ChangeLog b/ChangeLog
index 2c24f0c..8e29683 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,8 @@
+2012-05-18 Philippe Brochard <pbrochard at common-lisp.net>
+
+ * src/clfswm-util.lisp (change-current-root-geometry): New
+ function.
+
2012-05-17 Philippe Brochard <pbrochard at common-lisp.net>
* src/clfswm-util.lisp (exchange-root-geometry-with-mouse): New
diff --git a/src/clfswm-query.lisp b/src/clfswm-query.lisp
index 7838bb2..9e72529 100644
--- a/src/clfswm-query.lisp
+++ b/src/clfswm-query.lisp
@@ -337,4 +337,8 @@
(defun query-number (msg &optional (default 0))
"Query a number from the query input"
- (parse-integer (or (query-string msg (format nil "~A" default)) "") :junk-allowed t))
+ (multiple-value-bind (string return)
+ (query-string msg (format nil "~A" default))
+ (if (equal return :Return)
+ (or (parse-integer (or string "") :junk-allowed t) default)
+ default)))
diff --git a/src/clfswm-util.lisp b/src/clfswm-util.lisp
index 20ad0c7..6a51df7 100644
--- a/src/clfswm-util.lisp
+++ b/src/clfswm-util.lisp
@@ -78,6 +78,98 @@
(xlib:warp-pointer *root* x y)))
+
+
+;;; Root functions utility
+(defun select-generic-root (fun restart-menu)
+ (no-focus)
+ (let* ((current-root (find-root (current-child)))
+ (parent (find-parent-frame (root-original current-root))))
+ (when parent
+ (setf (frame-child parent) (funcall fun (frame-child parent)))
+ (let ((new-root (find-root (frame-selected-child parent))))
+ (setf (current-child) (aif (root-current-child new-root)
+ it
+ (frame-selected-child parent))))))
+ (show-all-children t)
+ (if restart-menu
+ (open-menu (find-menu 'root-menu))
+ (leave-second-mode)))
+
+(defun select-next-root ()
+ "Select the next root"
+ (select-generic-root #'rotate-list nil))
+
+(defun select-previous-root ()
+ "Select the previous root"
+ (select-generic-root #'anti-rotate-list nil))
+
+
+(defun select-next-root-restart-menu ()
+ "Select the next root"
+ (select-generic-root #'rotate-list t))
+
+(defun select-previous-root-restart-menu ()
+ "Select the previous root"
+ (select-generic-root #'anti-rotate-list t))
+
+
+(defun rotate-root-geometry-generic (fun restart-menu)
+ (no-focus)
+ (funcall fun)
+ (show-all-children t)
+ (if restart-menu
+ (open-menu (find-menu 'root-menu))
+ (leave-second-mode)))
+
+
+(defun rotate-root-geometry-next ()
+ "Rotate root geometry to next root"
+ (rotate-root-geometry-generic #'rotate-root-geometry nil))
+
+(defun rotate-root-geometry-previous ()
+ "Rotate root geometry to previous root"
+ (rotate-root-geometry-generic #'anti-rotate-root-geometry nil))
+
+(defun rotate-root-geometry-next-restart-menu ()
+ "Rotate root geometry to next root"
+ (rotate-root-geometry-generic #'rotate-root-geometry t))
+
+(defun rotate-root-geometry-previous-restart-menu ()
+ "Rotate root geometry to previous root"
+ (rotate-root-geometry-generic #'anti-rotate-root-geometry t))
+
+
+
+(defun exchange-root-geometry-with-mouse ()
+ "Exchange two root geometry pointed with the mouse"
+ (open-notify-window '("Select the first root to exchange"))
+ (wait-no-key-or-button-press)
+ (wait-mouse-button-release)
+ (close-notify-window)
+ (multiple-value-bind (x1 y1) (xlib:query-pointer *root*)
+ (open-notify-window '("Select the second root to exchange"))
+ (wait-no-key-or-button-press)
+ (wait-mouse-button-release)
+ (close-notify-window)
+ (multiple-value-bind (x2 y2) (xlib:query-pointer *root*)
+ (exchange-root-geometry (find-root-by-coordinates x1 y1)
+ (find-root-by-coordinates x2 y2))))
+ (leave-second-mode))
+
+(defun change-current-root-geometry ()
+ "Change the current root geometry"
+ (let* ((root (find-root (current-child)))
+ (x (query-number "New root X position" (root-x root)))
+ (y (query-number "New root Y position" (root-y root)))
+ (w (query-number "New root width" (root-w root)))
+ (h (query-number "New root height" (root-h root))))
+ (setf (root-x root) x (root-y root) y
+ (root-w root) w (root-h root) h)
+ (show-all-children)))
+
+
+
(defun place-window-from-hints (window)
"Place a window from its hints"
(let* ((hints (xlib:wm-normal-hints window))
@@ -1723,81 +1815,3 @@ For window: set current child to window or its parent according to window-parent
"Anti rotate brother frame geometry"
(rotate-frame-geometry-generic #'reverse))
-
-;;; Root functions utility
-(defun select-generic-root (fun restart-menu)
- (no-focus)
- (let* ((current-root (find-root (current-child)))
- (parent (find-parent-frame (root-original current-root))))
- (when parent
- (setf (frame-child parent) (funcall fun (frame-child parent)))
- (let ((new-root (find-root (frame-selected-child parent))))
- (setf (current-child) (aif (root-current-child new-root)
- it
- (frame-selected-child parent))))))
- (show-all-children t)
- (if restart-menu
- (open-menu (find-menu 'root-menu))
- (leave-second-mode)))
-
-(defun select-next-root ()
- "Select the next root"
- (select-generic-root #'rotate-list nil))
-
-(defun select-previous-root ()
- "Select the previous root"
- (select-generic-root #'anti-rotate-list nil))
-
-
-(defun select-next-root-restart-menu ()
- "Select the next root"
- (select-generic-root #'rotate-list t))
-
-(defun select-previous-root-restart-menu ()
- "Select the previous root"
- (select-generic-root #'anti-rotate-list t))
-
-
-(defun rotate-root-geometry-generic (fun restart-menu)
- (no-focus)
- (funcall fun)
- (show-all-children t)
- (if restart-menu
- (open-menu (find-menu 'root-menu))
- (leave-second-mode)))
-
-
-(defun rotate-root-geometry-next ()
- "Rotate root geometry to next root"
- (rotate-root-geometry-generic #'rotate-root-geometry nil))
-
-(defun rotate-root-geometry-previous ()
- "Rotate root geometry to previous root"
- (rotate-root-geometry-generic #'anti-rotate-root-geometry nil))
-
-(defun rotate-root-geometry-next-restart-menu ()
- "Rotate root geometry to next root"
- (rotate-root-geometry-generic #'rotate-root-geometry t))
-
-(defun rotate-root-geometry-previous-restart-menu ()
- "Rotate root geometry to previous root"
- (rotate-root-geometry-generic #'anti-rotate-root-geometry t))
-
-
-
-(defun exchange-root-geometry-with-mouse ()
- "Exchange two root geometry pointed with the mouse"
- (open-notify-window '("Select the first root to exchange"))
- (wait-no-key-or-button-press)
- (wait-mouse-button-release)
- (close-notify-window)
- (multiple-value-bind (x1 y1) (xlib:query-pointer *root*)
- (open-notify-window '("Select the second root to exchange"))
- (wait-no-key-or-button-press)
- (wait-mouse-button-release)
- (close-notify-window)
- (multiple-value-bind (x2 y2) (xlib:query-pointer *root*)
- (exchange-root-geometry (find-root-by-coordinates x1 y1)
- (find-root-by-coordinates x2 y2))))
- (leave-second-mode))
-
diff --git a/src/menu-def.lisp b/src/menu-def.lisp
index fcd508b..593038b 100644
--- a/src/menu-def.lisp
+++ b/src/menu-def.lisp
@@ -95,6 +95,7 @@
(add-menu-key 'root-menu "g" 'rotate-root-geometry-next-restart-menu)
(add-menu-key 'root-menu "f" 'rotate-root-geometry-previous-restart-menu)
(add-menu-key 'root-menu "x" 'exchange-root-geometry-with-mouse)
+(add-menu-key 'root-menu "r" 'change-current-root-geometry)
(add-sub-menu 'frame-menu "a" 'frame-adding-menu "Adding frame menu")
-----------------------------------------------------------------------
Summary of changes:
ChangeLog | 5 ++
src/clfswm-query.lisp | 6 ++-
src/clfswm-util.lisp | 170 ++++++++++++++++++++++++++----------------------
src/menu-def.lisp | 1 +
4 files changed, 103 insertions(+), 79 deletions(-)
hooks/post-receive
--
CLFSWM - A(nother) Common Lisp FullScreen Window Manager
More information about the clfswm-cvs
mailing list