241 lines
7.4 KiB
Scheme
241 lines
7.4 KiB
Scheme
(define-options-spec switch-wm-options-spec
|
|
(titlebar-colors colors '("#aaaaaa" "#eeeeee" "#777777" "black"))
|
|
(titlebar-colors-active colors '("#666699" "#aaaacc" "#333366" "#eeeeee"))
|
|
(titlebar-colors-focused colors '("#9999aa" "#eeeeff" "#777788" "black"))
|
|
(titlebar-height int 18)
|
|
(titlebar-style symbol 'flat)
|
|
(font font "-*-helvetica-medium-r-normal-*-12-*-*-*-*-*-*-*")
|
|
(select-next keys "M-k n")
|
|
(select-previous keys "M-k p")
|
|
(kill-client keys "M-c")
|
|
)
|
|
|
|
(define (create-switch-wm out-channel dpy parent options . children)
|
|
(create-wm dpy parent options children
|
|
(manager-type switch) switch-wm-options-spec
|
|
out-channel
|
|
(lambda (wm in-channel)
|
|
(spawn (lambda ()
|
|
(switch-wm-handler wm in-channel)))
|
|
wm)))
|
|
|
|
(define-record-type switch-wm-data :switch-wm-data
|
|
(make-switch-wm-data titlebars empty-titlebar)
|
|
switch-wm-data?
|
|
(titlebars data:titlebars set-data:titlebars!)
|
|
(empty-titlebar data:empty-titlebar))
|
|
|
|
(define (switch-wm-handler wm channel)
|
|
(let* ((dpy (wm:dpy wm))
|
|
(options (wm:options wm))
|
|
(gc (create-gc dpy (wm:window wm) '()))
|
|
(empty-titlebar (create-empty-titlebar wm))
|
|
(data (make-switch-wm-data '() empty-titlebar)))
|
|
(update-titlebars wm data)
|
|
|
|
(grab-shortcut dpy (wm:window wm)
|
|
(get-option-value options 'select-next)
|
|
'select-next channel #f)
|
|
(grab-shortcut dpy (wm:window wm)
|
|
(get-option-value options 'select-previous)
|
|
'select-previous channel #f)
|
|
|
|
(let loop ()
|
|
(let ((msg (receive channel)))
|
|
(case (car msg)
|
|
((draw-main-window) #t)
|
|
|
|
((fit-windows)
|
|
(fit-titlebars wm data)
|
|
(for-each (lambda (c)
|
|
(fit-client-window wm c))
|
|
(wm-clients wm)))
|
|
|
|
((init-client)
|
|
(init-client wm data (second msg) (third msg)))
|
|
((deinit-client)
|
|
(deinit-client wm data (second msg)))
|
|
|
|
((draw-client-window) #f)
|
|
|
|
((fit-client)
|
|
;; client-window changed it's size
|
|
(fit-client wm (second msg)))
|
|
|
|
((fit-client-window)
|
|
;; client changed it's size ??
|
|
(fit-client-window wm (second msg)))
|
|
|
|
;; TODO: need focus-in of manager to update empty-titlebar
|
|
|
|
((update-client-state)
|
|
(let* ((client (second msg))
|
|
(dpy (wm:dpy wm))
|
|
(window (client:window client))
|
|
(state (if (window-contains-focus? dpy window)
|
|
'focused
|
|
(if (window-viewable? dpy window)
|
|
'active
|
|
'normal)))
|
|
(titlebar (assq/false client (data:titlebars data)))
|
|
(name (client-name dpy client)))
|
|
(set-titlebar-state! titlebar state)
|
|
(set-titlebar-title! titlebar name)))
|
|
|
|
((select-next) (select-next-client wm (second msg)))
|
|
((select-previous) (select-previous-client wm (second msg)))
|
|
))
|
|
(loop))
|
|
(free-gc (wm:dpy wm) gc)))
|
|
|
|
(define (fit-titlebars wm data)
|
|
(let* ((dpy (wm:dpy wm))
|
|
(width (window-width dpy (wm:window wm)))
|
|
(height (window-height dpy (wm:window wm)))
|
|
(titlebar-height (get-option-value (wm:options wm) 'titlebar-height)))
|
|
(move-resize-titlebar (data:empty-titlebar data)
|
|
(make-rectangle 0 0 width titlebar-height))
|
|
(let* ((titlebars (map cdr (data:titlebars data)))
|
|
(n (length titlebars))
|
|
(widths (if (zero? n) '()
|
|
(let ((dw (quotient width n)))
|
|
(append (map (lambda (_) dw) (iota (- n 1)))
|
|
(list (- width (* dw (- n 1)))))))))
|
|
(for-each (lambda (i width titlebar)
|
|
(move-resize-titlebar
|
|
titlebar
|
|
(make-rectangle (* i width) 0
|
|
width titlebar-height)))
|
|
(iota n) widths titlebars))))
|
|
|
|
(define (update-titlebars wm data)
|
|
(if (null? (data:titlebars data))
|
|
(map-titlebar (data:empty-titlebar data))
|
|
(begin
|
|
(unmap-titlebar (data:empty-titlebar data))
|
|
(for-each (lambda (c.t)
|
|
(map-titlebar (cdr c.t)))
|
|
(data:titlebars data)))))
|
|
|
|
(define (init-client wm data client maybe-rect)
|
|
;; TODO: transients!
|
|
(let ((dpy (wm:dpy wm))
|
|
(options (wm:options wm)))
|
|
(set-window-border-width! dpy (client:window client) 0)
|
|
(let* ((channel (make-channel))
|
|
(titlebar (create-client-titlebar channel wm client)))
|
|
(set-data:titlebars! data (cons (cons client titlebar)
|
|
(data:titlebars data)))
|
|
(fit-titlebars wm data)
|
|
(update-titlebars wm data)
|
|
(fit-client-window wm client)
|
|
(fit-client wm client)
|
|
|
|
(install-dragging-control channel dpy
|
|
(titlebar:window titlebar)
|
|
(client:client-window client))
|
|
(grab-shortcut dpy (client:client-window client)
|
|
(get-option-value options 'kill-client)
|
|
'kill-client channel #f)
|
|
(spawn
|
|
(lambda ()
|
|
(let loop ()
|
|
(let ((msg (receive channel)))
|
|
(case (car msg)
|
|
((drop)
|
|
;; TODO: check if outside...
|
|
;;(move-window dpy (client:client-window client)
|
|
;; (second msg) (third msg))
|
|
#t
|
|
)
|
|
((click)
|
|
(wm-select-client wm client (fourth msg)))
|
|
((kill-client)
|
|
(let ((time (second msg)))
|
|
(delete-window dpy (client:window client) time)))
|
|
(else (mdisplay "unhandled client message: " msg "\n"))))
|
|
;; TODO: internal channel
|
|
(loop))))
|
|
|
|
(map-titlebar titlebar)
|
|
(map-window dpy (client:client-window client))
|
|
;;(select-client wm client))) ??
|
|
)))
|
|
|
|
(define (create-client-titlebar channel wm client)
|
|
(let ((options (wm:options wm)))
|
|
(create-titlebar channel (wm:dpy wm) (wm:window wm)
|
|
(wm:colormap wm)
|
|
;; TODO: buttons
|
|
(list (cons 'normal-colors
|
|
(get-option options 'titlebar-colors))
|
|
(cons 'active-colors
|
|
(get-option options 'titlebar-colors-active))
|
|
(cons 'focused-colors
|
|
(get-option options 'titlebar-colors-focused))
|
|
(cons 'border-style
|
|
(get-option options 'titlebar-style))))))
|
|
|
|
(define (create-empty-titlebar wm)
|
|
(let* ((options (wm:options wm))
|
|
(tb
|
|
(create-titlebar #f (wm:dpy wm) (wm:window wm) (wm:colormap wm)
|
|
;; buttons ??
|
|
(list ;; TODO: (cons 'draggable #f)
|
|
(cons 'normal-colors
|
|
(get-option options 'titlebar-colors))
|
|
(cons 'active-colors
|
|
(get-option options 'titlebar-colors-active))
|
|
(cons 'focused-colors
|
|
(get-option options 'titlebar-colors-focused))
|
|
(cons 'border-style
|
|
(get-option options 'titlebar-style))))))
|
|
(set-titlebar-title! tb "<empty frame>")
|
|
tb))
|
|
|
|
(define (deinit-client wm data client)
|
|
(let ((dpy (wm:dpy wm))
|
|
(tb (assq/false client (data:titlebars data))))
|
|
(set-data:titlebars! data (filter (lambda (c.t)
|
|
(not (eq? (car c.t) client)))
|
|
(data:titlebars data)))
|
|
(if tb (destroy-titlebar tb))
|
|
(fit-titlebars wm data)
|
|
(update-titlebars wm data)))
|
|
|
|
;; ***
|
|
|
|
(define (fit-client wm client)
|
|
(maximize-window (wm:dpy wm) (client:window client)))
|
|
|
|
(define (fit-client-window wm client)
|
|
(let* ((dpy (wm:dpy wm))
|
|
(w (wm:window wm))
|
|
(options (wm:options wm))
|
|
(titlebar-height (get-option-value options 'titlebar-height)))
|
|
(move-resize-window dpy (client:client-window client)
|
|
0 titlebar-height
|
|
(window-width dpy w) (- (window-height dpy w)
|
|
titlebar-height))))
|
|
|
|
;; ***
|
|
|
|
(define (select-next-client* wm clients time)
|
|
(let ((cc (wm-current-client wm)))
|
|
(let loop ((rest clients))
|
|
(if (null? rest)
|
|
(if (null? clients)
|
|
#f
|
|
(car clients))
|
|
(if (eq? cc (car rest))
|
|
(if (null? (cdr rest))
|
|
#f
|
|
(wm-select-client wm (cadr rest) time))
|
|
(loop (cdr rest)))))))
|
|
|
|
(define (select-next-client wm time)
|
|
(select-next-client* wm (wm-clients wm) time))
|
|
|
|
(define (select-previous-client wm time)
|
|
(select-next-client* wm (reverse (wm-clients wm)) time))
|