498 lines
16 KiB
Scheme
498 lines
16 KiB
Scheme
(define (create-move-wm out-channel dpy parent options
|
|
special-options . children)
|
|
(create-wm dpy parent options #f children
|
|
(manager-type move)
|
|
out-channel
|
|
(lambda (wm in-channel)
|
|
(init-move-wm wm in-channel)
|
|
wm)))
|
|
|
|
(define (init-move-wm wm channel)
|
|
(let* ((dpy (wm:dpy wm))
|
|
(window (wm:window wm))
|
|
(gc (create-gc dpy window '()))
|
|
(pager-channel (make-channel))
|
|
(options (wm:options wm))
|
|
(pager (create-move-wm-pager wm pager-channel options))
|
|
(titlebar-options
|
|
(let ((get (lambda (id) (get-option-value options id))))
|
|
(build-options dpy (options:colormap options)
|
|
titlebar-options-spec
|
|
`((buttons . (kill maximize iconify))
|
|
(normal-colors . ,(get 'titlebar-colors))
|
|
(active-colors . ,(get 'titlebar-colors-focused))
|
|
(focused-colors . ,(get 'titlebar-colors-focused))
|
|
(border-style . ,(get 'titlebar-style))
|
|
(font . ,(get 'font))
|
|
(button-down-colors . ,(get
|
|
'titlebar-button-down-colors))
|
|
(button-up-colors . ,(get 'titlebar-button-up-colors))
|
|
(height . ,(get 'titlebar-height)))))))
|
|
(for-each (lambda (id)
|
|
(grab-shortcut dpy window
|
|
(get-option-value options id)
|
|
id channel #f))
|
|
'(select-next select-previous hide-show-pager))
|
|
(spawn* (list 'move-wm wm)
|
|
(lambda (release)
|
|
(release)
|
|
(call-with-current-continuation
|
|
(lambda (exit)
|
|
(let loop ()
|
|
(let ((msg (receive channel)))
|
|
(handle-message wm pager gc titlebar-options exit msg)
|
|
(loop)))))
|
|
(free-gc dpy gc)))))
|
|
|
|
(define (handle-message wm pager gc titlebar-options exit msg)
|
|
(let ((dpy (wm:dpy wm))
|
|
(window (wm:window wm)))
|
|
(case (car msg)
|
|
((wait)
|
|
(let ((sp (second msg))
|
|
(message (third msg)))
|
|
(handle-message wm pager gc titlebar-options
|
|
(lambda args
|
|
(sync-point-release sp)
|
|
(apply exit args))
|
|
message)
|
|
(sync-point-release sp)))
|
|
|
|
((deinit-manager)
|
|
(exit 'deinit-manager))
|
|
|
|
((draw-main-window) #t)
|
|
|
|
((update-manager-state) #t)
|
|
|
|
((fit-windows)
|
|
(map (lambda (client)
|
|
(assert-client-visible wm client))
|
|
(wm-clients wm))
|
|
(pager-refit pager))
|
|
|
|
((init-client)
|
|
(let ((client (second msg))
|
|
(maybe-rect (third msg)))
|
|
(init-client wm client maybe-rect titlebar-options)
|
|
(pager-add-client pager client)
|
|
;; for (properly) transient windows this would not be necessary:
|
|
(wm-select-client wm client current-time)))
|
|
|
|
((deinit-client)
|
|
(let ((client (second msg)))
|
|
(deinit-client wm client)
|
|
(pager-remove-client pager client)))
|
|
|
|
((configure-window)
|
|
(let ((window (second msg))
|
|
(changes (third msg))
|
|
(client? (client-of-window wm window)))
|
|
(if (window-exists? dpy window) (begin
|
|
(let* ((r (window-rectangle dpy window))
|
|
(dx (cond
|
|
((assq (window-change x) changes) =>
|
|
(lambda (c.x) (- (cdr c.x) (rectangle:x r))))
|
|
(else 0)))
|
|
(dy (cond
|
|
((assq (window-change y) changes) =>
|
|
(lambda (c.y) (- (cdr c.y) (rectangle:y r))))
|
|
(else 0)))
|
|
(dw (cond
|
|
((assq (window-change width) changes) =>
|
|
(lambda (c.w) (- (cdr c.w) (rectangle:width r))))
|
|
(else 0)))
|
|
(dh (cond
|
|
((assq (window-change height) changes) =>
|
|
(lambda (c.h) (- (cdr c.h) (rectangle:height r))))
|
|
(else 0)))
|
|
(send-synthetic-event
|
|
(lambda ()
|
|
(let ((r (root-rectangle dpy window)))
|
|
(send-event dpy window #f (event-mask structure-notify)
|
|
(create-configure-event
|
|
(event-type configure-notify) 0 #t dpy
|
|
window window
|
|
;; TODO: border-width/gravity ?
|
|
(rectangle:x r) (rectangle:y r)
|
|
(rectangle:width r) (rectangle:height r)
|
|
0 none #f))))))
|
|
(cond
|
|
((or (assq (window-change width) changes)
|
|
(assq (window-change height) changes)
|
|
(assq (window-change border-width) changes))
|
|
(if client?
|
|
(let* ((cw (client:client-window client?))
|
|
(cr (window-rectangle dpy cw)))
|
|
(configure-window
|
|
dpy cw
|
|
(append (make-window-change-alist
|
|
(border-width 0)
|
|
(x (+ (rectangle:x cr) dx))
|
|
(y (+ (rectangle:y cr) dy))
|
|
(width (+ (rectangle:width cr) dw))
|
|
(height (+ (rectangle:height cr) dh)))
|
|
changes)))
|
|
(configure-window dpy window
|
|
(append (make-window-change-alist
|
|
(border-width 0))
|
|
changes))))
|
|
((or (assq (window-change x) changes)
|
|
(assq (window-change y) changes)
|
|
(assq (window-change stack-mode) changes))
|
|
(if client?
|
|
(let* ((cw (client:client-window client?))
|
|
(cr (window-rectangle dpy cw)))
|
|
(configure-window
|
|
dpy cw
|
|
(append (make-window-change-alist
|
|
(border-width 0)
|
|
(x (+ (rectangle:x cr) dx))
|
|
(y (+ (rectangle:y cr) dy)))
|
|
changes))))
|
|
(send-synthetic-event))
|
|
(else (send-synthetic-event))))))))
|
|
|
|
((iconify-client)
|
|
(let ((client (second msg)))
|
|
(if (not (eq? (client:wm-state client) (wm-state iconic)))
|
|
(begin
|
|
(unmap-window dpy (client:client-window client))
|
|
(unmap-window dpy (client:window client))
|
|
(set-wm-state! dpy (client:window client) (wm-state iconic)
|
|
none)
|
|
(set-client:wm-state! client (wm-state iconic))))
|
|
(pager-update-client pager client)))
|
|
|
|
((maximize-client)
|
|
;; TODO: maybe exclude pager?
|
|
(let ((client (second msg)))
|
|
(maximize-window dpy (client:client-window client))))
|
|
|
|
((normalize-client)
|
|
(let ((client (second msg)))
|
|
(if (not (eq? (client:wm-state client) (wm-state normal)))
|
|
(begin
|
|
(map-window dpy (client:window client))
|
|
(map-window dpy (client:client-window client))
|
|
(set-wm-state! dpy (client:window client) (wm-state normal)
|
|
none)
|
|
(set-client:wm-state! client (wm-state normal))))
|
|
(pager-update-client pager client)))
|
|
|
|
((draw-client-window)
|
|
(draw-client-window wm (second msg) gc))
|
|
|
|
((fit-client)
|
|
;; client-window changed it's size
|
|
(fit-client-windows wm (second msg)))
|
|
|
|
((fit-client-window)
|
|
;; client changed it's size ??
|
|
(fit-client-window wm (second msg)))
|
|
|
|
((manager-focused) #t)
|
|
|
|
((update-client-state)
|
|
(let* ((client (second msg))
|
|
(focused? (third msg))
|
|
(state (if focused?
|
|
'focused
|
|
'normal))
|
|
(titlebar (client-data:titlebar client)))
|
|
(set-titlebar-state! titlebar state)
|
|
(pager-update-client pager client)))
|
|
|
|
((update-client-name)
|
|
(let ((client (second msg))
|
|
(name (third msg)))
|
|
(let ((titlebar (client-data:titlebar client)))
|
|
(set-titlebar-title! titlebar name)
|
|
(pager-update-client pager client))))
|
|
|
|
((show-clients)
|
|
(let ((clients (second msg)))
|
|
(for-each (lambda (c)
|
|
(if (eq? (client:wm-state c) (wm-state iconic))
|
|
(handle-message wm pager gc titlebar-options exit
|
|
(list 'normalize-client c)))
|
|
(raise-window dpy (client:client-window c)))
|
|
clients)))
|
|
|
|
((select-next select-previous)
|
|
(let* ((time (second msg))
|
|
(cc (wm-current-client wm))
|
|
(clients (if (eq? (first msg) 'select-next)
|
|
(wm-clients wm)
|
|
(reverse (wm-clients wm)))))
|
|
(let loop ((l (append clients clients)))
|
|
(and (not (null? l))
|
|
(if (eq? (car l) cc)
|
|
(and (not (null? (cdr l)))
|
|
(wm-select-client wm (cadr l) time))
|
|
(loop (cdr l)))))))
|
|
|
|
((hide-show-pager)
|
|
(pager-change-visibility pager))
|
|
|
|
(else (warn "unhandled move-wm message" wm msg)))))
|
|
|
|
(define (make-client-data titlebar resizer)
|
|
(list titlebar resizer))
|
|
|
|
(define (client-data:titlebar client)
|
|
(first (client:data client)))
|
|
|
|
(define (client-data:resizer client)
|
|
(second (client:data client)))
|
|
|
|
(define (window-wants-decoration? dpy window)
|
|
(cond
|
|
((get-motif-wm-hints dpy window) =>
|
|
(lambda (hints)
|
|
(mdisplay (motif-wm-hints:decorations hints) "\n")
|
|
(or (not (motif-wm-hints:decorations hints))
|
|
(not (null? (enum-set->list (motif-wm-hints:decorations hints)))))))
|
|
(else #t)))
|
|
|
|
(define (init-client wm client maybe-rect titlebar-options)
|
|
(let ((dpy (wm:dpy wm)))
|
|
(let* ((r (initial-client-rect wm client maybe-rect))
|
|
(channel (make-channel))
|
|
(titlebar (create-client-titlebar channel wm client
|
|
titlebar-options))
|
|
(resizer (create-resizer wm client))
|
|
(options (wm:options wm)))
|
|
(set-client:data! client (make-client-data titlebar resizer))
|
|
(set-titlebar-title! titlebar (client-name dpy client))
|
|
(let* ((bw (get-option-value options 'border-width))
|
|
(th (get-option-value options 'titlebar-height))
|
|
(x.y (if (window-wants-decoration? dpy (client:window client))
|
|
(cons (rectangle:x r) (rectangle:y r))
|
|
(cons (- (rectangle:x r) bw)
|
|
(- (rectangle:y r) (+ bw th))))))
|
|
(move-resize-window dpy (client:client-window client)
|
|
(car x.y) (cdr x.y)
|
|
(+ (rectangle:width r) (* 2 bw))
|
|
(+ (rectangle:height r) (* 2 bw) th)))
|
|
(fit-client-windows wm client)
|
|
|
|
(install-dragging-control channel dpy
|
|
(titlebar:window titlebar)
|
|
(client:client-window client))
|
|
(spawn*
|
|
(list 'move-wm-client-handler wm client)
|
|
(lambda (release)
|
|
(release)
|
|
(let loop ()
|
|
(select*
|
|
(wrap (receive-rv channel)
|
|
(lambda (msg)
|
|
(case (car msg)
|
|
((drop)
|
|
;; check if outside...
|
|
(let ((window-x (second msg))
|
|
(window-y (third msg))
|
|
(root-x (fourth msg))
|
|
(root-y (fifth msg)))
|
|
(let ((r (root-rectangle dpy (wm:window wm))))
|
|
(if (point-in-rectangle? r root-x root-y)
|
|
(move-window dpy (client:client-window client)
|
|
window-x window-y)
|
|
(send (wm:out-channel wm)
|
|
(list 'root-drop (client:window client)
|
|
root-x root-y))))))
|
|
((click)
|
|
(wm-select-client wm client (fourth msg)))
|
|
;; from titlebar-buttons
|
|
((kill)
|
|
(delete-window dpy (client:window client) (second msg)))
|
|
((iconify)
|
|
(wm-iconify-window wm (client:window client)))
|
|
((maximize)
|
|
(wm-maximize-window wm (client:window client)))
|
|
))))
|
|
;; TODO: internal channel
|
|
(loop))
|
|
(destroy-resizer dpy resizer)))
|
|
|
|
(map-titlebar titlebar)
|
|
(if (window-exists? dpy (client:window client))
|
|
(map-window dpy (client:window client)))
|
|
(map-window dpy (client:client-window client)))))
|
|
|
|
(define (create-client-titlebar channel wm client titlebar-options)
|
|
(let ((options (wm:options wm)))
|
|
(create-titlebar channel (wm:dpy wm) (client:client-window client)
|
|
titlebar-options)))
|
|
|
|
(define (deinit-client wm client)
|
|
(let ((dpy (wm:dpy wm)))
|
|
(set-input-focus dpy (wm:window wm) (revert-to parent) current-time)))
|
|
|
|
;; ***
|
|
|
|
(define (fit-client-windows wm client)
|
|
(let* ((dpy (wm:dpy wm))
|
|
(options (wm:options wm))
|
|
(border-width (get-option-value options 'border-width))
|
|
(titlebar-height (get-option-value options 'titlebar-height))
|
|
(wa (get-window-attributes dpy (client:client-window client))))
|
|
;; TODO: is called much too often
|
|
(if (window-exists? dpy (client:window client))
|
|
(move-resize-window dpy (client:window client)
|
|
border-width
|
|
(+ border-width titlebar-height)
|
|
(- (window-attribute:width wa)
|
|
(* 2 border-width))
|
|
(- (window-attribute:height wa)
|
|
(+ (* 2 border-width) titlebar-height))))
|
|
(move-resize-titlebar
|
|
(client-data:titlebar client)
|
|
(make-rectangle border-width border-width
|
|
(- (window-attribute:width wa) (* 2 border-width))
|
|
titlebar-height))))
|
|
|
|
(define (fit-client-window wm client)
|
|
(let* ((dpy (wm:dpy wm))
|
|
(options (wm:options wm))
|
|
(border-width (get-option-value options 'border-width))
|
|
(titlebar-height (get-option-value options 'titlebar-height)))
|
|
(if (window-exists? dpy (client:window client))
|
|
(let ((wa (get-window-attributes dpy (client:window client))))
|
|
(resize-window dpy (client:client-window client)
|
|
(+ (window-attribute:width wa) (* 2 border-width))
|
|
(+ (window-attribute:height wa)
|
|
(* 2 border-width)
|
|
titlebar-height))))))
|
|
|
|
(define (assert-client-visible wm client)
|
|
(let* ((dpy (wm:dpy wm))
|
|
(win (client:client-window client))
|
|
(x (window-x dpy win))
|
|
(y (window-y dpy win))
|
|
(w (window-width dpy (wm:window wm)))
|
|
(h (window-height dpy (wm:window wm))))
|
|
(if (>= x w)
|
|
(set-window-x! dpy win (- w 10)))
|
|
(if (>= y h)
|
|
(set-window-y! dpy win (- h 10)))))
|
|
|
|
(define (draw-client-window wm client gc)
|
|
(let* ((options (wm:options wm))
|
|
(colors (get-option-value options 'border-colors))
|
|
(window (client:client-window client))
|
|
(dpy (wm:dpy wm))
|
|
(border-style (get-option-value options 'border-style))
|
|
(border-width (get-option-value options 'border-width))
|
|
(clip-rect (clip-rectangle dpy window)))
|
|
(if (not (eq? border-style 'flat))
|
|
(let ((light (if (eq? border-style 'sunken)
|
|
(car colors) (cadr colors)))
|
|
(dark (if (eq? border-style 'sunken)
|
|
(cadr colors) (car colors))))
|
|
(for-each (lambda (i)
|
|
(let ((r (make-rectangle
|
|
(+ i (rectangle:x clip-rect))
|
|
(+ i (rectangle:y clip-rect))
|
|
(- (rectangle:width clip-rect) (* i 2))
|
|
(- (rectangle:height clip-rect) (* i 2)))))
|
|
(draw-shadow-rectangle dpy window gc
|
|
r light dark)))
|
|
(iota border-width))))))
|
|
|
|
(define (initial-client-rect wm client maybe-rect)
|
|
(let* ((dpy (wm:dpy wm))
|
|
(win (client:window client))
|
|
(default-width (if maybe-rect (rectangle:width maybe-rect) 400))
|
|
(default-height (if maybe-rect (rectangle:height maybe-rect) 200))
|
|
(w.h (initial-client-size wm client default-width default-height))
|
|
;; TODO: Transients centered?
|
|
(options (wm:options wm))
|
|
(maybe-x.y
|
|
(let* ((bw (get-option-value options 'border-width))
|
|
(th (get-option-value options 'titlebar-height))
|
|
(x.y (find-free-position wm client w.h '(0 . 0))))
|
|
x.y))
|
|
(x.y (desired-position/hints dpy win maybe-x.y)))
|
|
(make-rectangle (car x.y) (cdr x.y)
|
|
(car w.h) (cdr w.h))))
|
|
|
|
(define (initial-client-size wm client default-width default-height)
|
|
(let* ((dpy (wm:dpy wm))
|
|
(win (client:window client))
|
|
(w.h-1
|
|
(let ((w.h (minimal-size/hints dpy win default-width
|
|
default-height)))
|
|
(cons (if (< default-width (car w.h))
|
|
(car w.h)
|
|
default-width)
|
|
(if (< default-height (cdr w.h))
|
|
(cdr w.h)
|
|
default-height))))
|
|
(w.h (maximal-size/hints dpy win (car w.h-1) (cdr w.h-1))))
|
|
;;(w.h (desired-size/hints dpy win w.h-2)))
|
|
w.h))
|
|
|
|
(define (find-free-position wm client size default-pos)
|
|
(let* ((dpy (wm:dpy wm))
|
|
(max-w (window-width dpy (wm:window wm)))
|
|
(max-h (window-height dpy (wm:window wm)))
|
|
(w (car size))
|
|
(h (cdr size))
|
|
(rects (map (lambda (client)
|
|
(window-rectangle dpy (client:client-window client)))
|
|
(filter (lambda (c)
|
|
(and (not (eq? c client))
|
|
(not (eq? (client:wm-state c)
|
|
(wm-state iconic)))))
|
|
(wm-clients wm))))
|
|
(list1 (map (lambda (x.y)
|
|
(make-rectangle (car x.y) (cdr x.y) w h))
|
|
(possible-positions rects)))
|
|
(list2 (filter (lambda (r) (rect-ok? r rects))
|
|
list1))
|
|
;; list2 may contain rects that are outside the wm
|
|
(list3 (filter (lambda (r)
|
|
(not (or (> (+ (rectangle:x r) (rectangle:width r))
|
|
max-w)
|
|
(> (+ (rectangle:y r) (rectangle:height r))
|
|
max-h))))
|
|
list2)))
|
|
(if (null? list3)
|
|
default-pos
|
|
(let ((r (car list3)))
|
|
(cons (rectangle:x r) (rectangle:y r))))))
|
|
|
|
;; possible positions are all rect-corners except the upper left, and
|
|
;; all intersection points of all bottom and right sides of the rects.
|
|
(define (possible-positions rects)
|
|
(let ((corners (flatten
|
|
(map (lambda (r)
|
|
(let* ((x1 (rectangle:x r))
|
|
(y1 (rectangle:y r))
|
|
(x2 (+ x1 (rectangle:width r)))
|
|
(y2 (+ y1 (rectangle:height r))))
|
|
(list (cons x1 y2)
|
|
;; (cons x2 y2) also included below
|
|
(cons x2 y1))))
|
|
rects)))
|
|
(xs (map (lambda (r)
|
|
(+ (rectangle:x r) (rectangle:width r)))
|
|
rects))
|
|
(ys (map (lambda (r)
|
|
(+ (rectangle:y r) (rectangle:height r)))
|
|
rects)))
|
|
(append (list (cons 0 0))
|
|
corners
|
|
(flatten (map (lambda (x)
|
|
(map (lambda (y) (cons x y))
|
|
ys))
|
|
xs)))))
|
|
|
|
;; it's ok if it does not overlap with any rect
|
|
(define (rect-ok? rect rects)
|
|
(not (any (lambda (r)
|
|
(rectangles-overlap? rect r))
|
|
rects)))
|