scsh-conservatory
/
orion-wm
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

only draw a frame for the dragged window

This commit is contained in:
frese 2003-04-22 21:39:57 +00:00
parent 1460ae198f
commit d2cb491315
1 changed files with 56 additions and 115 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

171
src/drag-window.scm
View File

@ -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)))