[clfswm-cvs] [clfswm-git]CLFSWM - A(nother) Common Lisp FullScreen Window Manager branch master updated. R-1212-6-g5b30659
Philippe Brochard
pbrochard at common-lisp.net
Wed Dec 26 13:13:00 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, master has been updated
via 5b30659681be4b47f51d23638e8961d81fe43b76 (commit)
from 1ebf6e9d43fc995dfc0392c5dd91d4c23335c717 (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 5b30659681be4b47f51d23638e8961d81fe43b76
Author: Philippe Brochard <pbrochard at common-lisp.net>
Date: Wed Dec 26 14:12:54 2012 +0100
Use children position information from show-all-children instead of recalculating them each time
diff --git a/src/clfswm-internal.lisp b/src/clfswm-internal.lisp
index e0be9f6..e543dc0 100644
--- a/src/clfswm-internal.lisp
+++ b/src/clfswm-internal.lisp
@@ -126,6 +126,7 @@
(x-drawable-x window) (x-drawable-y window)
(x-drawable-width window) (x-drawable-height window))))
+
(defgeneric in-child (child x y))
(defmethod in-child ((child frame) x y)
@@ -1193,78 +1194,82 @@ XINERAMA version 1.1 opcode: 150
-
-(defun show-all-children (&optional (from-root-frame nil))
- "Show all children and hide those not in a root frame"
- (declare (ignore from-root-frame))
- (let ((geometry-change nil)
- (displayed-child nil)
- (hidden-child nil))
- (labels ((in-displayed-list (child)
- (member child displayed-child :test (lambda (c rect)
- (child-equal-p c (child-rect-child rect)))))
-
- (add-in-hidden-list (child)
- (pushnew child hidden-child :test #'child-equal-p))
-
- (set-geometry (child parent in-current-root child-current-root-p)
- (if (or in-current-root child-current-root-p)
+(let ((displayed-child nil))
+ (defun get-displayed-child ()
+ displayed-child)
+
+ (defun show-all-children (&optional (from-root-frame nil))
+ "Show all children and hide those not in a root frame"
+ (declare (ignore from-root-frame))
+ (let ((geometry-change nil)
+ (hidden-child nil))
+ (labels ((in-displayed-list (child)
+ (member child displayed-child :test (lambda (c rect)
+ (child-equal-p c (child-rect-child rect)))))
+
+ (add-in-hidden-list (child)
+ (pushnew child hidden-child :test #'child-equal-p))
+
+ (set-geometry (child parent in-current-root child-current-root-p)
+ (if (or in-current-root child-current-root-p)
+ (when (frame-p child)
+ (adapt-frame-to-parent child (if child-current-root-p nil parent)))
+ (add-in-hidden-list child)))
+
+ (recurse-on-frame-child (child in-current-root child-current-root-p selected-p)
+ (let ((selected-child (frame-selected-child child)))
+ (dolist (sub-child (frame-child child))
+ (rec sub-child child
+ (and selected-p (child-equal-p sub-child selected-child))
+ (or in-current-root child-current-root-p)))))
+
+ (hidden-child-p (rect)
+ (dolist (r displayed-child)
+ (when (and (rect-hidden-p r rect)
+ (or (not (xlib:window-p (child-rect-child r)))
+ (eq (window-type (child-rect-child r)) :normal)))
+ (return t))))
+
+ (select-and-display (child parent selected-p)
+ (multiple-value-bind (nx ny nw nh)
+ (get-parent-layout child parent)
+ (let ((rect (make-child-rect :child child :parent parent
+ :selected-p selected-p
+ :x nx :y ny :w nw :h nh)))
+ (if (and *show-hide-policy* (hidden-child-p rect))
+ (add-in-hidden-list child)
+ (push rect displayed-child)))))
+
+ (display-displayed-child ()
+ (let ((previous nil))
+ (setf displayed-child (nreverse displayed-child))
+ (dolist (rect displayed-child)
+ (when (adapt-child-to-rect rect)
+ (setf geometry-change t))
+ (select-child (child-rect-child rect) (child-rect-selected-p rect))
+ (show-child (child-rect-child rect)
+ (child-rect-parent rect)
+ previous)
+ (setf previous (child-rect-child rect)))))
+
+ (rec (child parent selected-p in-current-root)
+ (let ((child-current-root-p (child-root-p child)))
+ (unless (in-displayed-list child)
+ (set-geometry child parent in-current-root child-current-root-p))
(when (frame-p child)
- (adapt-frame-to-parent child (if child-current-root-p nil parent)))
- (add-in-hidden-list child)))
-
- (recurse-on-frame-child (child in-current-root child-current-root-p selected-p)
- (let ((selected-child (frame-selected-child child)))
- (dolist (sub-child (frame-child child))
- (rec sub-child child
- (and selected-p (child-equal-p sub-child selected-child))
- (or in-current-root child-current-root-p)))))
-
- (hidden-child-p (rect)
- (dolist (r displayed-child)
- (when (and (rect-hidden-p r rect)
- (or (not (xlib:window-p (child-rect-child r)))
- (eq (window-type (child-rect-child r)) :normal)))
- (return t))))
-
- (select-and-display (child parent selected-p)
- (multiple-value-bind (nx ny nw nh)
- (get-parent-layout child parent)
- (let ((rect (make-child-rect :child child :parent parent
- :selected-p selected-p
- :x nx :y ny :w nw :h nh)))
- (if (and *show-hide-policy* (hidden-child-p rect))
- (add-in-hidden-list child)
- (push rect displayed-child)))))
-
- (display-displayed-child ()
- (let ((previous nil))
- (dolist (rect (nreverse displayed-child))
- (when (adapt-child-to-rect rect)
- (setf geometry-change t))
- (select-child (child-rect-child rect) (child-rect-selected-p rect))
- (show-child (child-rect-child rect)
- (child-rect-parent rect)
- previous)
- (setf previous (child-rect-child rect)))))
-
- (rec (child parent selected-p in-current-root)
- (let ((child-current-root-p (child-root-p child)))
- (unless (in-displayed-list child)
- (set-geometry child parent in-current-root child-current-root-p))
- (when (frame-p child)
- (recurse-on-frame-child child in-current-root child-current-root-p selected-p))
- (when (and (or in-current-root child-current-root-p)
- (not (in-displayed-list child)))
- (select-and-display child parent selected-p)))))
-
- (rec *root-frame* nil t (child-root-p *root-frame*))
- (display-displayed-child)
- (dolist (child hidden-child)
- (hide-child child))
- (set-focus-to-current-child)
- (xlib:display-finish-output *display*)
- geometry-change)))
+ (recurse-on-frame-child child in-current-root child-current-root-p selected-p))
+ (when (and (or in-current-root child-current-root-p)
+ (not (in-displayed-list child)))
+ (select-and-display child parent selected-p)))))
+
+ (setf displayed-child nil)
+ (rec *root-frame* nil t (child-root-p *root-frame*))
+ (display-displayed-child)
+ (dolist (child hidden-child)
+ (hide-child child))
+ (set-focus-to-current-child)
+ (xlib:display-finish-output *display*)
+ geometry-change))))
diff --git a/src/clfswm-util.lisp b/src/clfswm-util.lisp
index 73834b8..8bc8b62 100644
--- a/src/clfswm-util.lisp
+++ b/src/clfswm-util.lisp
@@ -354,22 +354,6 @@ Write (defparameter *contrib-dir* \"/usr/local/lib/clfswm/\") in ~A.~%"
-(defun find-window-under-mouse (x y)
- "Return the child window under the mouse"
- (let ((win *root*))
- (with-all-root-child (root)
- (with-all-windows-frames-and-parent (root child parent)
- (when (and (or (managed-window-p child parent) (child-equal-p parent (current-child)))
- (not (window-hidden-p child))
- (in-window child x y))
- (setf win child))
- (when (in-frame child x y)
- (setf win (frame-window child)))))
- win))
-
-
-
-
(defun find-child-under-mouse-in-never-managed-windows (x y)
"Return the child under mouse from never managed windows"
(let ((ret nil))
@@ -381,30 +365,20 @@ Write (defparameter *contrib-dir* \"/usr/local/lib/clfswm/\") in ~A.~%"
(setf ret win)))))
ret))
+(defun find-child-under-mouse-in-child-tree (x y)
+ (dolist (child-rect (get-displayed-child))
+ (when (in-rect x y (child-rect-x child-rect) (child-rect-y child-rect)
+ (child-rect-w child-rect) (child-rect-h child-rect))
+ (return-from find-child-under-mouse-in-child-tree (child-rect-child child-rect)))))
-(defun find-child-under-mouse-in-child-tree (x y &optional first-foundp)
- "Return the child under the mouse"
- (let ((ret nil))
- (with-all-root-child (root)
- (with-all-windows-frames (root child)
- (when (and (not (window-hidden-p child))
- (in-window child x y))
- (if first-foundp
- (return-from find-child-under-mouse-in-child-tree child)
- (setf ret child)))
- (when (in-frame child x y)
- (if first-foundp
- (return-from find-child-under-mouse-in-child-tree child)
- (setf ret child)))))
- ret))
-
-(defun find-child-under-mouse (x y &optional first-foundp also-never-managed)
+(defun find-child-under-mouse (x y &optional also-never-managed)
"Return the child under the mouse"
(or (and also-never-managed
(find-child-under-mouse-in-never-managed-windows x y))
- (find-child-under-mouse-in-child-tree x y first-foundp)))
+ (find-child-under-mouse-in-child-tree x y)))
+
@@ -593,32 +567,32 @@ Write (defparameter *contrib-dir* \"/usr/local/lib/clfswm/\") in ~A.~%"
"Eval a lisp form from the query input"
(let ((form (query-string (format nil "Eval Lisp <~A> " (package-name *package*))
"" all-symbols))
- (result nil))
- (when (and form (not (equal form "")))
- (let ((printed-result
- (with-output-to-string (*standard-output*)
- (setf result (handler-case
- (loop for i in (multiple-value-list
- (eval (read-from-string form)))
- collect (format nil "~S" i))
- (error (condition)
- (format nil "~A" condition)))))))
- (let ((ret (info-mode (expand-newline (append (ensure-list (format nil "> ~A" form))
- (ensure-list printed-result)
- (ensure-list result)))
- :width (- (xlib:screen-width *screen*) 2))))
- (when (or (search "defparameter" form :test #'string-equal)
- (search "defvar" form :test #'string-equal))
- (let ((elem (split-string form)))
- (pushnew (string-downcase (if (string= (first elem) "(") (third elem) (second elem)))
- all-symbols :test #'string=)))
- (when (search "in-package" form :test #'string-equal)
- (let ((*notify-window-placement* 'middle-middle-root-placement))
- (open-notify-window '("Collecting all symbols for Lisp REPL completion."))
- (setf all-symbols (collect-all-symbols))
- (close-notify-window)))
- (when ret
- (eval-from-query-string))))))))
+ (result nil))
+ (when (and form (not (equal form "")))
+ (let ((printed-result
+ (with-output-to-string (*standard-output*)
+ (setf result (handler-case
+ (loop for i in (multiple-value-list
+ (eval (read-from-string form)))
+ collect (format nil "~S" i))
+ (error (condition)
+ (format nil "~A" condition)))))))
+ (let ((ret (info-mode (expand-newline (append (ensure-list (format nil "> ~A" form))
+ (ensure-list printed-result)
+ (ensure-list result)))
+ :width (- (xlib:screen-width *screen*) 2))))
+ (when (or (search "defparameter" form :test #'string-equal)
+ (search "defvar" form :test #'string-equal))
+ (let ((elem (split-string form)))
+ (pushnew (string-downcase (if (string= (first elem) "(") (third elem) (second elem)))
+ all-symbols :test #'string=)))
+ (when (search "in-package" form :test #'string-equal)
+ (let ((*notify-window-placement* 'middle-middle-root-placement))
+ (open-notify-window '("Collecting all symbols for Lisp REPL completion."))
+ (setf all-symbols (collect-all-symbols))
+ (close-notify-window)))
+ (when ret
+ (eval-from-query-string))))))))
@@ -891,7 +865,7 @@ For window: set current child to window or its parent according to window-parent
(funcall (cond ((eql mouse-fn #'move-frame) #'move-window)
((eql mouse-fn #'resize-frame) #'resize-window))
child root-x root-y)))
- (let ((child (find-child-under-mouse root-x root-y nil t)))
+ (let ((child (find-child-under-mouse root-x root-y t)))
(multiple-value-bind (never-managed raise-fun)
(never-managed-window-p child)
(if (and (xlib:window-p child) never-managed raise-fun)
@@ -1214,11 +1188,11 @@ For window: set current child to window or its parent according to window-parent
(with-current-window
(let ((parent (find-parent-frame window)))
(setf (x-drawable-x window) (truncate (+ (frame-rx parent)
- (/ (- (frame-rw parent)
- (x-drawable-width window)) 2)))
+ (/ (- (frame-rw parent)
+ (x-drawable-width window)) 2)))
(x-drawable-y window) (truncate (+ (frame-ry parent)
- (/ (- (frame-rh parent)
- (x-drawable-height window)) 2))))
+ (/ (- (frame-rh parent)
+ (x-drawable-height window)) 2))))
(xlib:display-finish-output *display*)))
(leave-second-mode))
@@ -1238,7 +1212,7 @@ For window: set current child to window or its parent according to window-parent
(defun set-current-window-transparency ()
"Set the current window transparency"
(with-current-window
- (ask-child-transparency "window" window))
+ (ask-child-transparency "window" window))
(leave-second-mode))
@@ -1421,7 +1395,7 @@ For window: set current child to window or its parent according to window-parent
(defun current-frame-set-sloppy-select-policy ()
"Set a sloppy select policy for the current frame."
- (set-focus-policy-generic :sloppy-select))
+ (set-focus-policy-generic :sloppy-select))
@@ -1445,7 +1419,7 @@ For window: set current child to window or its parent according to window-parent
(defun all-frames-set-sloppy-select-policy ()
"Set a sloppy select policy for all frames."
- (set-focus-policy-generic-for-all :sloppy-select))
+ (set-focus-policy-generic-for-all :sloppy-select))
@@ -1518,23 +1492,23 @@ For window: set current child to window or its parent according to window-parent
(loop for line = (ignore-errors (read-line stream nil nil))
while line
do
- (cond ((first-position "Name=" line) (setf name (um-extract-value line)))
- ((first-position "Exec=" line) (setf exec (um-extract-value line)))
- ((first-position "Categories=" line) (setf categories (um-extract-value line)))
- ((first-position "Comment=" line) (setf comment (um-extract-value line))))
- (when (and name exec categories)
- (let* ((sub-menu (um-find-submenu menu (split-string categories #\;)))
- (fun-name (intern name :clfswm)))
- (setf (symbol-function fun-name) (let ((do-exec exec))
- (lambda ()
- (do-shell do-exec)
- (leave-second-mode)))
- (documentation fun-name 'function) (format nil "~A~A" name (if comment
- (format nil " - ~A" comment)
- "")))
- (dolist (m sub-menu)
- (add-menu-key (menu-name m) :next fun-name m)))
- (setf name nil exec nil categories nil comment nil)))))))
+ (cond ((first-position "Name=" line) (setf name (um-extract-value line)))
+ ((first-position "Exec=" line) (setf exec (um-extract-value line)))
+ ((first-position "Categories=" line) (setf categories (um-extract-value line)))
+ ((first-position "Comment=" line) (setf comment (um-extract-value line))))
+ (when (and name exec categories)
+ (let* ((sub-menu (um-find-submenu menu (split-string categories #\;)))
+ (fun-name (intern name :clfswm)))
+ (setf (symbol-function fun-name) (let ((do-exec exec))
+ (lambda ()
+ (do-shell do-exec)
+ (leave-second-mode)))
+ (documentation fun-name 'function) (format nil "~A~A" name (if comment
+ (format nil " - ~A" comment)
+ "")))
+ (dolist (m sub-menu)
+ (add-menu-key (menu-name m) :next fun-name m)))
+ (setf name nil exec nil categories nil comment nil)))))))
(defun update-menus (&optional (menu (make-menu :name 'main :doc "Main menu")))
@@ -1862,12 +1836,12 @@ For window: set current child to window or its parent according to window-parent
(defun key-inc-transparency ()
"Increment the current window transparency"
(with-current-window
- (incf (child-transparency window) 0.1)))
+ (incf (child-transparency window) 0.1)))
(defun key-dec-transparency ()
"Decrement the current window transparency"
(with-current-window
- (decf (child-transparency window) 0.1)))
+ (decf (child-transparency window) 0.1)))
diff --git a/src/clfswm.lisp b/src/clfswm.lisp
index 730d5d8..62cdf76 100644
--- a/src/clfswm.lisp
+++ b/src/clfswm.lisp
@@ -79,9 +79,9 @@
(when (or (child-equal-p window (current-child))
(is-in-current-child-p window))
(setf change (or change :moved))
- (show-all-children)
(focus-window window)
- (focus-all-children window (find-parent-frame window (find-current-root))))))))
+ (focus-all-children window (find-parent-frame window (find-current-root)))
+ (show-all-children))))))
(unless (eq change :resized)
;; To be ICCCM compliant, send a fake configuration notify event only when
;; the window has moved and not when it has been resized or the border width has changed.
-----------------------------------------------------------------------
Summary of changes:
src/clfswm-internal.lisp | 147 +++++++++++++++++++++++----------------------
src/clfswm-util.lisp | 148 +++++++++++++++++++---------------------------
src/clfswm.lisp | 4 +-
3 files changed, 139 insertions(+), 160 deletions(-)
hooks/post-receive
--
CLFSWM - A(nother) Common Lisp FullScreen Window Manager
More information about the clfswm-cvs
mailing list