From e3e12d92f8a6d49535358e932f3169f6e7609b71 Mon Sep 17 00:00:00 2001 From: frese Date: Fri, 28 Mar 2003 01:40:16 +0000 Subject: [PATCH] first commit --- .gitignore | 28 +++ Makefile.in | 10 + configure.in | 5 + src/drag-window.scm | 134 ++++++++++++ src/key-grab.scm | 151 ++++++++++++++ src/main.scm | 21 ++ src/manager.scm | 358 ++++++++++++++++++++++++++++++++ src/move-wm-resizer.scm | 223 ++++++++++++++++++++ src/move-wm.scm | 198 ++++++++++++++++++ src/packages.scm | 139 +++++++++++++ src/root-manager.scm | 60 ++++++ src/split-wm.scm | 283 ++++++++++++++++++++++++++ src/switch-wm.scm | 240 ++++++++++++++++++++++ src/titlebar.scm | 122 +++++++++++ src/utils.scm | 439 ++++++++++++++++++++++++++++++++++++++++ 15 files changed, 2411 insertions(+) create mode 100644 .gitignore create mode 100644 Makefile.in create mode 100644 configure.in create mode 100644 src/drag-window.scm create mode 100644 src/key-grab.scm create mode 100644 src/main.scm create mode 100644 src/manager.scm create mode 100644 src/move-wm-resizer.scm create mode 100644 src/move-wm.scm create mode 100644 src/packages.scm create mode 100644 src/root-manager.scm create mode 100644 src/split-wm.scm create mode 100644 src/switch-wm.scm create mode 100644 src/titlebar.scm create mode 100644 src/utils.scm diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..da8168b --- /dev/null +++ b/.gitignore @@ -0,0 +1,28 @@ +# CVS default ignores begin +tags +TAGS +.make.state +.nse_depinfo +*~ +\#* +.#* +,* +_$* +*$ +*.old +*.bak +*.BAK +*.orig +*.rej +.del-* +*.a +*.olb +*.o +*.obj +*.so +*.exe +*.Z +*.elc +*.ln +core +# CVS default ignores end diff --git a/Makefile.in b/Makefile.in new file mode 100644 index 0000000..c70c0ad --- /dev/null +++ b/Makefile.in @@ -0,0 +1,10 @@ +SCX=@SCX@ +ORION-WM=orion-wm + +$(ORION-WM): Makefile + script=$(ORION-WM) && \ + echo '#!$(SCX) \\' > $$script && \ + echo "-lm `pwd`/src/packages.scm -m main -s" >> $$script && \ + echo '!#' >> $$script && \ + echo '(start)' >> $$script && \ + chmod 755 $$script diff --git a/configure.in b/configure.in new file mode 100644 index 0000000..4726ef1 --- /dev/null +++ b/configure.in @@ -0,0 +1,5 @@ +AC_INIT + AC_PATH_PROG(SCX, scx, /usr/local/bin/scx) + +AC_OUTPUT(Makefile) + diff --git a/src/drag-window.scm b/src/drag-window.scm new file mode 100644 index 0000000..5d76056 --- /dev/null +++ b/src/drag-window.scm @@ -0,0 +1,134 @@ +;; *** the draw window *********************************************** + +(define-record-type drag-window :drag-window + (make-drag-window dpy window) + drag-window? + (dpy dw:dpy) + (window dw:window)) + +(define (create-drag-window dpy dwindow) + (let* ((width (window-width dpy dwindow)) + (height (window-height dpy dwindow)) + (pixmap (create-pixmap dpy dwindow width height + (window-depth dpy dwindow))) + (gc (create-gc dpy pixmap + (make-gc-value-alist + (graphics-exposures #t) + (background (black-pixel dpy)) + (foreground (white-pixel dpy)) + (subwindow-mode (subwindow-mode include-inferiors))))) + ) + (copy-area dpy dwindow pixmap gc 0 0 width height 0 0) + ;; TODO: draw X shape over this now. + (free-gc dpy gc) + (let* ((rect (root-rectangle dpy dwindow)) + (window (create-simple-window dpy (default-root-window dpy) + (rectangle:x rect) (rectangle:y rect) + (rectangle:width rect) + (rectangle:height rect) + 0 (black-pixel dpy) + (black-pixel dpy))) + (gc (create-gc dpy window + (make-gc-value-alist + (tile pixmap) + (fill-style (fill-style tiled)) + (fill-rule (fill-rule even-odd)))))) + (set-window-override-redirect! dpy window #t) + (spawn* (lambda (release) + (call-with-event-channel + dpy window (event-mask exposure structure-notify) + (lambda (channel) + (release) + (map-window dpy window) + (fill-rectangle dpy window gc 0 0 width height) + (let loop () + (let ((xevent (receive channel))) + (cond + ((expose-event? xevent) + (if (= (expose-event-count xevent) 0) + (fill-rectangle dpy window gc 0 0 width height)) + (loop)) + ((destroy-window-event? xevent) + (free-gc dpy gc) + (free-pixmap dpy pixmap)) + (else (loop))))))))) + (make-drag-window dpy window)))) + +(define (destroy-drag-window dw) + (destroy-window (dw:dpy dw) (dw:window dw))) + +(define (move-drag-window dw x y) + (move-window (dw:dpy dw) (dw:window dw) x y)) + +;; *** control over the dragging ************************************* + +(define (install-dragging-control channel dpy click-window dragged-window) + (spawn* + (lambda (release) + (call-with-event-channel + dpy click-window + (event-mask button-press button-release + button-1-motion structure-notify) + (lambda (event-channel) + (release) + (letrec ((idle + (lambda () + (let ((xevent (receive event-channel))) + (cond + ((eq? (event-type button-press) + (any-event-type xevent)) + (trans (button-event-x xevent) + (button-event-y xevent))) + + ((destroy-window-event? xevent) #t) + (else (idle)))))) + (trans + (lambda (click-x click-y) + ;; if next event is motion-event it's a drag, if + ;; button-release then it's a click. + (let ((xevent (receive event-channel))) + (cond + ((eq? (event-type button-release) + (any-event-type xevent)) + (send channel (list 'click click-x click-y + (button-event-time xevent))) + (idle)) + ((motion-event? xevent) + (let ((r (root-rectangle dpy dragged-window)) + (dw (create-drag-window dpy + dragged-window))) + ;;(grab-server dpy) + (drag dw click-x click-y (rectangle:x r) + (rectangle:y r)))) + ((destroy-window-event? xevent) #t) + (else (trans click-x click-y)))))) + + (drag + (lambda (dwin click-x click-y win-x win-y) + (let ((xevent (receive event-channel))) + (cond + ((eq? (event-type button-release) + (any-event-type xevent)) + (let ((x (+ (window-x dpy dragged-window) + (- (button-event-x xevent) + click-x))) + (y (+ (window-y dpy dragged-window) + (- (button-event-y xevent) + click-y)))) + (destroy-drag-window dwin) + (send channel (list 'drop x y)) + ;;(ungrab-server dpy) + (idle))) + + ((motion-event? xevent) + (let ((x (motion-event-x xevent)) + (y (motion-event-y xevent))) + (move-drag-window dwin + (+ win-x (- x click-x)) + (+ win-y (- y click-y))) + (drag dwin click-x click-y win-x win-y))) + + ((destroy-window-event? xevent) #t) + (else + (drag dwin click-x click-y win-x win-y))))))) + (idle))))))) diff --git a/src/key-grab.scm b/src/key-grab.scm new file mode 100644 index 0000000..fe618d5 --- /dev/null +++ b/src/key-grab.scm @@ -0,0 +1,151 @@ +(define-record-type key-grab :key-grab + (make-key-grab window keys message channel override?) + key-grab? + (window key-grab:window) + (keys key-grab:keys) + (message key-grab:message) + (channel key-grab:channel) + (override? key-grab:override?)) + +(define (create-grab-server dpy) + (let ((in-channel (make-channel))) + (spawn + (lambda () + (let ((grabs '()) + (event-cache '())) + (let loop () + (let ((msg (receive in-channel))) + (case (car msg) + ((add-key-grab) + (let* ((key-grab (second msg)) + (first (car (key-grab:keys key-grab)))) + (set! grabs (cons key-grab grabs)) + (grab-key dpy (key:keycode first) + (key:modifiers first) (key-grab:window key-grab) + #f (grab-mode async) (grab-mode async)) + (spawn* (lambda (resume) + (call-with-event-channel + dpy (key-grab:window key-grab) + (event-mask key-press structure-notify) + (lambda (event-channel) + (resume) + (let loop () + (let ((e (receive event-channel))) + (cond + ((destroy-window-event? e) + (send in-channel (list 'remove-key-grab + key-grab))) + ((eq? (event-type key-press) + (any-event-type e)) + (send in-channel (list 'key-press e)) + (loop)) + (else (loop))))))))))) + ((remove-key-grab) + (let* ((key-grab (second msg)) + (first (car (key-grab:keys key-grab)))) + (if (window-exists? dpy (key-grab:window key-grab)) + (ungrab-key dpy (key:keycode first) + (key:modifiers first) + (key-grab:window key-grab))) + (set! grabs (filter (lambda (g) (not (eq? g key-grab))) + grabs)))) + ((key-press) + (let ((e (second msg)) + (events (filter (lambda (x) x) + (map weak-pointer-ref event-cache)))) + ;; because more of these can come in a row, we + ;; skip the ones already handled. + (if (memq e events) + #f + (begin + (set! event-cache + (map make-weak-pointer (cons e events))) + (let ((winner (do-grabs dpy grabs e))) + (if winner + (send (key-grab:channel winner) + (list (key-grab:message winner) + ;; this event ?? + (key-event-time e))))))))) + )) + (loop))))) + in-channel)) + +(define *grab-server* #f) +(define *grab-server-lock* (make-lock)) + +(define (grab-shortcut dpy window keys message channel override?) + ;; assert |keys| > 0 ?? + (with-lock *grab-server-lock* + (lambda () + (if (not *grab-server*) + (set! *grab-server* (create-grab-server dpy))))) + (let ((key-grab (make-key-grab window keys message channel override?))) + (send *grab-server* (list 'add-key-grab key-grab)) + key-grab)) + +;; unregister-key ?? + +(define (do-grabs dpy grabs event) + (let* ((path (reverse (window-path dpy (get-input-focus-window dpy)))) + (grabs (flatten + (filter + (lambda (x) x) + (map (lambda (win) + (filter + (lambda (grab) + (let ((first (car (key-grab:keys grab)))) + (and (equal? win (key-grab:window grab)) + (enum-set=? (key:modifiers first) + (key-event-state event)) + (equal? (key:keycode first) + (key-event-keycode event))))) + grabs)) + path)))) + (grabs-rests (map (lambda (g) + (cons g (cdr (key-grab:keys g)))) + grabs)) + (winner? (lambda (grabs-rests) + (let ((dones (map car (filter (lambda (grab-rest) + (null? (cdr grab-rest))) + grabs-rests)))) + (mdisplay "winner? dones: " dones "\n") + (let loop ((dones dones)) + (if (null? dones) + #f + (if (or (null? (cdr dones)) + (key-grab:override? (car dones))) + (car dones) + (loop (cdr dones))))))))) + (grab-keyboard dpy (default-root-window dpy) #f + (grab-mode async) (grab-mode async) ;; ?? + (key-event-time event)) + ;; Cursor ? + (let ((result + (call-with-event-channel + dpy (default-root-window dpy) (event-mask key-press) + (lambda (event-channel) + (let loop ((grabs-rests grabs-rests)) + (mdisplay "grabs-rests: " grabs-rests "\n") + (and (not (null? grabs-rests)) + (or (winner? grabs-rests) + (let ((e (receive event-channel))) + (cond + ((eq? (event-type key-press) + (any-event-type e)) + (let ((rest + (filter + (lambda (grab-rest) + (and (not (null? (cdr grab-rest))) + (let ((next (car (cdr grab-rest)))) + (enum-set=? (key:modifiers next) + (key-event-state e)) + (equal? (key:keycode next) + (key-event-keycode e))))) + grabs-rests))) + (loop (map (lambda (grab-rest) + (cons (car grab-rest) + (cdr (cdr grab-rest)))) + rest)))) + (else (loop grabs-rests))))))))))) + (ungrab-keyboard dpy current-time) + result))) diff --git a/src/main.scm b/src/main.scm new file mode 100644 index 0000000..0957530 --- /dev/null +++ b/src/main.scm @@ -0,0 +1,21 @@ +(define (start) + (apply orion-wm (command-line))) + +(define (orion-wm . args) + (let ((dpy (open-display))) + (synchronize dpy #t) + (init-sync-x-events dpy) + ;; for debugging: + (spawn (lambda () + (let loop ((se (most-recent-sync-x-event))) + (let ((e (sync-x-event-event se))) + (if (not (eq? e 'no-event)) + (display-event e)) + (loop (next-sync-x-event se (lambda (e) #t))))))) + + (let ((root-manager (create-root-wm dpy))) + (display "Orion-wm finished\n")))) + +(define (display-event e) + ;;(mdisplay "event: " (any-event-type e) " " (any-event-window e) "\n")) + #t) diff --git a/src/manager.scm b/src/manager.scm new file mode 100644 index 0000000..65ce92d --- /dev/null +++ b/src/manager.scm @@ -0,0 +1,358 @@ +(define-record-type wm :wm + (make-wm type in-channel out-channel internal-out-channel + dpy window colormap options + clients current-client) + wm? + (type wm:type) + (in-channel wm:in-channel) + (out-channel wm:out-channel) + (internal-out-channel wm:internal-out-channel) + (dpy wm:dpy) + (window wm:window) + (colormap wm:colormap) + (options wm:options) + (clients wm:clients set-wm:clients!) + (current-client wm:current-client set-wm:current-client!)) + +(define wm-clients wm:clients) +(define wm-current-client wm:current-client) + +(define-enumerated-type manager-type :manager-type + manager-type? manager-types manager-type-name manager-type-index + (split switch move)) + +(define (manager-name type) + (cond + ((eq? type (manager-type split)) "split-wm") + ((eq? type (manager-type switch)) "switch-wm") + ((eq? type (manager-type move)) "move-wm"))) + +(define focus-policy '(enter click)) ;; TODO: -> options + +(define (create-wm dpy parent options children + type options-spec out-channel fun) + (let* ((wa (get-window-attributes dpy parent)) + (main-window + (create-simple-window dpy parent 0 0 (window-attribute:width wa) + (window-attribute:height wa) + 0 (white-pixel dpy) (black-pixel dpy))) + (colormap (create-colormap dpy main-window + (window-attribute:visual wa) + (colormap-alloc none))) + (in-channel (make-channel)) + (internal-out-channel (make-channel)) + (wm (make-wm type in-channel out-channel internal-out-channel + dpy main-window colormap + (create-options dpy colormap options-spec options) + '() #f))) + + ;; set properties ************************************************ + (set-wm-name! dpy main-window + (string-list->property (list (manager-name type)))) + ;; icon ?? + ;; size-hints ?? + (set-wm-hints! dpy main-window + (make-wm-hint-alist (input? #t))) + ;; class-hint ?? + (set-wm-protocols! dpy main-window + (list (intern-atom dpy "WM_TAKE_FOCUS" #t))) + ;; TODO: Colormaps + + ;; spawn handlers ************************************************ + (spawn* (lambda (release) + (call-with-event-channel + (wm:dpy wm) (wm:window wm) + (event-mask structure-notify + enter-window + focus-change + exposure) + (lambda (event-channel) + (call-with-current-continuation + (lambda (exit) + (release) + (send internal-out-channel '(fit-windows)) ;; ?? + (let loop () + (select* + (wrap (receive-rv event-channel) + (lambda (xevent) + (handle-xevent wm exit xevent))) + (wrap (receive-rv (wm:in-channel wm)) + (lambda (msg) + (handle-external-message wm exit msg)))) + (loop)))))) + (free-colormap dpy colormap))) + + (for-each (lambda (window) + (wm-manage-window wm window)) + children) + (fun wm internal-out-channel))) + +(define (handle-xevent wm exit xevent) + (let ((main-window (wm:window wm)) + (dpy (wm:dpy wm)) + (internal-out-channel (wm:internal-out-channel wm)) + (type (any-event-type xevent))) + (cond + ((expose-event? xevent) + (send internal-out-channel '(draw-main-window))) + + ((configure-event? xevent) + (send internal-out-channel '(fit-windows))) + + ;; the manager got the focus (as a client) + ((client-message-event? xevent) + (let* ((p (client-message-event-property xevent)) + (type (property:type p))) + (if (equal? type (intern-atom dpy "WM_PROTOCOLS" #t)) + (let ((name (car (property:data p))) + (time (cadr (property:data p))) + (client (wm:current-client wm))) + (if (and client + (equal? name (intern-atom dpy "WM_TAKE_FOCUS" #t))) + (handle-external-message wm exit + (list 'select-client client time))) + )))) + + ))) + +(define (handle-external-message wm exit msg) + (let ((internal-out-channel (wm:internal-out-channel wm)) + (dpy (wm:dpy wm))) + (case (car msg) + ((manage-window) + (let* ((window (second msg)) + (client (create-client wm window))) + (set-wm:clients! wm (cons client (wm:clients wm))) + (send internal-out-channel + (list 'init-client client (third msg))) + (send internal-out-channel (list 'fit-client client)) + ;; sync ?? + (map-window dpy window) + (send internal-out-channel (list 'update-client-state client)))) + + ((unmanage-window) + (let* ((window (second msg)) + (client (find (lambda (c) + (eq? window (client:window c))) + (wm:clients wm)))) + (if client + (begin + (reparent-to-root dpy window) + (handle-external-message wm exit + (list 'deinit-client client)))))) + + ((destroy-manager) + ;; (send internal-out-channel '(deinit-manager)) + ;; sync ?? + (destroy-window dpy (wm:window wm))) + + ((deinit-client) + (let ((client (second msg))) + (set-wm:clients! wm (filter (lambda (c) (not (eq? c client))) + (wm:clients wm))) + (if (eq? (wm:current-client wm) client) + (set-wm:current-client! wm #f)) ;; select another ?? + (send (wm:internal-out-channel wm) (list 'deinit-client client)) + ;; sync ?? + (destroy-window dpy (client:client-window client)))) + + ((select-client) + (let ((client (second msg)) + (time (third msg))) + (set-wm:current-client! wm client) + (raise-window dpy (client:client-window client)) + (take-focus dpy (client:window client) time) +; (for-each (lambda (c) +; (if (not (eq? c client)) +; (grab-button dpy +; (button button1) (state-set) +; (client:client-window c) #f +; (event-mask button-press) +; (grab-mode async) (grab-mode async) +; none none))) +; (wm:clients wm)) + )) + + ))) + +(define (wm-deinit-client wm client) + (mdisplay "manager deinit-client\n") + (send (wm:in-channel wm) (list 'deinit-client client))) + +;; *** external messages ********************************************* + +(define (wm-manage-window wm window . rect) + (send (wm:in-channel wm) + (list 'manage-window window + (if (null? rect) + #f + (car rect)))) + ;; sync ?? + ) + +(define (wm-unmanage-window wm window) + (send (wm:in-channel wm) (list 'unmanage-window window))) + +(define (wm-select-client wm client time) + (send (wm:in-channel wm) (list 'select-client client time))) + +(define (destroy-wm wm) + (send (wm:in-channel wm) '(destroy-manager))) + +(define (send-root-drop wm window x y) + (send (wm:out-channel wm) (list 'root-drop window x y))) + +;; *** client ******************************************************** + +(define-record-type client :client + (make-client window client-window data) + client? + (window client:window) + (client-window client:client-window) + (data client:data set-client:data!)) + +(define (create-client wm window) + (mdisplay "creating client for " window "\n") + (let* ((dpy (wm:dpy wm)) + (client-window (create-simple-window dpy (wm:window wm) + 0 0 + (window-width dpy window) + (window-height dpy window) + 0 + (white-pixel dpy) + (black-pixel dpy))) + (client (make-client window client-window #f))) + (reparent-window dpy window client-window 0 0) + (create-client-handler wm client) + client)) + +(define (create-client-handler wm client) + (spawn* + (lambda (release) + (call-with-event-channel + (wm:dpy wm) (client:client-window client) + (event-mask exposure + enter-window + button-press + structure-notify + focus-change) + (lambda (client-window-channel) + (call-with-event-channel + (wm:dpy wm) (client:window client) + (event-mask property-change + structure-notify) + (lambda (client-channel) + (call-with-current-continuation + (lambda (exit) + (release) + (let loop () + (select* + (wrap (receive-rv client-window-channel) + (lambda (xevent) + (handle-client-window-xevent wm exit client xevent))) + (wrap (receive-rv client-channel) + (lambda (xevent) + (handle-client-xevent wm exit client xevent)))) + (loop))))))))))) + +(define (handle-client-window-xevent wm exit client xevent) + (let ((type (any-event-type xevent)) + (internal-out-channel (wm:internal-out-channel wm)) + (dpy (wm:dpy wm))) + (cond + ((expose-event? xevent) + (send internal-out-channel + (list 'draw-client-window client))) + ((configure-event? xevent) + (send internal-out-channel + (list 'fit-client client))) + ((or (focus-change-event? xevent) (circulate-event? xevent)) + ;; TODO: look at mode? or maybe only look at focus-in of the + ;; client, because the client-window never gets the focus + ;; anyway. + (if (window-exists? dpy (client:window client)) ;; TODO: not perfect + (send internal-out-channel + (list 'update-client-state client)))) + + ((eq? (event-type enter-notify) type) + (if (memq 'enter focus-policy) + (wm-select-client wm client (crossing-event-time xevent)))) + + ((eq? (event-type button-press) type) + (if (memq 'click focus-policy) + (wm-select-client wm client (button-event-time xevent)))) + + ((destroy-window-event? xevent) + (mdisplay "client-window destroyed\n") + (exit))))) + +(define (handle-client-xevent wm exit client xevent) + (let ((type (any-event-type xevent)) + (internal-out-channel (wm:internal-out-channel wm)) + (dpy (wm:dpy wm))) + (cond + ((property-event? xevent) + (let ((name (get-atom-name (property-event-display xevent) + (property-event-atom xevent)))) + (cond + ((equal? "WM_NAME" name) + (send internal-out-channel + (list 'update-client-state client))) + ;; TODO: respect NORMAL_HINTS change + ))) + ((configure-event? xevent) + ;; TODO: we have to prevent this event if changed the size on our own. + ;; --> XReconfigureWMWindow ?? + ;;(send internal-out-channel (list 'fit-client-window client)) + #t) + ((reparent-event? xevent) #t) +; (if (or (not (window-exists? dpy (client:window client))) +; (not (eq? (client:client-window client) +; (window-parent dpy (client:window client))))) +; (begin +; (mdisplay "manager " (wm:type wm) " reparented client\n") +; (wm-deinit-client wm client) +; (exit))) + ;; TODO: withdrawn-state etc. + ((destroy-window-event? xevent) + (mdisplay "destroy-window client\n") + (wm-deinit-client wm client) + (exit)) + ))) + +;; *** client names ************************************************** + +(define client-name + (let ((names '()) ;; (window oname name) + (lock (make-lock))) + (lambda (dpy client) + (let* ((w (client:window client)) + (cname (let* ((p (get-wm-name dpy w)) + (l (if p (property->string-list p) '()))) + (if (null? l) + "" + (car l))))) + (with-lock lock + (lambda () + (let ((name? (let ((p (assq w names))) + (and p (equal? (cadr p) cname) + (caddr p))))) + (set! names + (filter (lambda (e) + (and (not (eq? (car e) w)) + (window-exists? dpy (car e)))) + names)) + (let ((name (if name? name? + (unique-name cname + (map caddr names))))) + (set! names (cons (list w cname name) names)) + name)))))))) + +(define (unique-name name names) + (if (not (member name names)) + name + (let loop ((i 1)) + (let ((n (string-append name "<" (number->string i) ">"))) + (if (member n names) + (loop (+ i 1)) + n))))) diff --git a/src/move-wm-resizer.scm b/src/move-wm-resizer.scm new file mode 100644 index 0000000..7a9ecfd --- /dev/null +++ b/src/move-wm-resizer.scm @@ -0,0 +1,223 @@ +;; TODO: -> options ?? +(define default-cursor xc-X-cursor) +(define frame-size 3) + +(define (create-resizer wm client) + (let* ((dpy (wm:dpy wm)) + (window (client:client-window client)) + (gc (create-gc dpy (default-root-window dpy) + (make-gc-value-alist + (foreground (white-pixel dpy)) + (subwindow-mode (subwindow-mode include-inferiors)) + (line-width frame-size) + (function (gc-function xor))))) + (cursors + (map (lambda (dir id) + (cons dir (create-font-cursor dpy id))) + '(west north-west north north-east east south-east south + south-west none) + (list xc-left-side xc-top-left-corner xc-top-side + xc-top-right-corner xc-right-side xc-bottom-right-corner + xc-bottom-side xc-bottom-left-corner default-cursor)))) + + (spawn* + (lambda (release) + (call-with-event-channel + dpy window + (event-mask structure-notify + button-press button-release + pointer-motion) + (lambda (event-channel) + (release) + (letrec + ((idle + (lambda () + (let ((xevent (receive event-channel))) + (cond + ((motion-event? xevent) + (set-resize-cursor wm client cursors + (motion-event-x xevent) + (motion-event-y xevent)) + (idle)) + ((eq? (event-type button-press) + (any-event-type xevent)) + (let* ((x (button-event-x xevent)) + (y (button-event-y xevent)) + (dir (resizer-direction wm client x y))) + (if (eq? dir 'none) + (idle) + (let ((r (root-rectangle dpy window))) + (grab-server dpy) + (rubber-draw dpy gc r) + (drag x y r r dir))))) + ((destroy-window-event? xevent) #t) + (else (idle)))))) + + (drag + (lambda (start-x start-y start-r prev-rect dir) + (let ((xevent (receive event-channel))) + (cond + ((motion-event? xevent) + (let ((new-rect + (adjust-rect wm client start-r + (- (motion-event-x xevent) start-x) + (- (motion-event-y xevent) start-y) + dir))) + (rubber-draw dpy gc prev-rect) + (rubber-draw dpy gc new-rect) + (drag start-x start-y start-r new-rect dir))) + ((eq? (event-type button-release) + (any-event-type xevent)) + (rubber-draw dpy gc prev-rect) + (ungrab-server dpy) + (commit-resize wm client + (- (button-event-x xevent) start-x) + (- (button-event-y xevent) start-y) + dir) + (idle)) + ((destroy-window-event? xevent) #t) + (else (drag start-x start-y start-r + prev-rect dir))))))) + (idle)))) + (free-gc dpy gc) + (for-each (lambda (c) (free-cursor dpy (cdr c))) cursors))))) + +(define (rubber-draw dpy gc rect) + (draw-rectangle dpy (default-root-window dpy) gc + (rectangle:x rect) (rectangle:y rect) + (rectangle:width rect) (rectangle:height rect))) + +(define (adjust-rect wm client sr dx dy dir) + (let* ((r + (case dir + ((west) + (make-rectangle (+ (rectangle:x sr) dx) + (rectangle:y sr) + (- (rectangle:width sr) dx) + (rectangle:height sr))) + ((north-west) + (make-rectangle (+ (rectangle:x sr) dx) + (+ (rectangle:y sr) dy) + (- (rectangle:width sr) dx) + (- (rectangle:height sr) dy))) + ((north) + (make-rectangle (rectangle:x sr) + (+ (rectangle:y sr) dy) + (rectangle:width sr) + (- (rectangle:height sr) dy))) + ((north-east) + (make-rectangle (rectangle:x sr) + (+ (rectangle:y sr) dy) + (+ (rectangle:width sr) dx) + (- (rectangle:height sr) dy))) + ((east) + (make-rectangle (rectangle:x sr) + (rectangle:y sr) + (+ (rectangle:width sr) dx) + (rectangle:height sr))) + ((south-east) + (make-rectangle (rectangle:x sr) + (rectangle:y sr) + (+ (rectangle:width sr) dx) + (+ (rectangle:height sr) dy))) + ((south) + (make-rectangle (rectangle:x sr) + (rectangle:y sr) + (rectangle:width sr) + (+ (rectangle:height sr) dy))) + ((south-west) + (make-rectangle (+ (rectangle:x sr) dx) + (rectangle:y sr) + (- (rectangle:width sr) dx) + (+ (rectangle:height sr) dy))) + (else sr))) + (w.h (maximal-size/hints (wm:dpy wm) (client:window client) + (rectangle:width r) (rectangle:height r)))) + (set-rectangle:width! r (car w.h)) + (set-rectangle:height! r (cdr w.h)) + r)) + +(define (commit-resize wm client dx dy dir) + (let* ((dpy (wm:dpy wm)) + (win (client:client-window client)) + (sr (window-rectangle dpy win)) + (rect (adjust-rect wm client sr dx dy dir))) + (move-resize-window dpy win + (rectangle:x rect) + (rectangle:y rect) + (rectangle:width rect) + (rectangle:height rect)))) + +(define (set-resize-cursor wm client cursors x y) + (let* ((dpy (wm:dpy wm)) + (c (assq (resizer-direction wm client x y) cursors))) + (if c + (define-cursor dpy (client:client-window client) (cdr c))))) + +(define (resizer-direction wm client x y) + (let* ((dpy (wm:dpy wm)) + (win (client:client-window client)) + (width (window-width dpy win)) + (height (window-height dpy win)) + (corner-size (get-option (wm:options wm) 'corner-width)) + (fc-size (+ frame-size corner-size))) + (let ((region-alist + (list (cons 'west + (list (make-rectangle 0 fc-size frame-size + (- height (* 2 fc-size))))) + (cons 'north-west + (list (make-rectangle 0 frame-size frame-size + corner-size) + (make-rectangle 0 0 frame-size frame-size) + (make-rectangle frame-size 0 corner-size + frame-size))) + (cons 'north + (list (make-rectangle fc-size 0 (- width (* 2 fc-size)) + frame-size))) + (cons 'north-east + (list (make-rectangle (- width fc-size) 0 corner-size + frame-size) + (make-rectangle (- width frame-size) 0 + frame-size frame-size) + (make-rectangle (- width frame-size) frame-size + frame-size corner-size))) + (cons 'east + (list (make-rectangle (- width frame-size) fc-size + frame-size + (- height (* 2 fc-size))))) + (cons 'south-east + (list (make-rectangle (- width frame-size) + (- height fc-size) frame-size + corner-size) + (make-rectangle (- width frame-size) + (- height frame-size) + frame-size frame-size) + (make-rectangle (- width fc-size) + (- height frame-size) + corner-size frame-size))) + (cons 'south + (list (make-rectangle fc-size (- height frame-size) + (- width (* 2 fc-size)) + frame-size))) + (cons 'south-west + (list (make-rectangle frame-size + (- height frame-size) corner-size + frame-size) + (make-rectangle 0 (- width frame-size) + frame-size frame-size) + (make-rectangle 0 (- height fc-size) + frame-size corner-size)))))) + (let ((matches (filter (lambda (d.rs) + (any (lambda (r) + (point-in-rectangle? r x y)) + (cdr d.rs))) + region-alist))) + (if (null? matches) + 'none + (car (car matches))))))) + +(define (point-in-rectangle? r x y) + (and (>= x (rectangle:x r)) + (>= y (rectangle:y r)) + (< x (+ (rectangle:x r) (rectangle:width r))) + (< y (+ (rectangle:y r) (rectangle:height r))))) diff --git a/src/move-wm.scm b/src/move-wm.scm new file mode 100644 index 0000000..f782ebf --- /dev/null +++ b/src/move-wm.scm @@ -0,0 +1,198 @@ +(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))))) + diff --git a/src/packages.scm b/src/packages.scm new file mode 100644 index 0000000..b095ada --- /dev/null +++ b/src/packages.scm @@ -0,0 +1,139 @@ + +;; *** utils ********************************************************* +(define-structure utils + (export mdisplay assq/false flatten + select* spawn* with-lock + + create-options free-options + get-option-value get-option set-option! get-options + ((define-options-spec) :syntax) + + string->keys string->key key:keycode key:modifiers + + reparent-to-root window-path + window-viewable? + window-focused? + window-contains-focus? + take-focus delete-window + window-exists? + move-resize-window* + root-rectangle window-rectangle clip-rectangle + draw-shadow-rectangle + invalidate-window + text-center-pos + + maximize-window maximal-size/hints + size-window desired-size/hints desired-position/hints) + (open scheme i/o list-lib define-record-types finite-types enum-sets + threads locks placeholders rendezvous + signals handle + rx-syntax field-reader-package + xlib) + (files utils)) + +(define-structure dragging + (export install-dragging-control) + (open scheme define-record-types threads + rendezvous-channels rendezvous + xlib + utils) + (files drag-window)) + +(define-structure titlebar + (export create-titlebar destroy-titlebar titlebar? titlebar:window + map-titlebar unmap-titlebar move-resize-titlebar + set-titlebar-state! set-titlebar-title!) + (open scheme define-record-types threads list-lib + rendezvous-channels rendezvous + xlib + utils) + (files titlebar)) + +;; *** key-grab ****************************************************** + +(define-structure key-grab + (export grab-shortcut) + (open scheme define-record-types enum-sets weak + threads list-lib + rendezvous-channels rendezvous locks + xlib utils) + (files key-grab)) + +;; *** manager ******************************************************* + +(define-structure manager + (export wm? wm:type wm:dpy wm:window wm:colormap wm:options + (manager-type :syntax) manager-types manager-type-name + create-wm destroy-wm + wm-clients wm-current-client + + wm-manage-window wm-unmanage-window wm-select-client + + client? client:window client:client-window + client:data set-client:data! + client-name) + (open scheme threads list-lib locks + xlib + define-record-types + finite-types + rendezvous-channels + rendezvous + utils key-grab) + (files manager)) + +;; *** move manager ************************************************** + +(define-structure move-wm + (export create-move-wm) + (open scheme list-lib define-record-types + threads rendezvous-channels rendezvous + xlib + manager key-grab + utils dragging titlebar) + (files move-wm + move-wm-resizer)) + +;; *** split manager ************************************************* + +(define-structure split-wm + (export create-split-wm) + (open scheme list-lib define-record-types + threads rendezvous-channels rendezvous + xlib + manager + utils) + (files split-wm + split-wm-resizer)) + +;; *** switch manager ************************************************ + +(define-structure switch-wm + (export create-switch-wm) + (open scheme list-lib define-record-types + threads rendezvous-channels rendezvous + xlib + manager titlebar dragging + utils key-grab) + (files switch-wm)) + +;; *** main package ************************************************** + +(define-structure root-manager + (export root-wm? create-root-wm) + (open scheme + define-record-types + xlib + rendezvous rendezvous-channels + utils + manager + move-wm split-wm switch-wm + ) + (files root-manager)) + +(define-structure main + (export start) + (open scsh scheme threads + xlib + root-manager + utils) + (files main)) diff --git a/src/root-manager.scm b/src/root-manager.scm new file mode 100644 index 0000000..3364c5f --- /dev/null +++ b/src/root-manager.scm @@ -0,0 +1,60 @@ +(define-record-type root-wm :root-wm + (make-root-wm dpy managers current-manager) + root-wm? + (dpy root-wm:dpy) + (managers root-wm:managers set-root-wm:managers!) + (current-manager root-wm:current-manager set-root-wm:current-manager!)) + +(define (create-root-wm dpy) + (let* ((window (default-root-window dpy)) + (children (window-children dpy window)) + (in-channel (make-channel)) + (root-wm (make-root-wm dpy '() #f)) + (initial-manager (create-move-wm in-channel dpy window '()))) + (mdisplay "creating root-wm\n") + (set-root-wm:managers! root-wm (list initial-manager)) + (set-root-wm:current-manager! root-wm initial-manager) + + (map-window dpy (wm:window initial-manager)) + + (for-each (lambda (window) + (wm-manage-window initial-manager window)) + children) + ;;(create-move-wm in-channel dpy window '()) + + (call-with-event-channel + dpy window (event-mask substructure-redirect) + (lambda (event-channel) + (call-with-current-continuation + (lambda (exit) + (let loop () + (select* + (wrap (receive-rv event-channel) + (lambda (xevent) + (handle-xevent root-wm exit xevent))) + (wrap (receive-rv in-channel) + (lambda (msg) + (handle-message root-wm exit msg)))) + (loop)))))))) + +(define (handle-xevent root-wm exit xevent) + (let ((type (any-event-type xevent)) + (dpy (root-wm:dpy root-wm))) + (cond + ((configure-request-event? xevent) + ;; TODO: maybe let it configure by the future manager... + (configure-window dpy (configure-request-event-window xevent) + (configure-request-event-window-change-alist xevent))) + ((map-request-event? xevent) + (wm-manage-window (root-wm:current-manager root-wm) + (map-request-event-window xevent) + #f)) + ))) + +(define (handle-message root-wm exit msg) + 'none) + +;; *** observing managers ******************************************** + +(define (add-manager! manager) + #t) diff --git a/src/split-wm.scm b/src/split-wm.scm new file mode 100644 index 0000000..af41998 --- /dev/null +++ b/src/split-wm.scm @@ -0,0 +1,283 @@ +(define-options-spec split-wm-options-spec + (orientation symbol 'horizontal) ;; horizontal | vertical + (aspect number 1/1) + (bar-width int 3) + (resize-step int 5) + (bar-style symbol 'raised) ;; raised | sunken | flat + (bar-colors colors '("#dddddd" "#888888" "#333333")) + ) + +;; ---------- ---------- +;; | | | | | +;; ---------- vertical | | | horizontal +;; | | | | | +;; ---------- ---------- + +(define (create-split-wm external-in-channel dpy parent options . children) + (create-wm dpy parent options children + (manager-type split) split-wm-options-spec + external-in-channel + (lambda (wm in-channel) + (spawn (lambda () + (split-wm-handler wm in-channel))) + wm))) + +(define (split-wm-handler wm channel) + (let ((resizer-window (create-resizer wm))) + (map-window (wm:dpy wm) resizer-window) + (let loop () + (let ((msg (receive channel))) + (case (car msg) + ((draw-main-window) #t) + + ((fit-windows) + (fit-windows wm resizer-window)) + + ((init-client) + (init-client wm (second msg) (third msg))) + + ((deinit-client) + (deinit-client wm (second msg))) + + ((draw-client-window) #t) + + ((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) #t) + )) + (loop)))) + +;(define (draw-main-window wm gc) +; (let* ((dpy (wm:dpy wm)) +; (options (wm:options wm)) +; (colors (get-option-value options 'bar-colors)) +; (bar-style (get-option-value options 'bar-style)) +; (rects (calc-rectangles wm)) +; (bar-rect (second rects)) +; (win (wm:window wm)) +; (x1 (rectangle:x bar-rect)) +; (y1 (rectangle:y bar-rect)) +; (x2 (+ (rectangle:x bar-rect) (rectangle:width bar-rect) -1)) +; (y2 (+ (rectangle:y bar-rect) (rectangle:height bar-rect) -1))) +; (mdisplay "bar drawing: " bar-rect "\n") +; (set-gc-foreground! dpy gc (second colors)) +; (fill-rectangle dpy win gc x1 y1 +; (rectangle:width bar-rect) (rectangle:height bar-rect)) +; (if (and #f (not (eq? bar-style 'flat))) +; (let ((light (if (eq? bar-style 'raised) +; (first colors) +; (third colors))) +; (dark (if (eq? bar-style 'raised) +; (third colors) +; (first colors)))) +; (set-gc-line-width! dpy gc 1) +; (set-gc-foreground! dpy gc light) +; (draw-lines dpy win gc (list (cons x1 y2) (cons x1 y1) (cons x2 y1)) +; (coord-mode origin)) +; (set-gc-foreground! dpy gc dark) +; (draw-lines dpy win gc (list (cons x2 (+ y1 1)) (cons x2 y2) +; (cons x1 y2)) +; (coord-mode origin)))))) + +(define (calc-rectangles wm) + (let* ((options (wm:options wm)) + (bar-width (get-option-value options 'bar-width)) + (orientation (get-option-value options 'orientation)) + (aspect (get-option-value options 'aspect)) + (r (clip-rectangle (wm:dpy wm) (wm:window wm)))) + (mdisplay "calc-rects: aspect " aspect "\n") + (if (eq? orientation 'horizontal) + (let* ((r1 (make-rectangle 0 0 + (floor (/ (- (rectangle:width r) bar-width) + (+ 1 (/ 1 aspect)))) + (rectangle:height r))) + (r2 (make-rectangle (rectangle:width r1) 0 + bar-width (rectangle:height r))) + (r3 (make-rectangle (+ (rectangle:width r1) bar-width) 0 + (- (rectangle:width r) + (+ (rectangle:width r1) bar-width)) + (rectangle:height r)))) + (list r1 r2 r3)) + (let* ((r1 (make-rectangle 0 0 (rectangle:width r) + (floor (/ (- (rectangle:height r) bar-width) + (+ 1 (/ 1 aspect)))))) + (r2 (make-rectangle 0 (rectangle:height r1) + (rectangle:width r) bar-width)) + (r3 (make-rectangle 0 (+ (rectangle:height r1) bar-width) + (rectangle:width r) + (- (rectangle:height r) + (+ (rectangle:height r1) bar-width))))) + (list r1 r2 r3))))) + +(define (fit-windows wm resizer-window) + (let* ((rects (calc-rectangles wm)) + (clients (wm-clients wm)) + (dpy (wm:dpy wm))) + (mdisplay "splitter rects: " rects "\n") + (move-resize-window* dpy resizer-window (second rects)) + (if (and (pair? clients) (pair? (cdr clients))) + (move-resize-window* dpy + (client:client-window (second clients)) + (first rects))) + (if (pair? clients) + (move-resize-window* dpy + (client:client-window (first clients)) + (third rects))))) + +(define (init-client wm client maybe-rect) + (let* ((rects (calc-rectangles wm)) + (r (if (> (length (wm-clients wm)) 1) + (third rects) + (first rects)))) + (let ((dpy (wm:dpy wm)) + (options (wm:options wm))) + (set-window-border-width! dpy (client:window client) 0) + (move-resize-window* dpy (client:client-window client) r) + + (map-window dpy (client:client-window client)) + ;;(select-client wm client))) ?? + ))) + +(define (deinit-client wm client) + (let ((dpy (wm:dpy wm))) + ;; maybe destroy-wm ?? TODO + #t)) + +(define (fit-client-windows wm client) + (let ((dpy (wm:dpy wm))) + (maximize-window dpy (client:window client)))) + +(define (fit-client-window wm client) + #t) + +;; ******************************************************************* +;; Resizer +;; ******************************************************************* + +(define (create-resizer wm) + (let* ((dpy (wm:dpy wm)) + (main-window (wm:window wm)) + (options (wm:options wm)) + (window (create-simple-window dpy main-window 0 0 1 1 0 + (white-pixel dpy) (black-pixel dpy))) + (root (window-root dpy window)) + (gc (create-gc dpy window '())) + (root-gc (create-gc dpy window + (make-gc-value-alist + (function (gc-function xor)) + (subwindow-mode (subwindow-mode + include-inferiors))))) + (cursor (create-font-cursor + dpy (if (eq? (get-option-value options 'orientation) + 'horizontal) + xc-sb-h-double-arrow + xc-sb-v-double-arrow)))) + (set-window-cursor! dpy window cursor) + (spawn* + (lambda (release) + (call-with-event-channel + dpy window (event-mask structure-notify + exposure + button-press button-release + button-1-motion) + (lambda (event-channel) + (release) + (letrec + ((idle (lambda () + (let* ((e (receive event-channel)) + (type (any-event-type e))) + (cond + ((eq? (event-type button-press) type) + (let ((r (root-rectangle dpy window))) + (grab-server dpy) + (draw-resizer r) + (drag r r (button-event-x e) (button-event-y e)))) + ((expose-event? e) + (draw-resizer-window) + (idle)) + ((destroy-window-event? e) #t) + (else (idle)))))) + (drag (lambda (start-rect last-rect start-x start-y) + (let* ((e (receive event-channel)) + (type (any-event-type e))) + (cond + ((motion-event? e) + (draw-resizer last-rect) + (let ((new-rect (calc-new-rect + start-rect + (- (motion-event-x e) start-x) + (- (motion-event-y e) start-y)))) + (draw-resizer new-rect) + (drag start-rect new-rect start-x start-y))) + ((eq? (event-type button-release) type) + (draw-resizer last-rect) + (ungrab-server dpy) + (commit-resize (- (button-event-x e) start-x) + (- (button-event-y e) start-y)) + (idle)) + ((expose-event? e) + (draw-resizer-window) + (drag start-rect last-rect start-x start-y)) + ((destroy-window-event? e) #t) + (else + (drag start-rect last-rect start-x start-y)))))) + + (draw-resizer + (lambda (rect) + (draw dpy root root-gc rect))) + (draw-resizer-window + (lambda () + (draw dpy window gc (clip-rectangle dpy window)))) + (commit-resize + (lambda (dx dy) + ;; check if outside... TODO + (let* ((rects (calc-rectangles wm)) + (r1 (first rects)) (r2 (third rects)) + (aspect + (if (eq? 'horizontal + (get-option-value options 'orientation)) + (if (= 0 (- (rectangle:width r2) dx)) + 0 + (/ (+ (rectangle:width r1) dx) + (- (rectangle:width r2) dx))) + (if (= 0 (- (rectangle:height r2) dy)) + 0 + (/ (+ (rectangle:height r1) dy) + (- (rectangle:height r2) dy)))))) + (if (> aspect 0) + (begin + (set-option! options 'aspect aspect) + (fit-windows wm window)))))) + (calc-new-rect + (lambda (start-rect dx dy) + (let ((width (rectangle:width start-rect)) + (height (rectangle:height start-rect))) + (if (eq? (get-option-value options 'orientation) + 'horizontal) + (make-rectangle (+ (rectangle:x start-rect) dx) + (rectangle:y start-rect) + width height) + (make-rectangle (rectangle:x start-rect) + (+ (rectangle:y start-rect) dy) + width height))))) + (draw + (lambda (dpy window gc r) + (let ((colors (get-option-value options 'bar-colors))) + (set-gc-foreground! dpy gc (second colors)) + (fill-rectangle dpy window gc + (rectangle:x r) (rectangle:y r) + (rectangle:width r) (rectangle:height r)) + ;; Rest ?? + ))) + ) + (idle) + (free-cursor dpy cursor) + (free-gc dpy gc) + (free-gc dpy root-gc)))))) + window)) diff --git a/src/switch-wm.scm b/src/switch-wm.scm new file mode 100644 index 0000000..8a68018 --- /dev/null +++ b/src/switch-wm.scm @@ -0,0 +1,240 @@ +(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 "") + 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)) diff --git a/src/titlebar.scm b/src/titlebar.scm new file mode 100644 index 0000000..6d792ab --- /dev/null +++ b/src/titlebar.scm @@ -0,0 +1,122 @@ +(define-options-spec titlebar-options-spec + (buttons symbol-list '(kill)) ; iconize, maximize, roll + (normal-colors colors '("#aaaaaa" "#eeeeee" "#777777" "black")) + (active-colors colors '("#9999aa" "#eeeeff" "#777788" "black")) + (focused-colors colors '("#666699" "#aaaacc" "#333366" "#eeeeee")) + (border-style symbol 'raised) ; none | sunken + (font font "-*-helvetica-medium-r-normal-*-12-*-*-*-*-*-*-*") + (button-border-style symbol 'flat) ; none | raised + ) + +(define-record-type titlebar :titlebar + (make-titlebar channel dpy window title state) + titlebar? + (channel titlebar:channel) + (dpy titlebar:dpy) + (window titlebar:window) + (title titlebar:title set-titlebar:title!) + (state titlebar:state set-titlebar:state!)) ;; active | focused | normal + +(define (create-titlebar out-channel dpy parent colormap options-def) + (let* ((in-channel (make-channel)) + (window (create-simple-window dpy parent + 0 0 1 1 0 + (black-pixel dpy) (black-pixel dpy))) + (options (create-options dpy colormap titlebar-options-spec + options-def)) + (gc (create-gc dpy window '())) + (tb (make-titlebar in-channel dpy window "test" 'normal)) + ;; buttons... icon-window... + ) + (mdisplay "creating titlebar " window "\n") + (spawn* + (lambda (release) + (call-with-event-channel + dpy window (event-mask exposure structure-notify) + (lambda (event-channel) + (call-with-current-continuation + (lambda (exit) + (release) + (let loop () + (select* + (wrap (receive-rv event-channel) + (lambda (xevent) + (cond + ((expose-event? xevent) + (draw-titlebar tb options gc)) + ((destroy-window-event? xevent) + (exit))))) + (wrap (receive-rv in-channel) + (lambda (msg) + (case (car msg) + ((title) + (set-titlebar:title! tb (cdr msg)) + (invalidate-window dpy window)) + ((state) + (set-titlebar:state! tb (cdr msg)) + (invalidate-window dpy window))))) + ) + (loop)))))) + (free-gc dpy gc) + (free-options options))) + tb)) + +(define (destroy-titlebar tb) + (destroy-window (titlebar:dpy tb) (titlebar:window tb))) + +(define (map-titlebar tb) + (map-window (titlebar:dpy tb) (titlebar:window tb))) +; (send (titlebar:channel tb) '(map #f))) + +(define (unmap-titlebar tb) + (unmap-window (titlebar:dpy tb) (titlebar:window tb))) + +(define (move-resize-titlebar tb rect) + (move-resize-window (titlebar:dpy tb) (titlebar:window tb) + (rectangle:x rect) (rectangle:y rect) + (rectangle:width rect) (rectangle:height rect))) + +(define (set-titlebar-title! tb title) + (send (titlebar:channel tb) (cons 'title title))) + +(define (set-titlebar-state! tb state) + (send (titlebar:channel tb) (cons 'state state))) + +(define (draw-titlebar tb options gc) + (let ((dpy (titlebar:dpy tb)) + (window (titlebar:window tb)) + (state (titlebar:state tb)) + (title (titlebar:title tb))) + (let ((colors (colors-of-state state options)) + (font (get-option-value options 'font)) + (border-style (get-option-value options 'border-style))) + (let ((main-color (first colors)) + (light-color (second colors)) + (dark-color (third colors)) + (font-color (fourth colors)) + (r (clip-rectangle dpy window))) + ;; fill the area with the main color + (set-gc-foreground! dpy gc main-color) + (fill-rectangle dpy window gc 0 0 (rectangle:width r) + (rectangle:height r)) + ;; draw the border + (case border-style + ((raised) (draw-shadow-rectangle dpy window gc r + light-color dark-color)) + ((sunken) (draw-shadow-rectangle dpy window gc r + dark-color light-color))) + ;; else flat... + ;; draw the title + (set-gc-foreground! dpy gc font-color) + (set-gc-background! dpy gc main-color) + (let ((x.y (text-center-pos r font title))) + (draw-image-string dpy window gc (car x.y) (cdr x.y) + title)) + )))) + +(define (colors-of-state state options) + (get-option-value options + (case state + ((active) 'active-colors) + ((focused) 'focused-colors) + (else 'normal-colors)))) diff --git a/src/utils.scm b/src/utils.scm new file mode 100644 index 0000000..cb1eb9d --- /dev/null +++ b/src/utils.scm @@ -0,0 +1,439 @@ +(define (mdisplay . args) + (for-each display args) + (force-output (current-output-port))) + +(define (:optional args default) + (if (null? args) + default + (car args))) + +(define (assq/false key alist) + (let ((p (assq key alist))) + (and p (cdr p)))) + +(define (flatten lists) + (fold-right append + '() + lists)) + +;; *** cml utilities ************************************************* + +(define (select* . list) (select list)) + +(define (make-sync-point) + (make-placeholder)) + +(define (sync-point-release sp) + (placeholder-set! sp #t)) + +(define (sync-point-wait sp) + (placeholder-value sp)) + +(define (spawn* fun) + (let ((sp (make-sync-point))) + (spawn (lambda () + (fun (lambda () (sync-point-release sp))))) + (sync-point-wait sp))) + +(define (with-lock lock thunk) + (obtain-lock lock) + (let ((r (thunk))) + (release-lock lock) + r)) + +;; *** option utilities ********************************************** + +(define-record-type options :options + (make-options dpy colormap option-alist value-alist type-alist) + options? + (dpy options:dpy) + (colormap options:colormap) + (option-alist options:option-alist set-options:option-alist!) + (value-alist options:value-alist set-options:value-alist!) + (type-alist options:type-alist set-options:type-alist!)) + +(define (create-options dpy colormap spec options) + (let ((option-alist (map (lambda (s) + (let* ((n (first s)) + (op (assq n options))) + (cons n (if op (cdr op) (third s))))) + spec)) + (value-alist '()) + (type-alist (map (lambda (s) + (cons (first s) (second s))) + spec))) + (for-each (lambda (name.option name.type) + (allocate-option dpy colormap (car name.option) + (cdr name.type) (cdr name.option))) + option-alist type-alist) + (make-options dpy colormap option-alist value-alist type-alist))) + +(define (free-options options) + ;; TODO + #t) + +(define (get-option-value options name) + (let ((p (assq name (options:value-alist options)))) + (if p + (cdr p) + (let ((op (assq name (options:option-alist options))) + (tp (assq name (options:type-alist options)))) + (if (or (not op) (not tp)) + (error "option not defined" name) + (let ((v (allocate-option (options:dpy options) + (options:colormap options) + name (cdr tp) (cdr op)))) + (set-options:value-alist! options + (cons (cons name v) + (options:value-alist options))) + v)))))) + +(define (get-option options name) + (let ((vp (assq name (options:option-alist options)))) + (if (not vp) + (error "option not defined" name) + (cdr vp)))) + +(define (set-option! options name def) + (set-options:option-alist! options + (cons (cons name def) + (filter (lambda (n.o) + (not (eq? (car n.o) name))) + (options:option-alist options)))) + (set-options:value-alist! options + (filter (lambda (n.v) + (not (eq? (car n.v) name))) + (options:value-alist options)))) + +(define (get-options options) + (options:option-alist options)) + +(define-enumerated-type option-type :option-type + option-type? option-types option-type-name option-type-index + (int number inexact exact string symbol font color colors + boolean symbol-list keys)) + +(define-syntax define-options-spec + (syntax-rules + () + ((define-options-spec id (name type default) ...) + (define id (list (list (quote name) (option-type type) default) + ...))))) + +(define (allocate-option dpy colormap name type def) + (let ((check (lambda (value pred) + (if (not (pred value)) + (error "wrong type argument" value) ;; TODO: other?? + value)))) + (cond + ((eq? type (option-type int)) (check def integer?)) + ((eq? type (option-type number)) (check def number?)) + ((eq? type (option-type inexact)) (check def inexact?)) + ((eq? type (option-type exact)) (check def inexact?)) + ((eq? type (option-type string)) (check def string?)) + ((eq? type (option-type symbol)) (check def symbol?)) + ((eq? type (option-type font)) + (check (load-query-font dpy def) (lambda (v) v))) + ((eq? type (option-type color)) + (let ((c (alloc-named-color dpy colormap def))) + (check (and c (color:pixel c)) (lambda (v) v)))) + ((eq? type (option-type colors)) + (and (check def list?) + (map (lambda (c) (allocate-option dpy colormap name + (option-type color) c)) + def))) + ((eq? type (option-type boolean)) + (check def boolean?)) ;; maybe allow 'yes 'no ?? + ((eq? type (option-type symbol-list)) + (and (check def list?) + (map (lambda (s) (allocate-option dpy colormap name + (option-type symbol) s)) + def))) + ((eq? type (option-type keys)) + (let ((keys (string->keys dpy def))) + (check keys (lambda (x) x)))) + (else (error "option type not implemented" name type))))) + +;; *** keys utilities ************************************************ + +(define-record-type key :key + (make-key modifiers keycode) + key? + (modifiers key:modifiers) + (keycode key:keycode)) + +(define (string->keys dpy s) + (let* ((keys-s (split-space s)) + (keys (map (lambda (s) (string->key dpy s)) keys-s))) + (and (not (memq #f keys)) keys))) + +(define (string->key dpy s) + (let* ((l (reverse (split-minus s))) + (mod-strings (reverse (cdr l))) + (key-string (car l)) + (modifiers (strings->modifiers mod-strings)) + ;; TODO: upcase chars + Shift + (keycode (keysym->keycode dpy (string->keysym key-string)))) + (and modifiers keycode + (make-key modifiers keycode)))) + +(define split-minus (infix-splitter (rx "-"))) +(define split-space (infix-splitter (rx " "))) + +(define (strings->modifiers str-list) + (let ((l (map string->modifiers str-list))) + (and (not (memq #f l)) + (fold enum-set-union + (state-set) + l)))) + +(define (string->modifiers s) + (cond + ((equal? s "C") (state-set control)) + ((equal? s "M") (state-set mod1)) + ((equal? s "M1") (state-set mod1)) + ((equal? s "M2") (state-set mod2)) + ((equal? s "M3") (state-set mod3)) + ((equal? s "M4") (state-set mod4)) + ((equal? s "M5") (state-set mod5)) + ((equal? s "S") (state-set shift)) ;; needed? + (else #f))) + +;; *** xlib utilities ************************************************ + +(define (reparent-to-root dpy window) + ;; reparent window to it's root-window so that it stays virtually at + ;; the same position. + ;; TODO + (reparent-window dpy window (window-root dpy window))) + +(define (window-path dpy window) + (cons window + (let ((p (window-parent dpy window))) + (if (zero? p) + '() + (window-path dpy p))))) + +(define (window-viewable? dpy window) + (eq? (window-attribute:map-state (get-window-attributes dpy window)) + (map-state is-viewable))) + +(define (window-focused? dpy window) + (eq? (get-input-focus-window dpy) window)) + +(define (window-contains-focus? dpy window) + (or (window-focused? dpy window) + (any (lambda (child) + (window-contains-focus? dpy child)) + (window-children dpy window)))) + +(define (take-focus dpy window time) + ;; implements the TAKE_FOCUS protocol + (let* ((protocols (get-wm-protocols dpy window)) + (wm-take-focus (intern-atom dpy "WM_TAKE_FOCUS" #t)) + (wm-hints (get-wm-hints dpy window)) + (t (and wm-hints (assq (wm-hint input?) wm-hints))) + (input? (if t (cdr t) #t))) + (let ((type (if (not (and protocols wm-take-focus + (memq wm-take-focus protocols))) + (if input? + 'passive + 'no-input) + (if input? + 'locally-active + 'globally-active)))) + ;; we use passive as the default (with no hints at all) + (case type + ((passive) + (set-input-focus dpy window (revert-to parent) time)) ;; ?? + ((globally-active) #t) + ((locally-active) + (send-protocol-message dpy window wm-take-focus time)) + ((no-focus) #f))))) + +(define (send-protocol-message dpy window atom time) + (send-event dpy window #f (event-mask) + (create-client-message-event + (event-type client-message) 0 #t dpy window + (make-property (intern-atom dpy "WM_PROTOCOLS" #t) + (property-format long) + (list atom time))))) + +(define (delete-window dpy window time) + (let* ((protocols (get-wm-protocols dpy window)) + (wm-delete-window (intern-atom dpy "WM_DELETE_WINDOW" #t))) + (if (member wm-delete-window protocols) + (send-protocol-message dpy window wm-delete-window time) + (destroy-window dpy window)))) + +(define (move-resize-window* dpy window rect) + (move-resize-window dpy window + (rectangle:x rect) (rectangle:y rect) + (rectangle:width rect) (rectangle:height rect))) + +(define (root-rectangle dpy win) + (let ((r (translate-coordinates dpy win (default-root-window dpy) + 0 0))) + (make-rectangle (if r (car r) 0) (if r (cadr r) 0) + (window-width dpy win) (window-height dpy win)))) + +(define (window-rectangle dpy win) + (let ((wa (get-window-attributes dpy win))) + (make-rectangle (window-attribute:x wa) (window-attribute:y wa) + (window-attribute:width wa) (window-attribute:height wa)))) + +(define (clip-rectangle dpy win) + (make-rectangle 0 0 (window-width dpy win) (window-height dpy win))) + +(define (draw-shadow-rectangle dpy win gc r lc dc) + (let* ((x1 (rectangle:x r)) + (y1 (rectangle:y r)) + (x2 (- (+ x1 (rectangle:width r)) 1)) + (y2 (- (+ y1 (rectangle:height r)) 1))) + (set-gc-foreground! dpy gc lc) + (draw-lines dpy win gc (list (cons x1 y2) (cons x1 y1) (cons x2 y1)) + (coord-mode origin)) + (set-gc-foreground! dpy gc dc) + (draw-lines dpy win gc (list (cons x2 y1) (cons x2 y2) (cons x1 y2)) + (coord-mode origin)))) + +(define (invalidate-window dpy win) + (let ((wa (get-window-attributes dpy win))) + (clear-area dpy win 0 0 (window-attribute:width wa) + (window-attribute:height wa) #t))) + +(define (text-center-pos rect font-struct str) + (let* ((cs (text-extents font-struct str)) + (tw (char-struct:width cs))) + (cons (floor (/ (- (rectangle:width rect) tw) 2)) + (+ (floor (/ (rectangle:height rect) 2)) + (font-struct:descent font-struct))))) + +;; maximize-window moves and resizes the window fill as much space of +;; it's parent (or the window specified with the optional +;; argument). If there is a WM_NORMAL hint present for the window, and +;; the window has to be smaller than the parent, it is centered. + +(define (maximize-window dpy window . maybe-parent) + (let ((r (apply maximal-rect/hints dpy window maybe-parent))) + (mdisplay "maximize-window: " window " " + (rectangle:x r) " " (rectangle:y r) " " + (rectangle:width r) " " (rectangle:height r) "\n") + (move-resize-window dpy window (rectangle:x r) (rectangle:y r) + (rectangle:width r) (rectangle:height r)))) + +(define (maximal-rect/hints dpy window . maybe-parent) + (let ((parent (:optional maybe-parent (window-parent dpy window)))) + (let ((max-width (window-width dpy parent)) + (max-height (window-height dpy parent))) + (let ((w.h (maximal-size/hints dpy window max-width max-height))) + (let ((width (car w.h)) + (height (cdr w.h))) + (let ((x (quotient (- max-width width) 2)) + (y (quotient (- max-height height) 2))) + (make-rectangle x y width height))))))) + +(define (maximal-size/hints dpy window max-width max-height) + (let ((hints (get-wm-normal-hints dpy window))) ;; or group-leader? + (if hints + (adjust-size/hints hints max-width max-height) + (cons max-width max-height)))) + +(define (size-window dpy window default-size) + (let ((size (desired-size/hints dpy window default-size))) + (configure-window dpy window + (make-window-change-alist + (width (car size)) + (height (cdr size)))))) + +(define (desired-size/hints dpy window default-size) + (let* ((hints (get-wm-normal-hints dpy window)) ;; or group-leader? + (size (or (assq/false (size-hint us-size) hints) + (assq/false (size-hint size) hints) + default-size))) + (adjust-size/hints hints (car size) (cdr size)))) + +(define (desired-position/hints dpy window default-position) + (let* ((hints (get-wm-normal-hints dpy window)) ;; or group-leader? + (pos (or (assq/false (size-hint us-position) hints) + (assq/false (size-hint position) hints) + default-position))) + pos)) + +;; returns width/height pair that conform to the defined +;; aspects/resize-inc etc. in hints, and are as close as possible to +;; width/height (but never bigger). + +(define (adjust-size/hints size-hints width height) + (let ((min-size-hint (assq (size-hint min-size) size-hints)) + (max-size-hint (assq (size-hint max-size) size-hints)) + (resize-inc-hint (assq (size-hint resize-inc) size-hints)) + (aspect-hint (assq (size-hint aspect) size-hints)) + (base-size-hint (assq (size-hint base-size) size-hints))) + + ;; respect the desired maximal size ****************************** + (if max-size-hint + (let ((max-width (car (cdr max-size-hint))) + (max-height (cdr (cdr max-size-hint)))) + (if (> width max-width) (set! width max-width)) + (if (> height max-height) (set! height max-height)))) + + ;; ignore the minimal size, but give a warning ******************* +; (let ((hint (or min-size-hint base-size-hint))) ;; according to ICCCM +; (if hint +; (let* ((min-size (cdr hint)) +; (min-width (car min-size)) +; (min-height (cdr min-size))) +; (if (or (< width min-width) +; (< height min-height)) +; (debug-message 1 "% has to be smaller, than the desired minimal size %." +; window hint))))) + + ;; respect aspect ratios ***************************************** + (if aspect-hint + (let* ((base-width (if base-size-hint + (car (cdr base-size-hint)) + 0)) + (base-height (if base-size-hint + (cdr (cdr base-size-hint)) + 0)) + (width* (- width base-width)) + (height* (- height base-height)) + + (ratio (/ width* height*)) + (min-ratio (/ (car (car (cdr aspect-hint))) + (cdr (car (cdr aspect-hint))))) + (max-ratio (/ (car (cdr (cdr aspect-hint))) + (cdr (cdr (cdr aspect-hint))))) + (new-ratio ratio)) + (if (> ratio max-ratio) + (set! new-ratio max-ratio) + (if (< ratio min-ratio) + (set! new-ratio min-ratio))) + (if (< new-ratio ratio) + (set! width* (* height* new-ratio)) + (if (> new-ratio ratio) + (set! height* (/ width* new-ratio)))) + (set! width (+ width* base-width)) + (set! height (+ height* base-height)))) + + ;; respect resize-incs ******************************************* + (if resize-inc-hint + (let* ((width-inc (car (cdr resize-inc-hint))) + (height-inc (cdr (cdr resize-inc-hint))) + (base-size-hint (or base-size-hint min-size-hint)) + (base-width (if base-size-hint + (car (cdr base-size-hint)) + 0)) + (base-height (if base-size-hint + (cdr (cdr base-size-hint)) + 0))) + (set! width + (+ base-width (* width-inc (quotient (- width base-width) + width-inc)))) + (set! height + (+ base-height (* height-inc (quotient (- height base-height) + height-inc)))))) + + ;; result ******************************************************** + (cons width height)))