199 lines
6.4 KiB
Scheme
199 lines
6.4 KiB
Scheme
(define-options-spec move-wm-options-spec
|
|
(titlebar-colors colors '("#aaaaaa" "#eeeeee" "#777777" "black"))
|
|
(titlebar-colors-active colors '("#666699" "#aaaacc" "#333366" "#eeeeee"))
|
|
(titlebar-height int 18)
|
|
(titlebar-style symbol 'flat)
|
|
(font font "-*-helvetica-medium-r-normal-*-12-*-*-*-*-*-*-*")
|
|
(border-width int 3)
|
|
(corner-width int 10)
|
|
(border-style symbol 'raised) ;; raised | sunken | flat
|
|
(border-colors colors '("#333333" "#dddddd"))
|
|
(kill-client keys "M-c")
|
|
)
|
|
|
|
(define (create-move-wm out-channel dpy parent options . children)
|
|
(create-wm dpy parent options children
|
|
(manager-type move) move-wm-options-spec
|
|
out-channel
|
|
(lambda (wm in-channel)
|
|
(spawn (lambda ()
|
|
(move-wm-handler wm in-channel)))
|
|
wm)))
|
|
|
|
(define (move-wm-handler wm channel)
|
|
(let ((gc (create-gc (wm:dpy wm) (wm:window wm) '())))
|
|
(let loop ()
|
|
(let ((msg (receive channel)))
|
|
(case (car msg)
|
|
((draw-main-window) #t)
|
|
|
|
((fit-windows)
|
|
(map (lambda (client)
|
|
(assert-client-visible wm client))
|
|
(wm-clients wm)))
|
|
|
|
((init-client)
|
|
(init-client wm (second msg) (third msg)))
|
|
((deinit-client)
|
|
(deinit-client wm (second msg)))
|
|
|
|
((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)))
|
|
|
|
((update-client-state)
|
|
(let* ((client (second msg))
|
|
(dpy (wm:dpy wm))
|
|
(window (client:window client))
|
|
(state (if (window-contains-focus? dpy window)
|
|
'active
|
|
'normal))
|
|
(titlebar (car (client:data client)))
|
|
(name (client-name (wm:dpy wm) client)))
|
|
(set-titlebar-state! titlebar state)
|
|
(set-titlebar-title! titlebar name)))
|
|
))
|
|
(loop))
|
|
(free-gc (wm:dpy wm) gc)))
|
|
|
|
(define (init-client wm client maybe-rect)
|
|
(let ((dpy (wm:dpy wm)))
|
|
(set-window-border-width! dpy (client:window client) 0)
|
|
(let* ((r (initial-client-rect wm (client:window client) maybe-rect))
|
|
(channel (make-channel))
|
|
(titlebar (create-client-titlebar channel wm client))
|
|
(resizer (create-resizer wm client))
|
|
(options (wm:options wm)))
|
|
(set-client:data! client (list titlebar resizer))
|
|
(move-resize-window dpy (client:client-window client)
|
|
(rectangle:x r) (rectangle:y r)
|
|
(rectangle:width r) (rectangle:height r))
|
|
(fit-client-windows 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) ;; -> manager.scm ??
|
|
(spawn
|
|
(lambda ()
|
|
(let loop ()
|
|
(select*
|
|
(wrap (receive-rv channel)
|
|
(lambda (msg)
|
|
(case (car msg)
|
|
((drop)
|
|
;; TODO: check if outside...
|
|
(move-window dpy (client:client-window client)
|
|
(second msg) (third msg)))
|
|
((kill-client)
|
|
(let ((time (second msg)))
|
|
(delete-window dpy (client:window client) time)))))))
|
|
;; 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) (client:client-window client)
|
|
(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-active))
|
|
(cons 'border-style
|
|
(get-option options 'titlebar-style))))))
|
|
|
|
(define (deinit-client wm client)
|
|
(let ((dpy (wm:dpy wm)))
|
|
#t))
|
|
|
|
;; ***
|
|
|
|
(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
|
|
(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
|
|
(car (client:data 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))
|
|
(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)))
|
|
#t)) ;; ... TODO
|
|
|
|
(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 win maybe-rect)
|
|
(if maybe-rect
|
|
maybe-rect
|
|
(let* ((dpy (wm:dpy wm))
|
|
(w.h (desired-size/hints dpy win
|
|
(maximal-size/hints dpy win 400 200)))
|
|
(x.y (desired-position/hints dpy win (cons 0 0))))
|
|
(make-rectangle (car x.y) (cdr x.y)
|
|
(car w.h) (cdr w.h)))))
|
|
|