93 lines
2.8 KiB
Scheme
93 lines
2.8 KiB
Scheme
(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)))
|