diff --git a/src/drag-window.scm b/src/drag-window.scm index 6900d1d..ebba95b 100644 --- a/src/drag-window.scm +++ b/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,56 +39,54 @@ (button-event-time xevent))) (idle)) ((motion-event? xevent) - (let ((r (root-rectangle dpy dragged-window)) - (dw (create-drag-window dpy - dragged-window))) - ;;(grab-server dpy) - (drag dw click-x click-y (rectangle:x r) - (rectangle:y r)))) + (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 (dwin click-x click-y win-x win-y) - (let loop ((move-timer #f)) - (select - (cons - (wrap (receive-rv event-channel) - (lambda (xevent) - (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)))) - (destroy-drag-window dwin) - (send channel - (list 'drop x y - (button-event-x-root xevent) - (button-event-y-root xevent))) - ;;(ungrab-server dpy) - (idle))) + + (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))) - (loop (list 0.2 - (+ win-x (- x click-x)) - (+ win-y (- y click-y)))))) + ((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 move-timer))))) - (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))))))) + ((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)))