[clfswm-cvs] [clfswm-git]CLFSWM - A(nother) Common Lisp FullScreen Window Manager branch test updated. R-1106-41-g08028be
Philippe Brochard
pbrochard at common-lisp.net
Tue May 15 22:52:48 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 08028be65be08032cdf474bfa8a4fbbbdaf9715e (commit)
from aef0e417c99264a29d4b53ad71765598204cbe13 (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 08028be65be08032cdf474bfa8a4fbbbdaf9715e
Author: Philippe Brochard <pbrochard at common-lisp.net>
Date: Wed May 16 00:52:44 2012 +0200
src/menu-def.lisp: New root menu.
diff --git a/ChangeLog b/ChangeLog
index 119b1cd..127e19c 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,7 @@
+2012-05-16 Philippe Brochard <pbrochard at common-lisp.net>
+
+ * src/menu-def.lisp: New root menu.
+
2012-05-15 Philippe Brochard <pbrochard at common-lisp.net>
* src/clfswm-circulate-mode.lisp (rotate-root-geometry-next)
diff --git a/src/bindings-second-mode.lisp b/src/bindings-second-mode.lisp
index fb98005..ec9d293 100644
--- a/src/bindings-second-mode.lisp
+++ b/src/bindings-second-mode.lisp
@@ -52,16 +52,16 @@
(open-menu (find-menu 'action-by-number-menu)))
(defun open-frame-pack-menu ()
- "Open the frame pack menu"
- (open-menu (find-menu 'frame-pack-menu)))
+ "Open the frame pack/fill/resize menu"
+ (open-menu (find-menu 'frame-movement-menu)))
-(defun open-frame-fill-menu ()
- "Open the frame fill menu"
- (open-menu (find-menu 'frame-fill-menu)))
+(defun open-root-menu ()
+ "Open the root menu"
+ (open-menu (find-menu 'root-menu) nil t))
-(defun open-frame-resize-menu ()
- "Open the frame resize menu"
- (open-menu (find-menu 'frame-resize-menu)))
+(defun open-child-menu ()
+ "Open the child menu"
+ (open-menu (find-menu 'child-menu)))
(defun tile-current-frame ()
"Tile the current frame"
@@ -97,8 +97,8 @@
(define-second-key ("n") 'open-action-by-name-menu)
(define-second-key ("u") 'open-action-by-number-menu)
(define-second-key ("p") 'open-frame-pack-menu)
- (define-second-key ("l") 'open-frame-fill-menu)
- (define-second-key ("r") 'open-frame-resize-menu)
+ (define-second-key ("r") 'open-root-menu)
+ (define-second-key ("c") 'open-child-menu)
(define-second-key ("x") 'update-layout-managed-children-position)
(define-second-key ("g" :control) 'stop-all-pending-actions)
(define-second-key ("q") 'sm-delete-focus-window)
@@ -108,7 +108,7 @@
(define-second-key ("exclam") 'run-program-from-query-string)
(define-second-key ("Return") 'leave-second-mode)
(define-second-key ("Escape") 'leave-second-mode)
- (define-second-key ("t") 'tile-current-frame)
+ (define-second-key ("t" :shift) 'tile-current-frame)
(define-second-key ("Home" :mod-1 :control :shift) 'exit-clfswm)
(define-second-key ("Right" :mod-1) 'select-next-brother)
(define-second-key ("Left" :mod-1) 'select-previous-brother)
@@ -167,7 +167,7 @@
(define-second-key ("v" :control :shift) 'paste-selection-no-clear)
(define-second-key ("Delete" :control) 'remove-current-child)
(define-second-key ("Delete") 'delete-current-child)
- (define-shell ("c") b-start-xterm "start an xterm" "cd $HOME && exec xterm")
+ (define-shell ("t") b-start-xterm "start an xterm" "cd $HOME && exec xterm")
(define-shell ("e") b-start-emacs "start emacs" "cd $HOME && exec emacs")
(define-shell ("e" :control) b-start-emacsremote
"start an emacs for another user"
diff --git a/src/clfswm-internal.lisp b/src/clfswm-internal.lisp
index 4e4199e..26bf269 100644
--- a/src/clfswm-internal.lisp
+++ b/src/clfswm-internal.lisp
@@ -642,21 +642,26 @@
(root-child (find-root (current-child))))
(defun rotate-root-geometry ()
- (let* ((current (first root-list))
- (orig-x (root-x current))
- (orig-y (root-y current))
- (orig-w (root-w current))
- (orig-h (root-h current)))
- (dolist (root (rest root-list))
- (setf (root-x current) (root-x root)
- (root-y current) (root-y root)
- (root-w current) (root-w root)
- (root-h current) (root-h root)
- current root))
- (setf (root-x current) orig-x
- (root-y current) orig-y
- (root-w current) orig-w
- (root-h current) orig-h)))
+ (let* ((first (first root-list))
+ (len (length root-list))
+ (orig-x (root-x first))
+ (orig-y (root-y first))
+ (orig-w (root-w first))
+ (orig-h (root-h first)))
+ (dotimes (i (1- len))
+ (let ((root-1 (nth i root-list))
+ (root-2 (nth (1+ i) root-list)))
+ (rotatef (root-x root-1) (root-x root-2))
+ (rotatef (root-y root-1) (root-y root-2))
+ (rotatef (root-w root-1) (root-w root-2))
+ (rotatef (root-h root-1) (root-h root-2))))
+ (let ((root-1 (nth (1- len) root-list)))
+ (setf (root-x root-1) orig-x)
+ (setf (root-y root-1) orig-y)
+ (setf (root-w root-1) orig-w)
+ (setf (root-h root-1) orig-h))))
+
+
(defun anti-rotate-root-geometry ()
(setf root-list (nreverse root-list))
diff --git a/src/clfswm-menu.lisp b/src/clfswm-menu.lisp
index d2dc6e7..a629eed 100644
--- a/src/clfswm-menu.lisp
+++ b/src/clfswm-menu.lisp
@@ -137,33 +137,37 @@
(funcall action)))))
-(defun open-menu (&optional (menu *menu*) (parent nil))
+(defun open-menu (&optional (menu *menu*) (parent nil) (restart-menu nil))
"Open the main menu"
- (let ((action nil)
- (old-info-keys (copy-hash-table *info-keys*)))
- (labels ((populate-menu ()
- (let ((info-list nil))
- (dolist (item (menu-item menu))
- (let ((value (menu-item-value item)))
- (push (typecase value
- (menu (list (list (format nil "~A" (menu-item-key item)) *menu-color-menu-key*)
- (list (format nil ": < ~A >" (menu-doc value)) *menu-color-submenu*)))
- (string (list (list (format nil "~A" (menu-item-value item)) *menu-color-comment*)))
- (t (list (list (format nil "~A" (menu-item-key item)) *menu-color-key*)
- (format nil ": ~A" (documentation value 'function)))))
- info-list)
- (when (menu-item-key item)
- (define-info-key-fun (list (menu-item-key item))
- (lambda (&optional args)
- (declare (ignore args))
- (setf action value)
- (leave-info-mode nil))))))
- (nreverse info-list))))
- (let ((selected-item (info-mode (populate-menu))))
- (setf *info-keys* old-info-keys)
- (when selected-item
- (awhen (nth selected-item (menu-item menu))
- (setf action (menu-item-value it)))))
- (open-menu-do-action action menu parent))))
+ (when menu
+ (let ((action nil)
+ (old-info-keys (copy-hash-table *info-keys*)))
+ (labels ((populate-menu ()
+ (let ((info-list nil))
+ (dolist (item (menu-item menu))
+ (let ((value (menu-item-value item)))
+ (push (typecase value
+ (menu (list (list (format nil "~A" (menu-item-key item)) *menu-color-menu-key*)
+ (list (format nil ": < ~A >" (menu-doc value)) *menu-color-submenu*)))
+ (string (list (list (format nil "~A" (menu-item-value item)) *menu-color-comment*)))
+ (t (list (list (format nil "~A" (menu-item-key item)) *menu-color-key*)
+ (format nil ": ~A" (documentation value 'function)))))
+ info-list)
+ (when (menu-item-key item)
+ (define-info-key-fun (list (menu-item-key item))
+ (lambda (&optional args)
+ (declare (ignore args))
+ (setf action value)
+ (leave-info-mode nil))))))
+ (nreverse info-list))))
+ (let ((selected-item (info-mode (populate-menu))))
+ (setf *info-keys* old-info-keys)
+ (when selected-item
+ (awhen (nth selected-item (menu-item menu))
+ (setf action (menu-item-value it)))))
+ (let ((*in-second-mode* (if restart-menu nil *in-second-mode*)))
+ (open-menu-do-action action menu parent))
+ (when (and action restart-menu)
+ (open-menu menu parent restart-menu))))))
diff --git a/src/clfswm-pack.lisp b/src/clfswm-pack.lisp
index 7a075a9..00fffa6 100644
--- a/src/clfswm-pack.lisp
+++ b/src/clfswm-pack.lisp
@@ -38,47 +38,51 @@
(defun find-edge-up (current-frame parent)
(let ((y-found 0))
- (dolist (frame (frame-child parent))
- (when (and (frame-p frame)
- (not (equal frame current-frame))
- (<= (frame-y2 frame) (frame-y current-frame))
- (>= (frame-x2 frame) (frame-x current-frame))
- (<= (frame-x frame) (frame-x2 current-frame)))
- (setf y-found (max y-found (frame-y2 frame)))))
+ (when parent
+ (dolist (frame (frame-child parent))
+ (when (and (frame-p frame)
+ (not (equal frame current-frame))
+ (<= (frame-y2 frame) (frame-y current-frame))
+ (>= (frame-x2 frame) (frame-x current-frame))
+ (<= (frame-x frame) (frame-x2 current-frame)))
+ (setf y-found (max y-found (frame-y2 frame))))))
y-found))
(defun find-edge-down (current-frame parent)
(let ((y-found 1))
- (dolist (frame (frame-child parent))
- (when (and (frame-p frame)
- (not (equal frame current-frame))
- (>= (frame-y frame) (frame-y2 current-frame))
- (>= (frame-x2 frame) (frame-x current-frame))
- (<= (frame-x frame) (frame-x2 current-frame)))
- (setf y-found (min y-found (frame-y frame)))))
+ (when parent
+ (dolist (frame (frame-child parent))
+ (when (and (frame-p frame)
+ (not (equal frame current-frame))
+ (>= (frame-y frame) (frame-y2 current-frame))
+ (>= (frame-x2 frame) (frame-x current-frame))
+ (<= (frame-x frame) (frame-x2 current-frame)))
+ (setf y-found (min y-found (frame-y frame))))))
y-found))
(defun find-edge-right (current-frame parent)
(let ((x-found 1))
- (dolist (frame (frame-child parent))
- (when (and (frame-p frame)
- (not (equal frame current-frame))
- (>= (frame-x frame) (frame-x2 current-frame))
- (>= (frame-y2 frame) (frame-y current-frame))
- (<= (frame-y frame) (frame-y2 current-frame)))
- (setf x-found (min x-found (frame-x frame)))))
+ (when parent
+ (dolist (frame (frame-child parent))
+ (when (and (frame-p frame)
+ (not (equal frame current-frame))
+ (>= (frame-x frame) (frame-x2 current-frame))
+ (>= (frame-y2 frame) (frame-y current-frame))
+ (<= (frame-y frame) (frame-y2 current-frame)))
+ (setf x-found (min x-found (frame-x frame))))))
x-found))
(defun find-edge-left (current-frame parent)
(let ((x-found 0))
- (dolist (frame (frame-child parent))
- (when (and (frame-p frame)
- (not (equal frame current-frame))
- (<= (frame-x2 frame) (frame-x current-frame))
- (>= (frame-y2 frame) (frame-y current-frame))
- (<= (frame-y frame) (frame-y2 current-frame)))
- (setf x-found (max x-found (frame-x2 frame)))))
+ (when parent
+ (dolist (frame (frame-child parent))
+ (when (and (frame-p frame)
+ (not (equal frame current-frame))
+ (<= (frame-x2 frame) (frame-x current-frame))
+ (>= (frame-y2 frame) (frame-y current-frame))
+ (<= (frame-y frame) (frame-y2 current-frame)))
+ (setf x-found (max x-found (frame-x2 frame))))))
x-found))
diff --git a/src/menu-def.lisp b/src/menu-def.lisp
index f5f1f6e..43799be 100644
--- a/src/menu-def.lisp
+++ b/src/menu-def.lisp
@@ -50,6 +50,7 @@
(add-sub-menu 'main "F1" 'help-menu "Help menu")
(add-sub-menu 'main "d" 'standard-menu "Standard menu")
(add-sub-menu 'main "c" 'child-menu "Child menu")
+(add-sub-menu 'main "r" 'root-menu "Root menu")
(add-sub-menu 'main "f" 'frame-menu "Frame menu")
(add-sub-menu 'main "w" 'window-menu "Window menu")
(add-sub-menu 'main "s" 'selection-menu "Selection menu")
@@ -89,6 +90,11 @@
(add-menu-key 'child-menu "Page_Up" 'frame-lower-child)
(add-menu-key 'child-menu "Page_Down" 'frame-raise-child)
+(add-menu-key 'root-menu "n" 'select-next-root)
+(add-menu-key 'root-menu "p" 'select-previous-root)
+(add-menu-key 'root-menu "g" 'rotate-root-geometry-next)
+(add-menu-key 'root-menu "f" 'rotate-root-geometry-previous)
+(add-menu-key 'root-menu "m" 'exchange-root-geometry-with-mouse)
(add-sub-menu 'frame-menu "a" 'frame-adding-menu "Adding frame menu")
-----------------------------------------------------------------------
Summary of changes:
ChangeLog | 4 +++
src/bindings-second-mode.lisp | 24 ++++++++--------
src/clfswm-internal.lisp | 35 +++++++++++++----------
src/clfswm-menu.lisp | 58 +++++++++++++++++++++------------------
src/clfswm-pack.lisp | 60 ++++++++++++++++++++++-------------------
src/menu-def.lisp | 6 ++++
6 files changed, 105 insertions(+), 82 deletions(-)
hooks/post-receive
--
CLFSWM - A(nother) Common Lisp FullScreen Window Manager
More information about the clfswm-cvs
mailing list