From 6d99e01988478340c2eb3828043a0f831b18ee46 Mon Sep 17 00:00:00 2001 From: frese Date: Sat, 29 Jan 2005 14:36:47 +0000 Subject: [PATCH] - pass all allocated option-values to titlebars and buttons - use special-options for the layout --- src/button.scm | 13 ++++----- src/config-specs.scm | 8 +++-- src/config.scm | 8 +++-- src/manager.scm | 8 ++--- src/move-wm-pager.scm | 54 +++++++++++++++++----------------- src/move-wm.scm | 42 ++++++++++++++------------ src/packages.scm | 11 ++++--- src/root-manager.scm | 5 ++-- src/split-wm.scm | 43 ++++++++++++++------------- src/switch-wm.scm | 68 ++++++++++++++++++++++++------------------- src/titlebar.scm | 39 ++++++++++++++++--------- src/utils.scm | 30 +++++++++++++++---- 12 files changed, 191 insertions(+), 138 deletions(-) diff --git a/src/button.scm b/src/button.scm index 123f3e1..3f811bc 100644 --- a/src/button.scm +++ b/src/button.scm @@ -3,7 +3,7 @@ (up-colors colors '("gray" "white" "black" "black")) (down-colors colors '("gray" "black" "white" "black")) (font font "-*-helvetica-medium-r-normal-*-12-*-*-*-*-*-*-*") - (content sexp 'none) ;; string | 'kill | 'iconify | 'maximize + (initial-content sexp 'none) ;; string | 'kill | 'iconify | 'maximize (type sexp 'standard) ;; 'standard | 'switch (remains pressed) (initial-state sexp 'up) ;; 'up | 'down ) @@ -20,10 +20,8 @@ (lambda (b) `(Button ,(button:window b)))) -(define (create-button dpy parent colormap rect out-channel message options) - (let* ((options (create-options dpy colormap button-options-spec - options)) - (bgcolor (first (get-option-value options 'up-colors))) +(define (create-button dpy parent rect out-channel message options) + (let* ((bgcolor (first (get-option-value options 'up-colors))) (window (create-simple-window dpy parent (rectangle:x rect) (rectangle:y rect) @@ -46,7 +44,7 @@ (call-with-current-continuation (lambda (exit) (let ((state (get-option-value options 'initial-state)) - (content (get-option-value options 'content))) + (content (get-option-value options 'initial-content))) (let loop () (select* (wrap (receive-rv in-channel) @@ -98,8 +96,7 @@ (list message (button-event-time e) new-state))))))))) (loop))))) - (free-gc dpy gc) - (free-options options #t))))) + (free-gc dpy gc))))) abutton)) (define (destroy-button button) diff --git a/src/config-specs.scm b/src/config-specs.scm index ef4d5ce..bd3b455 100644 --- a/src/config-specs.scm +++ b/src/config-specs.scm @@ -1,8 +1,6 @@ ;; *** configuration specification *********************************** (define-options-spec split-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 @@ -18,6 +16,9 @@ (titlebar-colors colors '("#aaaaaa" "#eeeeee" "#777777" "black")) (titlebar-colors-focused colors '("#666699" "#aaaacc" "#333366" "#eeeeee")) (titlebar-colors-active colors '("#9999aa" "#eeeeff" "#777788" "black")) + ;; colors: (background top-left-border button-right-border font-img-color) + (titlebar-button-up-colors colors '("gray" "white" "black" "black")) + (titlebar-button-down-colors colors '("gray" "black" "white" "black")) (titlebar-height int 18) (titlebar-style symbol 'raised) (font font "-*-helvetica-medium-r-normal-*-12-*-*-*-*-*-*-*") @@ -31,6 +32,8 @@ (define-options-spec move-options-spec (titlebar-colors colors '("#aaaaaa" "#eeeeee" "#777777" "black")) (titlebar-colors-focused colors '("#666699" "#aaaacc" "#333366" "#eeeeee")) + (titlebar-button-up-colors colors '("gray" "white" "black" "black")) + (titlebar-button-down-colors colors '("gray" "black" "white" "black")) (titlebar-height int 18) (titlebar-style symbol 'flat) (font font "-*-helvetica-medium-r-normal-*-12-*-*-*-*-*-*-*") @@ -75,5 +78,6 @@ (user-bindings binding-list '(("F2" exec "xterm"))) (save-layout keys "F11") (select-outer-manager keys "M-Home") + (default-cursor cursor xc-X-cursor) ) diff --git a/src/config.scm b/src/config.scm index ba4940d..b2396c2 100644 --- a/src/config.scm +++ b/src/config.scm @@ -8,9 +8,12 @@ (map (lambda (c) (get-manager-by-window root-wm (client:window c))) - (wm-clients wm))))) + (wm-clients wm)))) + (diff (if (wm:special-options wm) + (get-options-diff (wm:special-options wm)) + '()))) (cons (manager-type-name (wm:type wm)) - (cons (get-options-diff (wm:options wm)) + (cons diff (map loop children))))))) (cddr (loop (root-wm:initial-manager root-wm))))) @@ -95,7 +98,6 @@ (cons 'move-options (get 'move-options))) (get 'root-options)))))))) - ;; TODO: maybe create a file with default-config-file in it '()))) (define default-config-file diff --git a/src/manager.scm b/src/manager.scm index f86b2f0..cc01594 100644 --- a/src/manager.scm +++ b/src/manager.scm @@ -1,6 +1,6 @@ (define-record-type wm :wm (make-wm type in-channel out-channel internal-out-channel - dpy window colormap options + dpy window colormap options special-options clients current-client) wm? (type wm:type) @@ -11,6 +11,7 @@ (window wm:window) (colormap wm:colormap) (options wm:options) + (special-options wm:special-options) (clients wm:clients set-wm:clients!) (current-client wm:current-client set-wm:current-client!)) @@ -31,7 +32,7 @@ ((eq? type (manager-type switch)) "switch-wm") ((eq? type (manager-type move)) "move-wm"))) -(define (create-wm dpy parent options children +(define (create-wm dpy parent options special-options children type out-channel fun) (let* ((wa (get-window-attributes dpy parent)) (main-window @@ -45,7 +46,7 @@ (internal-out-channel (make-channel)) (wm (make-wm type in-channel out-channel internal-out-channel dpy main-window colormap - options '() #f))) + options special-options '() #f))) (set-window-background-pixmap! dpy main-window parent-relative) ;; set properties ************************************************ @@ -311,7 +312,6 @@ wm-state))) ;; transparent by default. (set-window-background-pixmap! dpy client-window parent-relative) - ;;(define-cursor dpy client-window xc-X-cursor) TODO (if (memq 'click (get-option-value (wm:options wm) 'focus-policy)) ;; Note: won't work recursively (manager in manager) diff --git a/src/move-wm-pager.scm b/src/move-wm-pager.scm index 7b2ddbf..a742f56 100644 --- a/src/move-wm-pager.scm +++ b/src/move-wm-pager.scm @@ -1,6 +1,6 @@ (define-record-type move-wm-pager :move-wm-pager (make-move-wm-pager dpy window wm in-channel options buttons-alist width - visible?) + visible? button-options) move-wm-pager? (dpy pager:dpy) (window pager:window) @@ -10,9 +10,9 @@ ;; client -> button (buttons-alist pager:buttons-alist set-pager:buttons-alist!) (width pager:width set-pager:width!) - (visible? pager:visible? set-pager:visible!)) + (visible? pager:visible? set-pager:visible!) + (button-options pager:button-options)) -;; TODO: hide buttons/keys ;; TODO: client-name <-> WM_ICON_NAME? (define (repeat-infinitely fun) ;; -> utils @@ -35,9 +35,24 @@ bg-color)) (in-channel (make-channel)) (gc (create-gc dpy window '())) - (colormap (screen:default-colormap (display:default-screen dpy))) + (button-options + (let* ((colors (get-option-value options 'pager-colors)) + (main-color (second colors)) + (light (third colors)) + (dark (fourth colors)) + (font-color (fifth colors))) + (build-options + (options:dpy options) (options:colormap options) + button-options-spec + `((up-colors . ,(list main-color light dark font-color)) + (down-colors . ,(list main-color dark light font-color)) + (font . ,(get-option-value options 'font)) + (initial-content . "") + (type . switch) + (initial-state . up))))) (pager (make-move-wm-pager dpy window wm in-channel options '() - (rectangle:width rect) #t))) + (rectangle:width rect) #t + button-options))) (spawn* (list 'move-wm-pager wm window) (lambda (release) @@ -99,32 +114,17 @@ ((destroy-window-event? xevent) ;; mask? ;; destroy-button not necessary (exit)))))))) - (free-gc dpy gc) - ;;(free-options options #t) ;; common with wm - )))) + (free-gc dpy gc))))) (map-window dpy window) pager)) (define (pager-create-button pager client rect) - (let* ((dpy (pager:dpy pager)) - (options (pager:options pager)) - (colors (get-option options 'pager-colors)) - (main-color (second colors)) - (light (third colors)) - (dark (fourth colors)) - (font-color (fifth colors))) - (create-button (pager:dpy pager) (pager:window pager) - (screen:default-colormap (display:default-screen dpy)) - rect (pager:in-channel pager) - (cons 'button client) - `(;; TODO: don't let every button allocate the - ;; colors, and load the font. - (up-colors . ,(list main-color light dark font-color)) - (down-colors . ,(list main-color dark light font-color)) - (font . ,(get-option options 'font)) - (content . ,(client-name (pager:dpy pager) client)) - (type . switch) - (initial-state . up))))) + (let ((b (create-button (pager:dpy pager) (pager:window pager) + rect (pager:in-channel pager) + (cons 'button client) + (pager:button-options pager)))) + (button-set-content! b (client-name (pager:dpy pager) client)) + b)) (define (calc-pager-rect wm) (let ((dpy (wm:dpy wm)) diff --git a/src/move-wm.scm b/src/move-wm.scm index f038ef4..6977f9f 100644 --- a/src/move-wm.scm +++ b/src/move-wm.scm @@ -1,6 +1,6 @@ (define (create-move-wm out-channel dpy parent options special-options . children) - (create-wm dpy parent options children + (create-wm dpy parent options #f children (manager-type move) out-channel (lambda (wm in-channel) @@ -13,7 +13,21 @@ (gc (create-gc dpy window '())) (pager-channel (make-channel)) (options (wm:options wm)) - (pager (create-move-wm-pager wm pager-channel options))) + (pager (create-move-wm-pager wm pager-channel options)) + (titlebar-options + (let ((get (lambda (id) (get-option-value options id)))) + (build-options dpy (options:colormap options) + titlebar-options-spec + `((buttons . (kill maximize iconify)) + (normal-colors . ,(get 'titlebar-colors)) + (active-colors . ,(get 'titlebar-colors-focused)) + (focused-colors . ,(get 'titlebar-colors-focused)) + (border-style . ,(get 'titlebar-style)) + (font . ,(get 'font)) + (button-down-colors . ,(get + 'titlebar-button-down-colors)) + (button-up-colors . ,(get 'titlebar-button-up-colors)) + (height . ,(get 'titlebar-height))))))) (for-each (lambda (id) (grab-shortcut dpy window (get-option-value options id) @@ -26,11 +40,11 @@ (lambda (exit) (let loop () (let ((msg (receive channel))) - (handle-message wm pager gc exit msg) + (handle-message wm pager gc titlebar-options exit msg) (loop))))) (free-gc dpy gc))))) -(define (handle-message wm pager gc exit msg) +(define (handle-message wm pager gc titlebar-options exit msg) (let ((dpy (wm:dpy wm)) (window (wm:window wm))) (case (car msg) @@ -60,7 +74,7 @@ ((init-client) (let ((client (second msg)) (maybe-rect (third msg))) - (init-client wm client maybe-rect) + (init-client wm client maybe-rect titlebar-options) (pager-add-client pager client) ;; for (properly) transient windows this would not be necessary: (wm-select-client wm client current-time))) @@ -241,11 +255,12 @@ (not (null? (enum-set->list (motif-wm-hints:decorations hints))))))) (else #t))) -(define (init-client wm client maybe-rect) +(define (init-client wm client maybe-rect titlebar-options) (let ((dpy (wm:dpy wm))) (let* ((r (initial-client-rect wm client maybe-rect)) (channel (make-channel)) - (titlebar (create-client-titlebar channel wm client)) + (titlebar (create-client-titlebar channel wm client + titlebar-options)) (resizer (create-resizer wm client)) (options (wm:options wm))) (set-client:data! client (make-client-data titlebar resizer)) @@ -306,19 +321,10 @@ (map-window dpy (client:window client))) (map-window dpy (client:client-window client))))) -(define (create-client-titlebar channel wm client) +(define (create-client-titlebar channel wm client titlebar-options) (let ((options (wm:options wm))) (create-titlebar channel (wm:dpy wm) (client:client-window client) - (wm:colormap wm) - (list (cons 'buttons '(kill maximize iconify)) - (cons 'normal-colors - (get-option options 'titlebar-colors)) - (cons 'active-colors - (get-option options 'titlebar-colors-focused)) - (cons 'focused-colors - (get-option options 'titlebar-colors-focused)) - (cons 'border-style - (get-option options 'titlebar-style)))))) + titlebar-options))) (define (deinit-client wm client) (let ((dpy (wm:dpy wm))) diff --git a/src/packages.scm b/src/packages.scm index 8682fe5..aa65f47 100644 --- a/src/packages.scm +++ b/src/packages.scm @@ -6,7 +6,8 @@ make-sync-point sync-point-release sync-point-wait send-message+wait - create-options free-options + options:dpy options:colormap + create-options free-options build-options get-option-value get-option set-option! get-options ((define-options-spec) :syntax) options-spec-union get-options-diff spec-defaults @@ -55,7 +56,8 @@ (define-structure titlebar (export create-titlebar destroy-titlebar titlebar? titlebar:window map-titlebar unmap-titlebar move-resize-titlebar - set-titlebar-state! set-titlebar-title! set-titlebar-title+state!) + set-titlebar-state! set-titlebar-title! set-titlebar-title+state! + titlebar-options-spec) (open scheme define-record-types threads list-lib rendezvous-channels rendezvous xlib @@ -74,7 +76,8 @@ map-button unmap-button move-resize-button button-get-state button-set-state! - button-set-content!) + button-set-content! + button-options-spec) (open scheme list-lib rendezvous-channels rendezvous placeholders define-record-types @@ -116,7 +119,7 @@ (define-structure manager (export wm? wm:type wm:dpy wm:window wm:colormap wm:options wm:out-channel - wm:internal-out-channel + wm:internal-out-channel wm:special-options (manager-type :syntax) manager-types manager-type-name create-wm destroy-wm wm-clients wm-current-client diff --git a/src/root-manager.scm b/src/root-manager.scm index 93bc238..cd28b50 100644 --- a/src/root-manager.scm +++ b/src/root-manager.scm @@ -49,6 +49,7 @@ (make-sync-point) cross-ref-hack split-options switch-options move-options)) ) + (define-cursor dpy window (get-option-value options 'default-cursor)) (set-root-wm:current-manager! root-wm initial-manager) (add-manager! root-wm initial-manager) @@ -181,8 +182,8 @@ (splitter (create-split-wm in-channel dpy (window-parent dpy (wm:window current)) - (list (cons 'orientation orientation)) - (root-wm:split-options root-wm))) + (root-wm:split-options root-wm) + (list (cons 'orientation orientation)))) (first current) (creator (if (eq? new-wm 'switch-wm) create-switch-wm diff --git a/src/split-wm.scm b/src/split-wm.scm index c2dd0c7..e7d2b90 100644 --- a/src/split-wm.scm +++ b/src/split-wm.scm @@ -10,26 +10,25 @@ (define (create-split-wm external-in-channel dpy parent options special-options . children) - (create-wm dpy parent options children - (manager-type split) - external-in-channel - (lambda (wm in-channel) - (init-split-wm wm in-channel - (create-options dpy #f - split-special-options-spec - special-options)) - wm))) + (let ((special-options (create-options dpy #f + split-special-options-spec + special-options))) + (create-wm dpy parent options special-options children + (manager-type split) + external-in-channel + (lambda (wm in-channel) + (init-split-wm wm in-channel) + wm)))) (define-record-type split-data :split-data - (make-split-data resizer first-client second-client options) + (make-split-data resizer first-client second-client) split-data? (resizer data:resizer set-data:resizer!) (first-client data:first-client set-data:first-client!) - (second-client data:second-client set-data:second-client!) - (options data:options)) + (second-client data:second-client set-data:second-client!)) -(define (init-split-wm wm channel options) - (let* ((data (make-split-data #f #f #f options)) +(define (init-split-wm wm channel) + (let* ((data (make-split-data #f #f #f)) (resizer (create-resizer wm data))) (set-data:resizer! data resizer) (spawn* (list 'split-wm wm) @@ -42,7 +41,7 @@ (let ((msg (receive channel))) (handle-message wm channel data exit msg) (loop))))) - (free-options options #t))))) + (free-options (wm:special-options wm) #t))))) (define (handle-message wm channel data exit msg) (let ((dpy (wm:dpy wm))) @@ -81,7 +80,7 @@ (map-window dpy (client:window client)) (map-window dpy (client:client-window client)) - (let ((opt (if (eq? (get-option-value (data:options data) + (let ((opt (if (eq? (get-option-value (wm:special-options wm) 'orientation) 'horizontal) (if first? 'select-right 'select-left) @@ -143,9 +142,10 @@ (define (calc-rectangles wm data) (let* ((options (wm:options wm)) + (special-options (wm:special-options wm)) (bar-width (get-option-value options 'bar-width)) - (orientation (get-option-value (data:options data) 'orientation)) - (aspect (get-option-value (data:options data) 'aspect)) + (orientation (get-option-value special-options 'orientation)) + (aspect (get-option-value special-options 'aspect)) (r (clip-rectangle (wm:dpy wm) (wm:window wm)))) (if (eq? orientation 'horizontal) (let* ((r1 (make-rectangle 0 0 @@ -212,6 +212,7 @@ 'horizontal) xc-sb-h-double-arrow xc-sb-v-double-arrow)))) + ;; TODO: v-cursor doesn't work anymore?! (set-window-cursor! dpy window cursor) (spawn* (list 'split-resizer wm) @@ -278,7 +279,7 @@ (r1 (first rects)) (r2 (third rects)) (aspect (if (eq? 'horizontal - (get-option-value (data:options data) + (get-option-value (wm:special-options wm) 'orientation)) (if (= 0 (- (rectangle:width r2) dx)) 0 @@ -290,7 +291,7 @@ (- (rectangle:height r2) dy)))))) (if (> aspect 0) (begin - (set-option! (data:options data) 'aspect aspect) + (set-option! (wm:special-options wm) 'aspect aspect) (send (wm:internal-out-channel wm) '(fit-windows)) ))))) @@ -298,7 +299,7 @@ (lambda (start-rect dx dy) (let ((width (rectangle:width start-rect)) (height (rectangle:height start-rect))) - (if (eq? (get-option-value (data:options data) + (if (eq? (get-option-value (wm:special-options wm) 'orientation) 'horizontal) (make-rectangle (+ (rectangle:x start-rect) dx) diff --git a/src/switch-wm.scm b/src/switch-wm.scm index b65b07f..eccf501 100644 --- a/src/switch-wm.scm +++ b/src/switch-wm.scm @@ -1,6 +1,6 @@ (define (create-switch-wm out-channel dpy parent options special-options . children) - (create-wm dpy parent options children + (create-wm dpy parent options #f children (manager-type switch) out-channel (lambda (wm in-channel) @@ -8,11 +8,12 @@ wm))) (define-record-type switch-wm-data :switch-wm-data - (make-switch-wm-data titlebars empty-titlebar last-focused) + (make-switch-wm-data titlebars empty-titlebar last-focused titlebar-options) switch-wm-data? (titlebars data:titlebars set-data:titlebars!) (empty-titlebar data:empty-titlebar) - (last-focused data:last-focused set-data:last-focused!)) + (last-focused data:last-focused set-data:last-focused!) + (titlebar-options data:titlebar-options)) ;; only for switch-wm's, but maybe we will need that for all... (define (last-focused-client wm data) @@ -31,8 +32,23 @@ (window (wm:window wm)) (options (wm:options wm)) (gc (create-gc dpy window '())) + (titlebar-options + (let ((get (lambda (id) (get-option-value options id)))) + (build-options dpy (options:colormap options) + titlebar-options-spec + `((buttons . (kill)) + (normal-colors . ,(get 'titlebar-colors)) + (active-colors . ,(get 'titlebar-colors-active)) + (focused-colors . ,(get 'titlebar-colors-focused)) + (border-style . ,(get 'titlebar-style)) + (font . ,(get 'font)) + (button-down-colors . ,(get + 'titlebar-button-down-colors)) + (button-up-colors . ,(get 'titlebar-button-up-colors)) + (height . ,(get 'titlebar-height)))))) (empty-titlebar (create-empty-titlebar wm)) - (data (make-switch-wm-data '() empty-titlebar (cons #f #f)))) + (data (make-switch-wm-data '() empty-titlebar (cons #f #f) + titlebar-options))) (update-titlebars wm data) (for-each (lambda (id) @@ -195,7 +211,7 @@ (let ((dpy (wm:dpy wm)) (options (wm:options wm))) (let* ((channel (make-channel)) - (titlebar (create-client-titlebar channel wm client))) + (titlebar (create-client-titlebar channel wm data client))) (set-data:titlebars! data (append (data:titlebars data) (list (cons client titlebar)))) (set-titlebar-title! titlebar (client-name dpy client)) @@ -246,34 +262,26 @@ (map-window dpy (client:window client))) (wm-select-client wm client current-time)))) -(define (create-client-titlebar channel wm client) - (let ((options (wm:options wm))) - (create-titlebar channel (wm:dpy wm) (wm:window wm) - (wm:colormap wm) - (list (cons 'buttons '(kill)) - (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-client-titlebar channel wm data client) + (create-titlebar channel (wm:dpy wm) (wm:window wm) + (data:titlebar-options data))) (define (create-empty-titlebar wm) (let* ((options (wm:options wm)) - (tb - (create-titlebar #f (wm:dpy wm) (wm:window wm) (wm:colormap wm) - (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)) - (cons 'buttons '()))))) + (get (lambda (id) (get-option-value options id))) + (tb-options + (build-options (options:dpy options) (options:colormap options) + titlebar-options-spec + `((buttons . ()) + (normal-colors . ,(get 'titlebar-colors)) + (active-colors . ,(get 'titlebar-colors-active)) + (focused-colors . ,(get 'titlebar-colors-focused)) + (border-style . ,(get 'titlebar-style)) + (font . ,(get 'font)) + (button-down-colors . ,(get 'titlebar-button-down-colors)) + (button-up-colors . ,(get 'titlebar-button-up-colors)) + (height . ,(get 'titlebar-height))))) + (tb (create-titlebar #f (wm:dpy wm) (wm:window wm) tb-options))) (set-titlebar-title! tb "") tb)) diff --git a/src/titlebar.scm b/src/titlebar.scm index 2bbed65..073b5ae 100644 --- a/src/titlebar.scm +++ b/src/titlebar.scm @@ -5,7 +5,10 @@ (focused-colors colors '("#666699" "#aaaacc" "#333366" "#eeeeee")) (border-style symbol 'raised) ; flat | sunken (font font "-*-helvetica-medium-r-normal-*-12-*-*-*-*-*-*-*") - (button-border-style symbol 'flat) ; none | raised + ;; colors: (background top-left-border button-right-border font-img-color) + (button-up-colors colors '("gray" "white" "black" "black")) + (button-down-colors colors '("gray" "black" "white" "black")) + (height number 18) ) (define-record-type titlebar :titlebar @@ -17,23 +20,34 @@ (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) +(define (create-titlebar out-channel dpy parent options) (let* ((in-channel (make-channel)) + (height (get-option-value options 'height)) ;; TODO: height button-size (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)) (button-channel out-channel) - (button-size 13) ;; TODO has to be calculated from window-height + (button-size (- height 4)) + (button-options + (build-options + (options:dpy options) (options:colormap options) + button-options-spec + `((up-colors . ,(get-option-value options 'button-up-colors)) + (down-colors . ,(get-option-value options 'button-down-colors)) + (font . ,(get-option-value options 'font)) + (initial-content . "") + (type . standard) + (initial-state . up)))) + ;; TODO: border-style -> colors (buttons (map (lambda (id) - (create-button dpy window colormap - (make-rectangle 0 0 1 1) - button-channel id - ;; TODO: border-style -> colors - `((content . ,id)))) + (let ((b (create-button dpy window + (make-rectangle 0 0 1 1) + button-channel id + button-options))) + (button-set-content! b id) + b)) (get-option-value options 'buttons))) ;; icon-window... ) @@ -89,9 +103,7 @@ (draw-titlebar tb options gc)))))))) ) (loop)))))) - (free-gc dpy gc) - ;; colormap might not exists anymore... - (free-options options #t))) + (free-gc dpy gc))) tb)) (define (destroy-titlebar tb) @@ -103,6 +115,7 @@ (define (unmap-titlebar tb) (unmap-window (titlebar:dpy tb) (titlebar:window tb))) +;; TODO: height must stay the same, or change buttons (define (move-resize-titlebar tb rect) (move-resize-window* (titlebar:dpy tb) (titlebar:window tb) rect)) diff --git a/src/utils.scm b/src/utils.scm index 06efa24..28a3bf3 100644 --- a/src/utils.scm +++ b/src/utils.scm @@ -80,6 +80,18 @@ (type-alist options:type-alist set-options:type-alist!) (default-alist options:default-alist)) +;; create new options structure out of existing (allocated) values +;; TODO: remember which options were specified and don't have to be +;; freed, and those that are allocated later. +;; TODO: the options are taken out of the spec, but that mustn't match +;; the given values +(define (build-options dpy colormap spec option-values) + (make-options dpy colormap + (options-spec-defaults spec) + option-values ;; TODO check this alist + (options-spec-types spec) + (options-spec-defaults spec))) + (define (create-options dpy colormap spec options) (let ((option-alist (map (lambda (s) (let* ((n (first s)) @@ -87,12 +99,8 @@ (cons n (if op (cdr op) (third s))))) spec)) (value-alist '()) - (type-alist (map (lambda (s) - (cons (first s) (second s))) - spec)) - (default-alist (map (lambda (s) - (cons (first s) (third s))) - spec))) + (type-alist (options-spec-types spec)) + (default-alist (options-spec-defaults spec))) (for-each (lambda (name.option name.type) (allocate-option dpy colormap (car name.option) (cdr name.type) (cdr name.option))) @@ -184,6 +192,16 @@ (define (options-spec-union spec1 spec2) (append spec1 spec2)) +(define (options-spec-types spec) + (map (lambda (s) + (cons (first s) (second s))) + spec)) + +(define (options-spec-defaults spec) + (map (lambda (s) + (cons (first s) (third s))) + spec)) + (define (allocate-option dpy colormap name type def) (let ((check (lambda (value pred) (if (not (pred value))