only draw a frame for the dragged window

src/drag-window.scm

@@ -1,68 +1,3 @@
-;; *** the draw window ***********************************************
-
-(define-record-type drag-window :drag-window
-  (make-drag-window dpy window)
-  drag-window?
-  (dpy dw:dpy)
-  (window dw:window))
-
-(define (create-drag-window dpy dwindow)
-  (let* ((width (window-width dpy dwindow))
-	 (height (window-height dpy dwindow))
-	 (pixmap (create-pixmap dpy dwindow width height
-				(window-depth dpy dwindow)))
-	 (gc (create-gc dpy pixmap
-			(make-gc-value-alist
-			 (graphics-exposures #t)
-			 (background (black-pixel dpy))
-			 (foreground (white-pixel dpy))
-			 (subwindow-mode (subwindow-mode include-inferiors)))))
-	 )
-    (copy-area dpy dwindow pixmap gc 0 0 width height 0 0)
-    ;; TODO: draw X shape over this now.
-    (free-gc dpy gc)
-    (let* ((rect (root-rectangle dpy dwindow))
-	   (window (create-simple-window dpy (default-root-window dpy)
-					 (rectangle:x rect) (rectangle:y rect)
-					 (rectangle:width rect)
-					 (rectangle:height rect)
-					 0 (black-pixel dpy)
-					 (black-pixel dpy)))
-	   (gc (create-gc dpy window
-			  (make-gc-value-alist
-			   (tile pixmap)
-			   (fill-style (fill-style tiled))
-			   (fill-rule (fill-rule even-odd))))))
-      (set-window-override-redirect! dpy window #t)
-      (spawn* (list 'drag-window window dwindow)
-	      (lambda (release)
-		(call-with-event-channel
-		 dpy window (event-mask exposure structure-notify)
-		 (lambda (channel)
-		   (release)
-		   (map-window dpy window)
-		   (fill-rectangle dpy window gc 0 0 width height)
-		   (let loop ()
-		     (let ((xevent (receive channel)))
-		       (cond
-			((expose-event? xevent)
-			 (if (= (expose-event-count xevent) 0)
-			     (fill-rectangle dpy window gc 0 0 width height))
-			 (loop))
-			((destroy-window-event? xevent)
-			 (free-gc dpy gc)
-			 (free-pixmap dpy pixmap))
-			(else (loop)))))))))
-      (make-drag-window dpy window))))
-
-(define (destroy-drag-window dw)
-  (destroy-window (dw:dpy dw) (dw:window dw)))
-
-(define (move-drag-window dw x y)
-  (move-window (dw:dpy dw) (dw:window dw) x y))
-
-;; *** control over the dragging *************************************
-
 (define (install-dragging-control channel dpy click-window dragged-window)
   (spawn*
    (list 'dragging-control click-window dragged-window)
@@ -73,7 +8,15 @@
 		  button-1-motion structure-notify)
       (lambda (event-channel)
 	(release)
-	(letrec ((idle
+	(letrec ((gc (create-gc dpy (default-root-window dpy)
+				(make-gc-value-alist
+				 (function (gc-function xor))
+				 (line-width 3)
+				 (background (black-pixel dpy))
+				 (foreground (white-pixel dpy))
+				 (subwindow-mode (subwindow-mode
+						  include-inferiors)))))
+		 (idle
 		  (lambda ()
 		    (let ((xevent (receive event-channel)))
 		      (cond
@@ -96,22 +39,18 @@
 					    (button-event-time xevent)))
 			(idle))
 		       ((motion-event? xevent)
-			(let ((r (root-rectangle dpy dragged-window))
+			(let ((r (root-rectangle dpy dragged-window)))
-			      (dw (create-drag-window dpy
+			  (grab-server dpy)
-						      dragged-window)))
+			  (draw-frame dpy gc r)
-			  ;;(grab-server dpy)
+			  (drag click-x click-y (rectangle:x r)
-			  (drag dw click-x click-y (rectangle:x r)
+				(rectangle:y r) r)))
-				(rectangle:y r))))
 		       ((destroy-window-event? xevent) #t)
 		       (else (trans click-x click-y))))))
 		 
 		 (drag
-		   (lambda (dwin click-x click-y win-x win-y)
+		  (lambda (click-x click-y win-x win-y last-r)
-		     (let loop ((move-timer #f))
+		     (let loop ()
-		       (select
+		       (let ((xevent (receive event-channel)))
-			(cons
-			 (wrap (receive-rv event-channel)
-			       (lambda (xevent)
 			 (cond
 			  ((eq? (event-type button-release)
 				(any-event-type xevent))
@@ -121,31 +60,33 @@
 				 (y (+ (window-y dpy dragged-window)
 				       (- (button-event-y xevent)
 					  click-y))))
-				     (destroy-drag-window dwin)
+			     (draw-frame dpy gc last-r)
+			     (ungrab-server dpy)
 			     (send channel
 				   (list 'drop x y
 					 (button-event-x-root xevent)
 					 (button-event-y-root xevent)))
-				     ;;(ungrab-server dpy)
 			     (idle)))
 				  
 			  ((motion-event? xevent)
-				   (let ((x (motion-event-x xevent))
+			   (let* ((x (motion-event-x xevent))
-					 (y (motion-event-y xevent)))
+				  (y (motion-event-y xevent))
-				     (loop (list 0.2
+				  (new-r (make-rectangle
 					  (+ win-x (- x click-x))
-						 (+ win-y (- y click-y))))))
+					  (+ win-y (- y click-y))
+					  (rectangle:width last-r)
+					  (rectangle:height last-r))))
+			     (draw-frame dpy gc last-r)
+			     (draw-frame dpy gc new-r)
+			     (drag click-x click-y win-x win-y new-r)))
 				  
 			  ((destroy-window-event? xevent) #t)
-				  (else (loop move-timer)))))
+			  (else (loop)))))))
-			 (if move-timer
-			     (list
-			      (wrap (after-time-rv (first move-timer))
-				    (lambda (_)
-				      (move-drag-window dwin
-							(second move-timer)
-							(third move-timer))
-				      (loop #f))))
-			     '()))))))
 		 )
-	  (idle)))))))
+	  (idle)
+	  (free-gc dpy gc)))))))
+
+(define (draw-frame dpy gc rect)
+  (draw-rectangle dpy (default-root-window dpy) gc
+		  (rectangle:x rect) (rectangle:y rect)
+		  (rectangle:width rect) (rectangle:height rect)))