223 lines
6.9 KiB
Scheme
223 lines
6.9 KiB
Scheme
(define-record-type move-wm-pager :move-wm-pager
|
|
(make-move-wm-pager dpy window wm in-channel options buttons-alist width
|
|
visible? button-options)
|
|
move-wm-pager?
|
|
(dpy pager:dpy)
|
|
(window pager:window)
|
|
(wm pager:wm)
|
|
(in-channel pager:in-channel)
|
|
(options pager:options)
|
|
;; client -> button
|
|
(buttons-alist pager:buttons-alist set-pager:buttons-alist!)
|
|
(width pager:width set-pager:width!)
|
|
(visible? pager:visible? set-pager:visible!)
|
|
(button-options pager:button-options))
|
|
|
|
;; TODO: client-name <-> WM_ICON_NAME?
|
|
|
|
(define (repeat-infinitely fun) ;; -> utils
|
|
(call-with-current-continuation
|
|
(lambda (exit)
|
|
(let loop ()
|
|
(fun exit)
|
|
(loop)))))
|
|
|
|
(define (create-move-wm-pager wm out-channel options)
|
|
(let* ((dpy (wm:dpy wm))
|
|
(parent (wm:window wm))
|
|
(rect (calc-pager-rect wm))
|
|
(bg-color (first (get-option-value options 'pager-colors)))
|
|
(window (create-simple-window dpy parent
|
|
(rectangle:x rect) (rectangle:y rect)
|
|
(rectangle:width rect)
|
|
(rectangle:height rect)
|
|
0 (black-pixel dpy)
|
|
bg-color))
|
|
(in-channel (make-channel))
|
|
(gc (create-gc dpy window '()))
|
|
(button-options
|
|
(let* ((colors (get-option-value options 'pager-colors))
|
|
(main-color (second colors))
|
|
(light (third colors))
|
|
(dark (fourth colors))
|
|
(font-color (fifth colors)))
|
|
(build-options
|
|
(options:dpy options) (options:colormap options)
|
|
button-options-spec
|
|
`((up-colors . ,(list main-color light dark font-color))
|
|
(down-colors . ,(list main-color dark light font-color))
|
|
(font . ,(get-option-value options 'font))
|
|
(initial-content . "<unnamed>")
|
|
(type . switch)
|
|
(initial-state . up)))))
|
|
(pager (make-move-wm-pager dpy window wm in-channel options '()
|
|
(rectangle:width rect) #t
|
|
button-options)))
|
|
(spawn*
|
|
(list 'move-wm-pager wm window)
|
|
(lambda (release)
|
|
(call-with-event-channel
|
|
dpy window
|
|
(event-mask exposure
|
|
button-press button-release
|
|
visibility-change)
|
|
(lambda (window-channel)
|
|
(release)
|
|
(repeat-infinitely
|
|
(lambda (exit)
|
|
(select*
|
|
(wrap (receive-rv in-channel)
|
|
(lambda (msg)
|
|
(cond
|
|
((and (pair? (first msg))
|
|
(eq? 'button (car (first msg))))
|
|
(let ((client (cdr (first msg)))
|
|
(time (second msg))
|
|
(event (third msg)))
|
|
(pager-action pager client time event)))
|
|
((not (pair? (first msg)))
|
|
(case (first msg)
|
|
((add-client)
|
|
(let* ((client (second msg))
|
|
(button (pager-create-button
|
|
pager client
|
|
(make-rectangle 0 0 1 1))))
|
|
(set-pager:buttons-alist!
|
|
pager
|
|
(append (pager:buttons-alist pager)
|
|
(list (cons client button))))
|
|
(pager-refit-buttons pager)
|
|
(map-button button)))
|
|
((remove-client)
|
|
(let* ((client (second msg))
|
|
(button (assq/false
|
|
client
|
|
(pager:buttons-alist pager))))
|
|
(set-pager:buttons-alist!
|
|
pager
|
|
(alist-delete client
|
|
(pager:buttons-alist pager)))
|
|
(if button
|
|
(begin
|
|
(destroy-button button)
|
|
(pager-refit-buttons pager))
|
|
(warn "pager-remove-client: unknown client."
|
|
pager client))))
|
|
)))))
|
|
|
|
(wrap (receive-rv window-channel)
|
|
(lambda (xevent)
|
|
(cond
|
|
((expose-event? xevent)
|
|
(if (zero? (expose-event-count xevent))
|
|
(pager-draw pager gc)))
|
|
((destroy-window-event? xevent) ;; mask?
|
|
;; destroy-button not necessary
|
|
(exit))))))))
|
|
(free-gc dpy gc)))))
|
|
(map-window dpy window)
|
|
pager))
|
|
|
|
(define (pager-create-button pager client rect)
|
|
(let ((b (create-button (pager:dpy pager) (pager:window pager)
|
|
rect (pager:in-channel pager)
|
|
(cons 'button client)
|
|
(pager:button-options pager))))
|
|
(button-set-content! b (client-name (pager:dpy pager) client))
|
|
b))
|
|
|
|
(define (calc-pager-rect wm)
|
|
(let ((dpy (wm:dpy wm))
|
|
(window (wm:window wm))
|
|
(options (wm:options wm))) ;; wm-options = pager-options!?
|
|
(let* ((g (get-geometry dpy window))
|
|
(width (vector-ref g 3))
|
|
(height (vector-ref g 4))
|
|
(pager-height (get-option-value options 'pager-height)))
|
|
(make-rectangle 0 (- height pager-height)
|
|
width pager-height))))
|
|
|
|
(define (pager-action pager client time event) ;, event??
|
|
(let ((wm (pager:wm pager)))
|
|
;; normalize/iconify directly via client?!
|
|
(if (eq? (client:wm-state client)
|
|
(wm-state iconic))
|
|
(begin
|
|
(wm-normalize-window wm (client:window client))
|
|
(wm-select-client wm client time))
|
|
(if (client:focused? client) ;; this should better be "on top?"
|
|
;; select a different one?
|
|
(wm-iconify-window wm (client:window client))
|
|
(wm-select-client wm client time)))))
|
|
|
|
(define (pager-draw pager gc)
|
|
(clear-window (pager:dpy pager) (pager:window pager)))
|
|
|
|
(define (pager-button-rects pager)
|
|
(let ((alist (pager:buttons-alist pager))
|
|
(options (pager:options pager)))
|
|
(if (null? alist)
|
|
'()
|
|
(let* ((width (pager:width pager))
|
|
(bwidth (min (get-option-value options
|
|
'pager-maximum-button-width)
|
|
(- (quotient width (length alist)) 2)))
|
|
(bheight (- (get-option-value options 'pager-height) 4))
|
|
(x 2)
|
|
(y 2))
|
|
(map (lambda (c.b)
|
|
(let ((r (make-rectangle x y bwidth bheight)))
|
|
(set! x (+ x bwidth 2))
|
|
(cons (cdr c.b) r)))
|
|
alist)))))
|
|
|
|
(define (pager-refit-buttons pager)
|
|
(for-each (lambda (b.r)
|
|
(move-resize-button (car b.r) (cdr b.r)))
|
|
(pager-button-rects pager)))
|
|
|
|
;; "external functions"
|
|
|
|
(define (pager-refit pager)
|
|
(let ((r (calc-pager-rect (pager:wm pager))))
|
|
(set-pager:width! pager (rectangle:width r))
|
|
(move-resize-window (pager:dpy pager) (pager:window pager)
|
|
(rectangle:x r) (rectangle:y r)
|
|
(rectangle:width r) (rectangle:height r))
|
|
(pager-refit-buttons pager)))
|
|
|
|
(define (pager-add-client pager client)
|
|
(send (pager:in-channel pager)
|
|
(list 'add-client client)))
|
|
|
|
(define (pager-remove-client pager client)
|
|
(send (pager:in-channel pager)
|
|
(list 'remove-client client)))
|
|
|
|
(define (pager-update-button pager button client)
|
|
(if (eq? (client:wm-state client)
|
|
(wm-state iconic))
|
|
(button-set-state! button 'down)
|
|
(button-set-state! button 'up))
|
|
(button-set-content! button
|
|
(client-name (pager:dpy pager) client)))
|
|
|
|
(define (pager-update-client pager client)
|
|
(let ((button (assq/false client (pager:buttons-alist pager))))
|
|
(if button
|
|
(pager-update-button pager button client)
|
|
(warn "pager-update-client: unknown client" pager client))))
|
|
|
|
(define (pager-update pager)
|
|
(for-each (lambda (c.b)
|
|
(let ((client (car c.b))
|
|
(button (cdr c.b)))
|
|
(pager-update-button pager button client)))
|
|
(pager:buttons-alist pager)))
|
|
|
|
(define (pager-change-visibility pager)
|
|
(set-pager:visible! pager (not (pager:visible? pager)))
|
|
(if (not (pager:visible? pager))
|
|
(unmap-window (pager:dpy pager) (pager:window pager))
|
|
(map-window (pager:dpy pager) (pager:window pager))))
|