sawfish r4270 - in trunk: . lisp/sawfish/wm lisp/sawfish/wm/commands lisp/sawfish/wm/util

[jkozicki svn gnome org]

Author: jkozicki
Date: Fri Aug 29 12:04:48 2008
New Revision: 4270
URL: http://svn.gnome.org/viewvc/sawfish?rev=4270&view=rev

Log:
Add stacking visibility patch by Timo Korvola. This fixes raise-lower window problems with xcomposite extension.




Modified:
   trunk/ChangeLog
   trunk/lisp/sawfish/wm/commands/grow-pack.jl
   trunk/lisp/sawfish/wm/stacking.jl
   trunk/lisp/sawfish/wm/util/rects.jl

Modified: trunk/lisp/sawfish/wm/commands/grow-pack.jl
==============================================================================
--- trunk/lisp/sawfish/wm/commands/grow-pack.jl	(original)
+++ trunk/lisp/sawfish/wm/commands/grow-pack.jl	Fri Aug 29 12:04:48 2008
@@ -54,6 +54,7 @@
 	  sawfish.wm.commands
 	  sawfish.wm.focus
 	  sawfish.wm.workspace
+         sawfish.wm.stacking
 	  sawfish.wm.util.stacking)
 
   (define-structure-alias grow-pack sawfish.wm.commands.grow-pack)
@@ -214,7 +215,7 @@
 			    (window-avoided-p x)
 			  (eq grow-pack-bump-other-depth 'always))))
 		  (or grow-pack-bump-obscured
-		      (not (eq (window-visibility x) 'fully-obscured)))
+                     (not (eq (stacking-visibility x) 'fully-obscured)))
 		  (or grow-pack-bump-ignored
 		      (not (window-ignored-p x)))
 		  (setq xa (window-position x)

Modified: trunk/lisp/sawfish/wm/stacking.jl
==============================================================================
--- trunk/lisp/sawfish/wm/stacking.jl	(original)
+++ trunk/lisp/sawfish/wm/stacking.jl	Fri Aug 29 12:04:48 2008
@@ -23,6 +23,8 @@
 
     (export save-stacking-order
 	    mapped-stacking-order
+            window-obscured
+            stacking-visibility
 	    raise-window
 	    lower-window
 	    stack-window-above
@@ -46,7 +48,8 @@
 	  sawfish.wm.custom
 	  sawfish.wm.session.init
 	  sawfish.wm.workspace
-	  sawfish.wm.state.transient)
+         sawfish.wm.state.transient
+          sawfish.wm.util.rects)
 
   ;; Each window will have a `depth' property--an integer, zero
   ;; represents the level of normal windows, negative for windows below
@@ -208,7 +211,54 @@
   (define (mapped-stacking-order)
     (delete-if-not window-mapped-p (stacking-order)))
 
-
+  (define (window-obscured window)
+    "Check whether WINDOW is obscured.  Return `t' if WINDOW is fully obscured
+by some other window, otherwise a list of windows partially obscuring WINDOW.
+In particular return `nil' if WINDOW is unobscured.  Note that if a list of
+partially obscuring windows is returned, taken together they may or may not
+fully obscure WINDOW."
+    (define w window)
+    (define ws (nearest-workspace-with-window w current-workspace))
+    (let loop ((stack (stacking-order))
+               (obs nil))
+         (if (null stack)               ; Should not happen
+             obs
+           (let ((w2 (car stack)))
+             (cond ((eq w2 w) obs)
+                   ((and (window-visible-p w2)
+                         (window-appears-in-workspace-p w2 ws))
+                    (case (apply rect-obscured
+                                 (rectangles-from-windows (list w w2)))
+                      ((unobscured) (loop (cdr stack) obs))
+                      ((fully-obscured) t)
+                      (t (loop (cdr stack) (cons w2 obs))))) ; Partially
+                   (t (loop (cdr stack) obs)))))))
+
+  (define (stacking-visibility window)
+    "Compute the visibility of WINDOW from the stacking order.  This should
+work even with the Composite extension, which appears to disable
+VisibilityNotify events.  Note that deciding between fully and partially
+obscured may require quite a bit of computation.  If you do not need that
+distinction, window-obscured should be faster."
+    (define (rect-list-minus rs s tail)
+      (if (null rs)
+          tail
+        (rect-list-minus (cdr rs) s
+                         (rect-minus (car rs) s tail))))
+    (let ((obs (window-obscured window)))
+      (case obs
+        ((t) 'fully-obscured)
+        ((()) 'unobscured)
+        (t
+         (do ((unobs (rectangles-from-windows (list window))
+                     (rect-list-minus unobs (car robs) nil))
+              (robs (rectangles-from-windows obs) (cdr robs)))
+             ((or (null unobs) (null robs))
+              (if (null unobs)
+                  'fully-obscured
+                'partially-obscured)))))))
+
+
 ;;; stacking functions
 
   (define (raise-window w)
@@ -340,7 +390,7 @@
   (define (raise-lower-window w)
     "If the window is at its highest possible position, then lower it to its
 lowest possible position. Otherwise raise it as far as allowed."
-    (if (or (eq (window-visibility w) 'unobscured)
+    (if (or (not (window-obscured w))
 	    (window-on-top-p w))
 	(lower-window w)
       (raise-window w)))
@@ -424,7 +474,7 @@
 	  (loop (delq lowest rest) (cons lowest out))))))
 
   (define (raise-lower-windows w order)
-    (if (or (eq (window-visibility w) 'unobscured)
+    (if (or (not (window-obscured w))
 	    (and (window-on-top-p (car order))
 		 ;; look for the group as a block.. this is a heuristic
 		 (let loop ((rest (memq (car order) (stacking-order))))

Modified: trunk/lisp/sawfish/wm/util/rects.jl
==============================================================================
--- trunk/lisp/sawfish/wm/util/rects.jl	(original)
+++ trunk/lisp/sawfish/wm/util/rects.jl	Fri Aug 29 12:04:48 2008
@@ -21,7 +21,9 @@
 
 (define-structure sawfish.wm.util.rects
 
-    (export rectangles-from-grid
+    (export rect-left rect-top rect-right rect-bottom
+            rect-obscured rect-minus
+            rectangles-from-grid
 	    rectangles-from-windows
 	    grid-from-rectangles
 	    rectangle-area
@@ -47,10 +49,75 @@
   ;; Commentary:
 
   ;; A rectangle is (LEFT TOP RIGHT BOTTOM [WEIGHT])
+  ;; The left and top edges are considered part of the rectangle,
+  ;; the right and bottom edges are not.
+
 
-
 ;;; rectangles
 
+  (define rect-left car)
+  (define rect-top cadr)
+  (define rect-right caddr)
+  (define rect-bottom cadddr)
+
+  (define (rect-obscured r by)
+    "Check whether rectangle R is wholly or partially contained in
+rectangle BY.  Return `unobscured', `partially-obscured' or `fully-obscured'."
+    (cond ((or (<= (rect-right by) (rect-left r))
+               (<= (rect-right r) (rect-left by))
+               (<= (rect-bottom by) (rect-top r))
+               (<= (rect-bottom r) (rect-top by)))
+           'unobscured)
+          ((and (<= (rect-left by) (rect-left r))
+                (<= (rect-right r) (rect-right by))
+                (<= (rect-top by) (rect-top r))
+                (<= (rect-bottom r) (rect-bottom by)))
+           'fully-obscured)
+          (t 'partially-obscured)))
+
+  (define (rect-minus r s #!optional tail)
+    "Return a list of disjoint rectangles whose union is the part of
+rectangle R not contained in rectangle S.  If TAIL is given, the
+result is prepended to it."
+    (let rminus ((r r) (result tail))
+         (cond
+          ;; Check for complete disjointness.
+          ((or (<= (rect-right s) (rect-left r))
+               (<= (rect-right r) (rect-left s))
+               (<= (rect-bottom s) (rect-top r))
+               (<= (rect-bottom r) (rect-top s)))
+           (cons r result))
+          ;; Extract a free slice from the bottom of r.
+          ((< (rect-bottom s) (rect-bottom r))
+           (rminus (list (rect-left r) (rect-top r)
+                         (rect-right r) (rect-bottom s))
+                   (cons (list (rect-left r) (rect-bottom s)
+                               (rect-right r) (rect-bottom r))
+                         result)))
+          ;; Extract a free slice from the right side of r.
+          ((< (rect-right s) (rect-right r))
+           (rminus (list (rect-left r) (rect-top r)
+                         (rect-right s) (rect-bottom r))
+                   (cons (list (rect-right s) (rect-top r)
+                               (rect-right r) (rect-bottom r))
+                         result)))
+          ;; Extract a free slice from the top of r.
+          ((> (rect-top s) (rect-top r))
+           (rminus (list (rect-left r) (rect-top s)
+                         (rect-right r) (rect-bottom r))
+                   (cons (list (rect-left r) (rect-top r)
+                               (rect-right r) (rect-top s))
+                         result)))
+          ;; Extract a free slice from the left side of r.
+          ((> (rect-left s) (rect-left r))
+           (rminus (list (rect-left s) (rect-top r)
+                         (rect-right r) (rect-bottom r))
+                   (cons (list (rect-left r) (rect-top r)
+                               (rect-left s) (rect-bottom r))
+                         result)))
+          ;; Completely covered.
+          (t result))))
+                 
   (define (rectangles-from-grid x-points y-points #!optional pred)
     "The two lists of integers X-POINTS and Y-POINTS define a rectangular
 grid. Return the complete list of rectangles formed by the