Skip to content

Commit

Permalink
Add ability to start and stop the tiling wm and tinywm
Browse files Browse the repository at this point in the history
  • Loading branch information
@mwitmer
mwitmer committed Oct 15, 2014
1 parent 30c32e1 commit 1e3114c
Show file tree
Hide file tree
Showing 3 changed files with 121 additions and 56 deletions.
36 changes: 22 additions & 14 deletions module/guile-wm/module/magnetic.scm
View file
Original file line number Diff line number Diff line change
Expand Up @@ -15,23 +15,31 @@

(define-module (guile-wm module magnetic)
#:use-module (guile-wm shared)
#:use-module (srfi srfi-2)
#:use-module (xcb xml)
#:use-module (xcb xml xproto)
#:use-module (xcb event-loop))

(use-wm-modules tinywm tiling)

(wm-init
(lambda ()
(add-wm-hook!
tinywm-drag-end-hook
(lambda (win)
(with-replies ((geom get-geometry win))
(let ((new-tile (tile-at (xref geom 'x) (xref geom 'y))))
(if (not (xid= blank-x-window win))
(move-tile selected-tile new-tile))))))
(add-wm-hook!
tinywm-resize-end-hook
(lambda (win)
(let ((tile (tile-for win)))
(move-tile tile tile))))))
(define (fit-to-bounds wind)
(and-let* ((tile (tile-for win)))
(move-tile tile tile)))

(define (snap-to-tile win)
(with-replies ((geom get-geometry win))
(and-let* ((new-tile (tile-at (xref geom 'x) (xref geom 'y)))
((tile-for win)))
(if (not (xid= blank-x-window win))
(move-tile selected-tile new-tile)))))

(define (start-magnetic!)
(add-wm-hook! tinywm-drag-end-hook snap-to-tile)
(add-wm-hook! tinywm-resize-end-hook fit-to-bounds))

(define (stop-magnetic!)
(remove-wm-hook! tinywm-drag-end-hook snap-to-tile)
(remove-wm-hook! tinywm-resize-end-hook fit-to-bounds))

(add-wm-hook! stop-tiling-hook stop-magnetic!)
(add-wm-hook! start-tiling-hook start-magnetic!)
101 changes: 72 additions & 29 deletions module/guile-wm/module/tiling.scm
View file
Original file line number Diff line number Diff line change
Expand Up @@ -33,11 +33,12 @@
#:use-module (xcb xml)
#:use-module ((xcb xml xproto)
#:select (unmap-window map-window get-geometry configure-window
destroy-window
destroy-notify-event allow-events
change-window-attributes
button-press-event unmap-notify-event
get-window-attributes))
#:export (blank-x-window selected-tile))
#:export (blank-x-window selected-tile start-tiling-hook stop-tiling-hook))

;;; Commentary:
;; This is a tiling window manager for guile-wm. It provides support
Expand Down Expand Up @@ -91,6 +92,9 @@
;; This is the master list of frames
(define-once frame-list #f)

(define-once stop-tiling-hook (make-wm-hook))
(define-once start-tiling-hook (make-wm-hook))

;; Helper procedures for managing tiles and splits

(define (container-of el)
Expand Down Expand Up @@ -262,6 +266,17 @@
(if x-window (fit-x-window! x-window tile))
(if select? (select-tile tile)))

(define (place-windows!)
(if (reparented-windows)
(map
(lambda (win)
(define parent (window-parent win))
(with-replies ((geom get-geometry parent))
(define x (xref geom 'x))
(define y (xref geom 'y))
(place-window! parent (tile-at x y) #t)))
(reparented-windows))))

(define (fit-x-window! x-window tile)
(define geom (reply-for get-geometry x-window))
(define hints (window-size-hints x-window))
Expand Down Expand Up @@ -383,36 +398,64 @@
(select-tile win))
(allow-events 'replay-pointer (xref button-press 'time)))

(define (non-tiling-click-to-focus button-press)
(define win (xref button-press 'event))
(configure-window (window-parent win) #:stack-mode 'above)
(set-focus win)
(allow-events 'replay-pointer (xref button-press 'time)))

(define (tiling-unmap event parent)
(discard-hidden-x-window! parent)
(and-let* ((tile (tile-for parent)))
(set-tile-window! tile #f)
(and-let* ((recent (most-recent-x-window)))
(place-window! recent tile))
(if (eq? tile selected-tile) (select-tile tile))))

(define (tiling-reparent child parent) (place-window! parent selected-tile #t))

(define (make-parent) (basic-window-create 0 0 1 1 2))

(define-command (start-tiling!)
(set! frame-list (detect-frames))
(set! blank-x-window (basic-window-create 0 0 200 20 2))
(change-window-attributes blank-x-window #:back-pixmap 'parent-relative)
(place-windows!)
(set! selected-tile (frame-content (car frame-list)))
(add-wm-hook! screen-change-hook reset-frames)
(add-wm-hook! menu-select-window-hook tiling-menu-select-window)
(add-wm-hook! unmap-notify-hook tiling-unmap)
(add-wm-hook! after-reparent-hook tiling-reparent)
(run-wm-hook start-tiling-hook)
(with-replies ((attributes get-window-attributes (current-root)))
(change-window-attributes (current-root)
#:event-mask (cons 'button-press (xref attributes 'your-event-mask)))
(change-window-attributes (current-root)
#:event-mask (cons 'button-press (xref attributes 'your-event-mask)))
(unlisten! button-press-event 'click-to-focus)
(listen! button-press-event 'click-to-focus tiling-click-to-focus)))

(define-command (stop-tiling!)
(remove-wm-hook! after-reparent-hook tiling-reparent)
(remove-wm-hook! unmap-notify-hook tiling-unmap)
(remove-wm-hook! menu-select-window-hook tiling-menu-select-window)
(set! selected-tile #f)
(destroy-window blank-x-window)
(set! blank-x-window #f)
(set! frame-list #f)
(with-replies ((attributes get-window-attributes (current-root)))
(change-window-attributes (current-root)
#:event-mask (delq 'button-press (xref attributes 'your-event-mask)))
(change-window-attributes (current-root)
#:event-mask (delq 'button-press (xref attributes 'your-event-mask)))
(unlisten! button-press-event 'click-to-focus)
(listen! button-press-event 'click-to-focus non-tiling-click-to-focus))
(run-wm-hook stop-tiling-hook))

(wm-init
(lambda ()
(define (make-parent) (basic-window-create 0 0 1 1 2))
(set! frame-list (detect-frames))
(set! blank-x-window (basic-window-create 0 0 200 20 2))
(change-window-attributes blank-x-window #:back-pixmap 'parent-relative)
(set! selected-tile (frame-content (car frame-list)))
(listen! button-press-event 'click-to-focus tiling-click-to-focus)
(add-wm-hook! screen-change-hook reset-frames)
(add-wm-hook! menu-select-window-hook tiling-menu-select-window)
(add-wm-hook!
after-reparent-hook
(lambda (child parent)
(place-window! parent selected-tile #t)
(add-wm-hook!
unmap-notify-hook
(lambda (event parent)
(discard-hidden-x-window! parent)
(and-let* ((tile (tile-for parent)))
(set-tile-window! tile #f)
(and-let* ((recent (most-recent-x-window)))
(place-window! recent tile))
(if (eq? tile selected-tile) (select-tile tile)))))))
;; Start redirecting map/configure/circulate requests right away so
;; that we don't miss any of them
(solicit
(with-replies ((attributes get-window-attributes (current-root)))
(change-window-attributes (current-root)
#:event-mask (cons 'button-press (xref attributes 'your-event-mask)))
(solicit (begin-reparent-redirect! make-parent 0 0 #f #f))))))
(start-tiling!)
(begin-reparent-redirect! make-parent 0 0 #f #f)))

;; This does the initial work of detecting the frames

Expand Down
40 changes: 27 additions & 13 deletions module/guile-wm/module/tinywm.scm
View file
Original file line number Diff line number Diff line change
Expand Up @@ -14,10 +14,13 @@
;; along with Guile-WM. If not, see <http://www.gnu.org/licenses/>.

(define-module (guile-wm module tinywm)
#:use-module (ice-9 receive)
#:use-module (guile-wm shared)
#:use-module (guile-wm command)
#:use-module (guile-wm log)
#:use-module (guile-wm focus)
#:use-module (guile-wm draw)
#:use-module (guile-wm reparent)
#:use-module (guile-wm module randr)
#:use-module (xcb xml xproto)
#:use-module (xcb event-loop)
Expand All @@ -27,6 +30,7 @@
(define win (make-parameter #f))
(define screen-height (make-parameter #f))
(define screen-width (make-parameter #f))
(define stop-proc #f)

(define-public tinywm-drag-end-hook (make-wm-hook 1))
(define-public tinywm-resize-end-hook (make-wm-hook 1))
Expand All @@ -35,10 +39,10 @@
(with-replies ((point query-pointer (current-root)) (geom get-geometry (win)))
(define (box p g s) (if (> (+ p g) s) (- s g) p))
(if (eq? (action) 'move)
(configure-window (win)
(configure-window (window-parent (win))
#:x (box (xref point 'root-x) (xref geom 'width) (screen-width))
#:y (box (xref point 'root-y) (xref geom 'height) (screen-height)))
(configure-window (win)
(configure-window (window-parent (win))
#:width (max 1 (- (xref point 'root-x) (xref geom 'x)))
#:height (max 1 (- (xref point 'root-y) (xref geom 'y)))))))

Expand All @@ -56,7 +60,8 @@
(xref (current-screen) 'height-in-pixels))))
(screen-width (car dimens))
(screen-height (cdr dimens))
(configure-window window #:stack-mode 'above)
(configure-window (window-parent window) #:stack-mode 'above)
(set-focus window)
(with-replies ((geom get-geometry window))
(cond
((= (xref button-press 'detail) 1)
Expand All @@ -79,14 +84,23 @@
(unless (or (= (xid->integer (win)) 0) (fixed-window? (win)))
(on-window-click (win) button-press)))

(wm-init
(lambda ()
(create-listener ()
((motion-notify-event #:event (current-root)) => on-motion-notify)
((button-release-event #:event (current-root)) => on-button-release)
((button-press-event #:event (current-root)) => on-button-press))
(define-command (start-tinywm!)
(receive (stop! reset!)
(create-listener ()
((motion-notify-event #:event (current-root)) => on-motion-notify)
((button-release-event #:event (current-root)) => on-button-release)
((button-press-event #:event (current-root)) => on-button-press))
(set! stop-proc stop!))

(grab-button #f (current-root) '(button-press button-release) 'async 'async
(current-root) (xcb-none xcursor) '#{1}# '(#{1}#))
(grab-button #f (current-root) '(button-press button-release) 'async 'async
(current-root) (xcb-none xcursor) '#{3}# '(#{1}#))))
(grab-button #f (current-root) '(button-press button-release) 'async 'async
(current-root) (xcb-none xcursor) '#{1}# '(#{1}#))
(grab-button #f (current-root) '(button-press button-release) 'async 'async
(current-root) (xcb-none xcursor) '#{3}# '(#{1}#)))

(define-command (stop-tinywm!)
(if stop-proc (stop-proc))
(set! stop-proc #f)
(ungrab-button '#{1}# (current-root) '(#{1}#))
(ungrab-button '#{3}# (current-root) '(#{1}#)))

(wm-init start-tinywm!)

0 comments on commit 1e3114c

Please sign in to comment.