135 lines
4.1 KiB
Scheme
135 lines
4.1 KiB
Scheme
;; *** 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* (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*
|
|
(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 ((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))
|
|
(dw (create-drag-window dpy
|
|
dragged-window)))
|
|
;;(grab-server dpy)
|
|
(drag dw click-x click-y (rectangle:x 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)
|
|
(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))))
|
|
(destroy-drag-window dwin)
|
|
(send channel (list 'drop x y))
|
|
;;(ungrab-server dpy)
|
|
(idle)))
|
|
|
|
((motion-event? xevent)
|
|
(let ((x (motion-event-x xevent))
|
|
(y (motion-event-y xevent)))
|
|
(move-drag-window dwin
|
|
(+ win-x (- x click-x))
|
|
(+ win-y (- y click-y)))
|
|
(drag dwin click-x click-y win-x win-y)))
|
|
|
|
((destroy-window-event? xevent) #t)
|
|
(else
|
|
(drag dwin click-x click-y win-x win-y)))))))
|
|
(idle)))))))
|