only draw a frame for the dragged window
This commit is contained in:
frese
parent
1460ae198f
commit
d2cb491315
|
|
@ -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))
|
||||
(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)
|
||||
(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))
|
||||
|
|
@ -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))
|
||||
(y (motion-event-y xevent)))
|
||||
(loop (list 0.2
|
||||
(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))))))
|
||||
(+ 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))))
|
||||
'()))))))
|
||||
(else (loop)))))))
|
||||
)
|
||||
(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)))
|
||||
|
|
|
|||
Loading…
Reference in New Issue