[sawfish/edge-actions] huge preparative commit in edge-flip, hot-spots and infinite-desktop for edge-actions

[Christopher Bratusek <chrisb src gnome org>]

commit 1ef7599b6546f7450c499fa6efd719e40aa68686
Author: Christopher Roy Bratusek <zanghar freenet de>
Date:   Tue Nov 2 18:25:59 2010 +0100

    huge preparative commit in
    edge-flip, hot-spots and infinite-desktop for edge-actions

 lisp/sawfish/wm/edge/flip.jl             |  127 ++---------------------------
 lisp/sawfish/wm/edge/hot-spots.jl        |   43 +---------
 lisp/sawfish/wm/edge/infinite-desktop.jl |   39 +--------
 3 files changed, 17 insertions(+), 192 deletions(-)
---
diff --git a/lisp/sawfish/wm/edge/flip.jl b/lisp/sawfish/wm/edge/flip.jl
index b1801c4..690ba45 100644
--- a/lisp/sawfish/wm/edge/flip.jl
+++ b/lisp/sawfish/wm/edge/flip.jl
@@ -20,8 +20,7 @@
 
 (define-structure sawfish.wm.edge.flip
 
-    (export edge-flip-enable
-	    edge-flip-enter)
+    (export edge-flip-activate)
 
     (open rep
 	  rep.system
@@ -39,39 +38,7 @@
 
   (define-structure-alias edge-flip sawfish.wm.edge.flip)
 
-  (defgroup edge-flip "Edge Flipping"
-    :group workspace
-    :require sawfish.wm.edge.flip)
-
-  (defcustom edge-flip-enabled nil
-    "Select the next desktop when the pointer hits screen edge."
-    :type boolean
-    :require sawfish.wm.edge.flip
-    :group (workspace edge-flip)
-    :after-set (lambda () (edge-flip-enable)))
-
-  (defcustom edge-flip-type 'workspace
-    "Hitting the screen edge selects the next: \\w"
-    :type (choice viewport workspace)
-    :depends edge-flip-enabled
-    :group (workspace edge-flip))
-
-  (defcustom edge-flip-only-when-moving nil
-    "Only flip when interactively moving a window."
-    :type boolean
-    :depends edge-flip-enabled
-    :group (workspace edge-flip)
-    :after-set (lambda () (edge-flip-enable)))
-
-  (defcustom edge-flip-delay 250
-    "Milliseconds to delay before edge flipping."
-    :type number
-    :depends edge-flip-enabled
-    :group (workspace edge-flip)
-    :after-set (lambda () (edge-flip-enable)))
-
   (define ef-current-edge nil)
-  (define ef-timer nil)
 
   (defvar before-edge-flip-hook '()
     "Hook called immediately before edge-flipping.")
@@ -79,57 +46,10 @@
   (defvar after-edge-flip-hook '()
     "Hook called immediately after edge-flipping.")
 
-  (define (edge-flip-enable)
-    (if (and edge-flip-enabled (not edge-flip-only-when-moving))
-	(progn
-	  (flippers-activate t)
-	  ;; XXX split all that stuff from edge-flip, so that
-	  ;; XXX HS and ID work, even if EF is disabled
-	  (unless (in-hook-p 'before-edge-lip-hook before-flip)
-	    (add-hook 'before-edge-flip-hook before-flip))
-	  (unless (in-hook-p 'after-edge-flip-hook after-flip)
-	    (add-hook 'after-edge-flip-hook after-flip))
-	  (unless (in-hook-p 'while-moving-hook edge-flip-while-moving)
-	    (add-hook 'while-moving-hook edge-flip-while-moving))
-	  (unless (in-hook-p 'enter-flipper-hook edge-flip-enter)
-	    (add-hook 'enter-flipper-hook edge-flip-enter))
-	  (unless (in-hook-p 'leave-flipper-hook edge-flip-leave)
-	    (add-hook 'leave-flipper-hook edge-flip-leave)))
-      (flippers-activate nil)
-      (if (in-hook-p 'before-edge-lip-hook before-flip)
-	(remove-hook 'before-edge-flip-hook before-flip))
-      (if (in-hook-p 'after-edge-flip-hook after-flip)
-	(remove-hook 'after-edge-flip-hook after-flip))
-      (if (in-hook-p 'while-moving-hook edge-flip-while-moving)
-	(remove-hook 'while-moving-hook edge-flip-while-moving))
-      (if (in-hook-p 'enter-flipper-hook edge-flip-enter)
-	(remove-hook 'enter-flipper-hook edge-flip-enter))
-      (if (in-hook-p 'leave-flipper-hook edge-flip-leave)
-	(remove-hook 'leave-flipper-hook edge-flip-leave))))
-
-  (define (edge-flip-enter edge)
-    (if (<= edge-flip-delay 0)
-	(edge-flip-for-edge edge)
-      (setq ef-current-edge edge)
-      (if ef-timer
-	  (set-timer ef-timer)
-	(setq ef-timer (make-timer (lambda ()
-				     (setq ef-timer nil)
-				     (edge-flip-for-edge ef-current-edge))
-				   (quotient edge-flip-delay 1000)
-				   (mod edge-flip-delay 1000))))))
-
-  (define (edge-flip-leave edge)
-    (declare (unused edge))
-    (setq ef-current-edge nil)
-    (when ef-timer
-      (delete-timer ef-timer)
-      (setq ef-timer nil)))
-
-  (define (edge-flip-for-edge edge)
+  (define (edge-flip-activate edge type)
     (let ((ptr (query-pointer t)))
-      (call-hook 'before-edge-flip-hook)
-      (if (eq edge-flip-type 'viewport)
+      (before-flip)
+      (if (eq type 'viewport)
 	  (progn
 	    (cond ((eq edge 'left)
 		   (when (move-viewport -1 0)
@@ -160,31 +80,10 @@
 		 (rplacd ptr 1)))
 	  (unless (= current-workspace orig)
 	    (warp-cursor (car ptr) (cdr ptr)))))
-      (call-hook 'after-edge-flip-hook)))
-
-  ;; this is a hack -- while the pointer's grabbed the flipper windows
-  ;; won't get enter/leave notify events (this is normally the right
-  ;; thing to do), so synthesize them ourselves while interactively
-  ;; moving windows
-  ;; XXX this probably doesn't handle the screen corners correctly
-  (define (edge-flip-synthesize)
-    (when edge-flip-enabled
-      (let ((ptr (query-pointer))
-	    edge)
-	(cond ((zerop (car ptr))
-	       (setq edge 'left))
-	      ((= (car ptr) (1- (screen-width)))
-	       (setq edge 'right))
-	      ((zerop (cdr ptr))
-	       (setq edge 'top))
-	      ((= (cdr ptr) (1- (screen-height)))
-	       (setq edge 'bottom)))
-	(unless (eq edge ef-current-edge)
-	  (if edge
-	      (call-hook 'enter-flipper-hook (list edge))
-	    (call-hook 'leave-flipper-hook (list ef-current-edge)))))))
+      (after-flip type)))
 
 ;;; ugly hacks to make flipping work while dragging windows
+
 ;;; XXX xrefresh() to fix rubberband-traces? maybe a user-option
 ;;; XXX whether to do so? We'll see...
 
@@ -195,18 +94,10 @@
     (when move-resize-window
       (setq original-space current-workspace)))
 
-  (define (after-flip)
+  (define (after-flip type)
     (let ((w move-resize-window))
       (when w
-	(when (and (eq edge-flip-type 'workspace)
+	(when (and (eq type 'workspace)
 		   (/= original-space current-workspace)
 		   (not (window-get w 'sticky)))
-	  (move-window-to-workspace w original-space current-workspace t)))))
-
-  (define (edge-flip-while-moving w)
-    (declare (unused w))
-    (when edge-flip-enabled
-      (edge-flip-synthesize)))
-
-(unless batch-mode
-  (edge-flip-enable)))
+	  (move-window-to-workspace w original-space current-workspace t))))))
diff --git a/lisp/sawfish/wm/edge/hot-spots.jl b/lisp/sawfish/wm/edge/hot-spots.jl
index 1ecb6ed..e9cd01a 100644
--- a/lisp/sawfish/wm/edge/hot-spots.jl
+++ b/lisp/sawfish/wm/edge/hot-spots.jl
@@ -1,4 +1,4 @@
-;; hot-spots.jl 2.1.0 -- perform actions when hitting the screen-edge
+;; hot-spots.jl 3.0.0 -- perform actions when hitting the screen-edge
 
 ;; Copyright (C) 2010 Christopher Roy Bratusek <zanghar freenet de>
 
@@ -20,8 +20,7 @@
 
 (define-structure sawfish.wm.edge.hot-spots
 
-    (export hot-spots-activate
-	    hot-spots-hook)
+    (export hot-spot-activate)
 
     (open rep
 	  rep.system
@@ -59,38 +58,7 @@
   (defvar bottom-left-corner-program nil
     "The program launched when hitting the bottom-left-corner.")
 
-  (defcustom hot-spots-enable nil
-    "Whether to enable sensitive spots on the screen-edge."
-    :type boolean
-    :group (workspace hot-spot)
-    :after-set (lambda () hot-spots-activate))
-
-  (defcustom hot-spot-delay 150
-    "Milliseconds to delay before activating hot-spot."
-    :type number
-    :group (workspace hot-spot))
-
-  (define (hot-spots-activate)
-    (if hot-spots-enable
-        (unless (in-hook-p 'enter-flipper-hook hot-spots-hook)
-	  (add-hook 'enter-flipper-hook hot-spots-hook)
-	(flippers-activate t))
-      (if (in-hook-p 'enter-flipper-hook hot-spots-hook)
-	(remove-hook 'enter-flipper-hook hot-spots-hook))
-      (flippers-activate nil)))
-
-  (define hs-timer nil)
-
-  (define (hot-spots-hook)
-    (if (<= hot-spot-delay 0)
-      (hot-spot-call)
-      (setq hs-timer (make-timer (lambda ()
-			(setq hs-timer nil)
-			(hot-spot-call))
-			  (quotient hot-spot-delay 1000)
-			  (mod hot-spot-delay 1000)))))
-
-  (define (hot-spot-call)
+  (define (hot-spot-activate)
     (cond ((eq (get-active-corner) 'top-left)
 	   (unless (eq top-left-corner-program nil)
 	     (if (functionp top-left-corner-program)
@@ -137,7 +105,4 @@
 	   (unless (eq bottom-edge-program nil)
              (if (functionp bottom-edge-program)
                    (funcall bottom-edge-program)
-                 (system (concat bottom-edge-program " &")))))))
-
-  (unless batch-mode
-    (hot-spots-activate)))
+                 (system (concat bottom-edge-program " &"))))))))
diff --git a/lisp/sawfish/wm/edge/infinite-desktop.jl b/lisp/sawfish/wm/edge/infinite-desktop.jl
index 9c57035..9535fe3 100644
--- a/lisp/sawfish/wm/edge/infinite-desktop.jl
+++ b/lisp/sawfish/wm/edge/infinite-desktop.jl
@@ -20,8 +20,7 @@
 
 (define-structure sawfish.wm.edge.infinite-desktop
 
-    (export infinite-desktop-enable
-	    infinite-desktop-hook)
+    (export infinite-desktop-activate)
 
     (open rep
           rep.system
@@ -35,14 +34,7 @@
 
   (define-structure-alias infinite-desktop sawfish.wm.edge.infinite-desktop)
 
-  (defgroup infinite-desktop "Infinite Desktop"
-    :group workspace)
-
-  (defcustom infinite-desktop-p nil
-    "\"Infinite desktop\", or smooth viewport motion with mouse (Conflicts edge-flipping)."
-    :group (workspace infinite-desktop)
-    :after-set (lambda () (infinite-desktop-enable))
-    :type boolean)
+  (defgroup infinite-desktop "Infinite Desktop" :group workspace)
 
   (defcustom infinite-desktop-move-distance 64
     "Amount to move the viewport when the pointer hits the screen edge."
@@ -106,33 +98,10 @@ left."
       (set-viewport viewport-x-offset (+ viewport-y-offset dist))
       (move-cursor 0 (- (min dist cdist)))))
 
-  (define (infinite-desktop-hook)
+  (define (infinite-desktop-activate)
     "Called when a desktop flipper is triggered to shift the visible desktop."
     (let ((edge (get-active-edge)))
       (cond ((eq edge 'right) (infinite-desktop-move-right))
             ((eq edge 'left) (infinite-desktop-move-left))
             ((eq edge 'bottom) (infinite-desktop-move-bottom))
-            ((eq edge 'top) (infinite-desktop-move-top)))))
-
-  (define (infinite-desktop-while-moving w)
-    (declare (unused w))
-    (if infinite-desktop-p
-        (infinite-desktop-hook)))
-
-  (define (infinite-desktop-enable)
-    "Turn on infinite-desktop if `infinite-desktop-p' is true."
-    (if infinite-desktop-p
-        (progn
-	  (unless (in-hook-p 'enter-flipper-hook infinite-desktop-hook)
-            (add-hook 'enter-flipper-hook infinite-desktop-hook))
-	  (unless (in-hook-p 'while-moving-hook infinite-desktop-while-moving)
-	    (add-hook 'while-moving-hook infinite-desktop-while-moving))
-	  (flippers-activate t))
-      (if (in-hook-p 'enter-flipper-hook infinite-desktop-hook)
-	(remove-hook 'enter-flipper-hook infinite-desktop-hook)
-      (if (in-hook-p 'while-moving-hook infinite-desktop-while-moving)
-	(remove-hook 'while-moving-hook infinite-desktop-while-moving))
-      (flippers-activate nil))))
-
-(unless batch-mode
-  (infinite-desktop-enable)))
+            ((eq edge 'top) (infinite-desktop-move-top))))))