diff --git a/src/move-wm-icon.scm b/src/move-wm-icon.scm new file mode 100644 index 0000000..7881443 --- /dev/null +++ b/src/move-wm-icon.scm @@ -0,0 +1,86 @@ +(define-record-type icon :icon + (make-icon wm client window) + icon? + (wm icon:wm) + (client icon:client) + (window icon:window)) + +(define (create-icon wm client rect) + (let* ((dpy (wm:dpy wm)) + (window (create-simple-window dpy (wm:window wm) + (rectangle:x rect) (rectangle:y rect) + (rectangle:width rect) + (rectangle:height rect) + 0 + (black-pixel dpy) (white-pixel dpy))) + (gc (create-gc dpy window + (make-gc-value-alist + (foreground (black-pixel dpy)) + (background (white-pixel dpy)))))) + (spawn* + (list 'move-wm-icon wm client window) + (lambda (release) + (call-with-current-continuation + (lambda (exit) + (call-with-event-channel + dpy window (event-mask exposure + structure-notify + button-press) + (lambda (event-channel) + (release) + (let loop () + (let ((xevent (receive event-channel))) + (cond + ((destroy-window-event? xevent) (exit 'destroyed)) + + ((expose-event? xevent) + (if (= 0 (expose-event-count xevent)) + (draw-icon dpy window gc client))) + + ((and (button-event? xevent) + (eq? (event-type button-press) + (button-event-type xevent))) + (send (wm:internal-out-channel wm) + (list 'normalize-client client)) + (exit 'normalized))) + (loop))))))) + (free-gc dpy gc))) + (make-icon wm client window))) + +(define (map-icon icon) + (map-window (wm:dpy (icon:wm icon)) (icon:window icon))) + +(define (destroy-icon icon) + (destroy-window (wm:dpy (icon:wm icon)) (icon:window icon))) + +(define (draw-icon dpy window gc client) + (let ((title (client-name dpy client)) ;; or WM_ICON_NAME ?? + (r (clip-rectangle dpy window))) + (draw-image-string dpy window gc 2 14 title))) + +(define (find-icon-rect wm-rect icons) + (let* ((icon-w 200) + (icon-h 18) + (xs (iota (quotient (rectangle:width wm-rect) icon-w))) + (ys (reverse (iota (quotient (rectangle:height wm-rect) icon-h)))) + (all (flatten (map (lambda (yi) + (map (lambda (xi) + (make-rectangle (* xi icon-w) + (* yi icon-h) + icon-w icon-h)) + xs)) + ys))) + (icon-rects (map (lambda (i) + (window-rectangle (wm:dpy (icon:wm i)) + (icon:window i))) + icons)) + (free (filter (lambda (r) + (not (any (lambda (ir) + (rectangles-overlap? r ir)) + icon-rects))) + all))) + (if (null? free) + (if (null? all) + (make-rectangle 0 0 icon-w icon-h) + (car all)) + (car free)))) diff --git a/src/move-wm.scm b/src/move-wm.scm index 1b9b6e5..9abcd4b 100644 --- a/src/move-wm.scm +++ b/src/move-wm.scm @@ -12,7 +12,9 @@ (define (create-move-wm out-channel dpy parent options default-options . children) - (create-wm dpy parent options default-options children + (create-wm dpy parent options (append default-options + '((focus-policy . (click)))) + children (manager-type move) move-wm-options-spec out-channel (lambda (wm in-channel) @@ -77,6 +79,33 @@ (append (make-window-change-alist (border-width 0)) changes)))) + + ((iconify-client) + (let ((client (second msg))) + (if (not (client-data:icon client)) + (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) + (let ((icon (create-client-icon wm client))) + (set-client-data:icon! client icon) + (map-icon icon)))))) + + ((maximize-client) + (let ((client (second msg))) + (maximize-window dpy (client:client-window client)))) + + ((normalize-client) + (let ((client (second msg))) + (if (client-data:icon client) + (begin + (destroy-icon (client-data:icon client)) + (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-data:icon! client #f))))) ((draw-client-window) (draw-client-window wm (second msg) gc)) @@ -97,17 +126,41 @@ (state (if focused? 'focused 'normal)) - (titlebar (car (client:data client)))) + (titlebar (client-data:titlebar client))) (set-titlebar-state! titlebar state))) ((update-client-name) (let ((client (second msg)) (name (third msg))) - (let ((titlebar (car (client:data client)))) + (let ((titlebar (client-data:titlebar client))) (set-titlebar-title! titlebar name)))) + + ((show-clients) + (let ((clients (second msg))) + (for-each (lambda (c) + (if (client-data:icon c) + (handle-message wm gc exit + (list 'normalize-client c))) + (raise-window dpy (client:client-window c))) + clients))) (else (warn "unhandled move-wm message" wm msg))))) +(define (make-client-data titlebar resizer icon) + (list titlebar resizer icon)) + +(define (client-data:titlebar client) + (first (client:data client))) + +(define (client-data:resizer client) + (second (client:data client))) + +(define (client-data:icon client) + (third (client:data client))) + +(define (set-client-data:icon! client icon) + (set-car! (cddr (client:data client)) icon)) + (define (init-client wm client maybe-rect) (let ((dpy (wm:dpy wm))) (let* ((r (initial-client-rect wm (client:window client) maybe-rect)) @@ -115,7 +168,7 @@ (titlebar (create-client-titlebar channel wm client)) (resizer (create-resizer wm client)) (options (wm:options wm))) - (set-client:data! client (list titlebar resizer)) + (set-client:data! client (make-client-data titlebar resizer #f)) (set-titlebar-title! titlebar (client-name dpy client)) (let ((bw (get-option-value options 'border-width)) (th (get-option-value options 'titlebar-height))) @@ -155,6 +208,10 @@ ;; 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)) @@ -169,7 +226,7 @@ (let ((options (wm:options wm))) (create-titlebar channel (wm:dpy wm) (client:client-window client) (wm:colormap wm) - (list (cons 'buttons '(kill maximize)) + (list (cons 'buttons '(kill maximize iconify)) (cons 'normal-colors (get-option options 'titlebar-colors)) (cons 'active-colors @@ -181,7 +238,14 @@ (define (deinit-client wm client) (let ((dpy (wm:dpy wm))) - #t)) + (set-input-focus dpy (wm:window wm) (revert-to parent) current-time))) + +(define (create-client-icon wm client) + (let* ((other-icons (filter (lambda (x) x) + (map client-data:icon (wm-clients wm)))) + (r (find-icon-rect (clip-rectangle (wm:dpy wm) (wm:window wm)) + other-icons))) + (create-icon wm client r))) ;; *** @@ -201,7 +265,7 @@ (- (window-attribute:height wa) (+ (* 2 border-width) titlebar-height)))) (move-resize-titlebar - (car (client:data client)) + (client-data:titlebar client) (make-rectangle border-width border-width (- (window-attribute:width wa) (* 2 border-width)) titlebar-height)))) @@ -223,8 +287,14 @@ (let* ((dpy (wm:dpy wm)) (win (client:client-window client)) (x (window-x dpy win)) - (y (window-y dpy win))) - #t)) ;; ... TODO + (y (window-y dpy win)) + (w (window-width (wm:window wm))) + (h (window-height (wm:window wm)))) + ;; TODO: assert-icon-visible ... + (if (>= x w) + (set-window-x! win (- w 10))) + (if (>= y h) + (set-window-y! win (- h 10))))) (define (draw-client-window wm client gc) (let* ((options (wm:options wm)) @@ -267,7 +337,15 @@ (w.h-2 (maximal-size/hints dpy win (car w.h-1) (cdr w.h-1))) (w.h (desired-size/hints dpy win w.h-2)) ;; TODO: look for a free position ?! Transients centered? - (x.y (desired-position/hints dpy win (cons 0 0)))) + (maybe-x.y (find-free-position wm w.h (cons 0 0))) + (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 (find-free-position wm 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))) + default-pos)) ;; TODO diff --git a/src/split-wm.scm b/src/split-wm.scm index 79c1603..c69fc92 100644 --- a/src/split-wm.scm +++ b/src/split-wm.scm @@ -109,6 +109,8 @@ (or first-client second-client)) (let ((r (client:window (or first-client second-client)))) (send (wm:out-channel wm) (list 'destroy-wm wm r))))))) + + ((iconfiy-client maximize-client) #t) ((draw-client-window) #t) @@ -138,6 +140,8 @@ (if (data:second-client data) (wm-select-client wm (data:second-client data) time)))) + ((show-clients) #t) + (else (warn "unhandled split-wm message" wm msg))))) (define (calc-rectangles wm) diff --git a/src/switch-wm.scm b/src/switch-wm.scm index 0f6d9de..8fd52d2 100644 --- a/src/switch-wm.scm +++ b/src/switch-wm.scm @@ -89,6 +89,8 @@ ((deinit-client) (deinit-client wm data (second msg))) + ((iconify-client maximize-client) #t) + ((configure-window) (let ((window (second msg)) (changes (third msg))) @@ -144,6 +146,15 @@ ((select-next) (select-next-client wm (second msg))) ((select-previous) (select-previous-client wm (second msg))) + ((show-clients) + (let ((clients (second msg))) + ;; it's a list of a client and it's transients. + (let ((cc (wm-current-client wm)) + (top (last clients))) + (if (and cc (window-mapped? dpy (client:client-window cc))) + (unmap-window dpy (client:client-window cc))) + (map-window dpy (client:client-window top))))) + (else (warn "unhandled switch-wm message" wm msg))))) (define (fit-titlebars wm data) @@ -222,7 +233,7 @@ (map-titlebar titlebar) (if (window-exists? dpy (client:window client)) (map-window dpy (client:window client))) - (map-window dpy (client:client-window client))))) + (wm-select-client wm client current-time)))) (define (create-client-titlebar channel wm client) (let ((options (wm:options wm))) @@ -263,7 +274,12 @@ (data:titlebars data))) (if tb (destroy-titlebar tb)) (fit-titlebars wm data) - (update-titlebars wm data))) + (update-titlebars wm data) + (if (eq? client (wm-current-client wm)) + (if (null? (wm-clients wm)) + (set-input-focus dpy (wm:window wm) (revert-to parent) + current-time) + (wm-select-client wm (car (wm-clients wm)) current-time))))) ;; ***