(define (install-dragging-control channel dpy click-window dragged-window)
  (spawn*
   (list 'dragging-control click-window dragged-window)
   (lambda (release)
     (call-with-event-channel
      dpy click-window
      (event-mask button-press button-release
		  button-1-motion structure-notify)
      (lambda (event-channel)
	(release)
	(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
		       ((eq? (event-type button-press)
			     (any-event-type xevent))
			(trans (button-event-x xevent)
			       (button-event-y xevent)))

		       ((destroy-window-event? xevent) #t)
		       (else (idle))))))
		 (trans
		  (lambda (click-x click-y)
		    ;; if next event is motion-event it's a drag, if
		    ;; button-release then it's a click.
		    (let ((xevent (receive event-channel)))
		      (cond
		       ((eq? (event-type button-release)
			     (any-event-type xevent))
			(send channel (list 'click click-x click-y
					    (button-event-time xevent)))
			(idle))
		       ((motion-event? xevent)
			(let ((r (root-rectangle dpy dragged-window)))
			  (grab-server dpy)
			  (draw-frame dpy gc r)
			  (drag click-x click-y (rectangle:x r)
				(rectangle:y r) r)))
		       ((destroy-window-event? xevent) #t)
		       (else (trans click-x click-y))))))
		 
		 (drag
		  (lambda (click-x click-y win-x win-y last-r)
		     (let loop ()
		       (let ((xevent (receive event-channel)))
			 (cond
			  ((eq? (event-type button-release)
				(any-event-type xevent))
			   (let ((x (+ (window-x dpy dragged-window)
				       (- (button-event-x xevent)
					  click-x)))
				 (y (+ (window-y dpy dragged-window)
				       (- (button-event-y xevent)
					  click-y))))
			     (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)))
			     (idle)))
				  
			  ((motion-event? xevent)
			   (let* ((x (motion-event-x xevent))
				  (y (motion-event-y xevent))
				  (new-r (make-rectangle
					  (+ win-x (- x click-x))
					  (+ 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)))))))
		 )
	  (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)))