224 lines
7.1 KiB
Scheme
224 lines
7.1 KiB
Scheme
;; TODO: -> options ??
|
|
(define default-cursor xc-X-cursor)
|
|
(define frame-size 3)
|
|
|
|
(define (create-resizer wm client)
|
|
(let* ((dpy (wm:dpy wm))
|
|
(window (client:client-window client))
|
|
(gc (create-gc dpy (default-root-window dpy)
|
|
(make-gc-value-alist
|
|
(foreground (white-pixel dpy))
|
|
(subwindow-mode (subwindow-mode include-inferiors))
|
|
(line-width frame-size)
|
|
(function (gc-function xor)))))
|
|
(cursors
|
|
(map (lambda (dir id)
|
|
(cons dir (create-font-cursor dpy id)))
|
|
'(west north-west north north-east east south-east south
|
|
south-west none)
|
|
(list xc-left-side xc-top-left-corner xc-top-side
|
|
xc-top-right-corner xc-right-side xc-bottom-right-corner
|
|
xc-bottom-side xc-bottom-left-corner default-cursor))))
|
|
|
|
(spawn*
|
|
(list 'move-wm-resizer wm client)
|
|
(lambda (release)
|
|
(call-with-event-channel
|
|
dpy window
|
|
(event-mask structure-notify
|
|
button-press button-release
|
|
pointer-motion)
|
|
(lambda (event-channel)
|
|
(release)
|
|
(letrec
|
|
((idle
|
|
(lambda ()
|
|
(let ((xevent (receive event-channel)))
|
|
(cond
|
|
((and (motion-event? xevent) (window-exists? dpy window))
|
|
(set-resize-cursor wm client cursors
|
|
(motion-event-x xevent)
|
|
(motion-event-y xevent))
|
|
(idle))
|
|
((and (eq? (event-type button-press)
|
|
(any-event-type xevent))
|
|
(window-exists? dpy window))
|
|
(let* ((x (button-event-x xevent))
|
|
(y (button-event-y xevent))
|
|
(dir (resizer-direction wm client x y)))
|
|
(if (eq? dir 'none)
|
|
(idle)
|
|
(let ((r (root-rectangle dpy window)))
|
|
(grab-server dpy)
|
|
(rubber-draw dpy gc r)
|
|
(drag x y r r dir)))))
|
|
((destroy-window-event? xevent) #t)
|
|
(else (idle))))))
|
|
|
|
(drag
|
|
(lambda (start-x start-y start-r prev-rect dir)
|
|
(let ((xevent (receive event-channel)))
|
|
(cond
|
|
((motion-event? xevent)
|
|
(let ((new-rect
|
|
(adjust-rect wm client start-r
|
|
(- (motion-event-x xevent) start-x)
|
|
(- (motion-event-y xevent) start-y)
|
|
dir)))
|
|
(rubber-draw dpy gc prev-rect)
|
|
(rubber-draw dpy gc new-rect)
|
|
(drag start-x start-y start-r new-rect dir)))
|
|
((eq? (event-type button-release)
|
|
(any-event-type xevent))
|
|
(rubber-draw dpy gc prev-rect)
|
|
(ungrab-server dpy)
|
|
(commit-resize wm client
|
|
(- (button-event-x xevent) start-x)
|
|
(- (button-event-y xevent) start-y)
|
|
dir)
|
|
(idle))
|
|
((destroy-window-event? xevent) #t)
|
|
(else (drag start-x start-y start-r
|
|
prev-rect dir)))))))
|
|
(idle))))
|
|
(free-gc dpy gc)
|
|
(for-each (lambda (c) (free-cursor dpy (cdr c))) cursors)))
|
|
window))
|
|
|
|
(define (destroy-resizer dpy resizer)
|
|
(destroy-window dpy resizer))
|
|
|
|
(define (rubber-draw dpy gc rect)
|
|
(draw-rectangle dpy (default-root-window dpy) gc
|
|
(rectangle:x rect) (rectangle:y rect)
|
|
(rectangle:width rect) (rectangle:height rect)))
|
|
|
|
(define (adjust-rect wm client sr dx dy dir)
|
|
(let* ((w.h (maximal-size/hints (wm:dpy wm) (client:window client)
|
|
(+ (rectangle:width sr) dx)
|
|
(+ (rectangle:height sr) dy)))
|
|
(dx (- (car w.h) (rectangle:width sr)))
|
|
(dy (- (cdr w.h) (rectangle:height sr))))
|
|
|
|
(case dir
|
|
((west)
|
|
(make-rectangle (+ (rectangle:x sr) dx)
|
|
(rectangle:y sr)
|
|
(- (rectangle:width sr) dx)
|
|
(rectangle:height sr)))
|
|
((north-west)
|
|
(make-rectangle (+ (rectangle:x sr) dx)
|
|
(+ (rectangle:y sr) dy)
|
|
(- (rectangle:width sr) dx)
|
|
(- (rectangle:height sr) dy)))
|
|
((north)
|
|
(make-rectangle (rectangle:x sr)
|
|
(+ (rectangle:y sr) dy)
|
|
(rectangle:width sr)
|
|
(- (rectangle:height sr) dy)))
|
|
((north-east)
|
|
(make-rectangle (rectangle:x sr)
|
|
(+ (rectangle:y sr) dy)
|
|
(+ (rectangle:width sr) dx)
|
|
(- (rectangle:height sr) dy)))
|
|
((east)
|
|
(make-rectangle (rectangle:x sr)
|
|
(rectangle:y sr)
|
|
(+ (rectangle:width sr) dx)
|
|
(rectangle:height sr)))
|
|
((south-east)
|
|
(make-rectangle (rectangle:x sr)
|
|
(rectangle:y sr)
|
|
(+ (rectangle:width sr) dx)
|
|
(+ (rectangle:height sr) dy)))
|
|
((south)
|
|
(make-rectangle (rectangle:x sr)
|
|
(rectangle:y sr)
|
|
(rectangle:width sr)
|
|
(+ (rectangle:height sr) dy)))
|
|
((south-west)
|
|
(make-rectangle (+ (rectangle:x sr) dx)
|
|
(rectangle:y sr)
|
|
(- (rectangle:width sr) dx)
|
|
(+ (rectangle:height sr) dy)))
|
|
(else sr))))
|
|
|
|
(define (commit-resize wm client dx dy dir)
|
|
(let* ((dpy (wm:dpy wm))
|
|
(win (client:client-window client))
|
|
(sr (window-rectangle dpy win))
|
|
(rect (adjust-rect wm client sr dx dy dir)))
|
|
(move-resize-window dpy win
|
|
(rectangle:x rect)
|
|
(rectangle:y rect)
|
|
(rectangle:width rect)
|
|
(rectangle:height rect))))
|
|
|
|
(define (set-resize-cursor wm client cursors x y)
|
|
(let* ((dpy (wm:dpy wm))
|
|
(c (assq (resizer-direction wm client x y) cursors)))
|
|
(if c
|
|
(define-cursor dpy (client:client-window client) (cdr c)))))
|
|
|
|
(define (resizer-direction wm client x y)
|
|
(let* ((dpy (wm:dpy wm))
|
|
(win (client:client-window client))
|
|
(width (window-width dpy win))
|
|
(height (window-height dpy win))
|
|
(corner-size (get-option (wm:options wm) 'corner-width))
|
|
(fc-size (+ frame-size corner-size)))
|
|
(let ((region-alist
|
|
(list (cons 'west
|
|
(list (make-rectangle 0 fc-size frame-size
|
|
(- height (* 2 fc-size)))))
|
|
(cons 'north-west
|
|
(list (make-rectangle 0 frame-size frame-size
|
|
corner-size)
|
|
(make-rectangle 0 0 frame-size frame-size)
|
|
(make-rectangle frame-size 0 corner-size
|
|
frame-size)))
|
|
(cons 'north
|
|
(list (make-rectangle fc-size 0 (- width (* 2 fc-size))
|
|
frame-size)))
|
|
(cons 'north-east
|
|
(list (make-rectangle (- width fc-size) 0 corner-size
|
|
frame-size)
|
|
(make-rectangle (- width frame-size) 0
|
|
frame-size frame-size)
|
|
(make-rectangle (- width frame-size) frame-size
|
|
frame-size corner-size)))
|
|
(cons 'east
|
|
(list (make-rectangle (- width frame-size) fc-size
|
|
frame-size
|
|
(- height (* 2 fc-size)))))
|
|
(cons 'south-east
|
|
(list (make-rectangle (- width frame-size)
|
|
(- height fc-size) frame-size
|
|
corner-size)
|
|
(make-rectangle (- width frame-size)
|
|
(- height frame-size)
|
|
frame-size frame-size)
|
|
(make-rectangle (- width fc-size)
|
|
(- height frame-size)
|
|
corner-size frame-size)))
|
|
(cons 'south
|
|
(list (make-rectangle fc-size (- height frame-size)
|
|
(- width (* 2 fc-size))
|
|
frame-size)))
|
|
(cons 'south-west
|
|
(list (make-rectangle frame-size
|
|
(- height frame-size) corner-size
|
|
frame-size)
|
|
(make-rectangle 0 (- width frame-size)
|
|
frame-size frame-size)
|
|
(make-rectangle 0 (- height fc-size)
|
|
frame-size corner-size))))))
|
|
(let ((matches (filter (lambda (d.rs)
|
|
(any (lambda (r)
|
|
(point-in-rectangle? r x y))
|
|
(cdr d.rs)))
|
|
region-alist)))
|
|
(if (null? matches)
|
|
'none
|
|
(car (car matches)))))))
|