- pass all allocated option-values to titlebars and buttons

- use special-options for the layout

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)
+(define (create-button dpy parent rect out-channel message options)
-  (let* ((options (create-options dpy colormap button-options-spec
+  (let* ((bgcolor (first (get-option-value options 'up-colors)))
-				  options))
-	 (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-gc dpy gc)))))
-	  (free-options options #t)))))
     abutton))
 
 (define (destroy-button button)

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)
   )
 

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

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)

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 . "<unnamed>")
+	       (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-gc dpy gc)))))
-	  ;;(free-options options #t) ;; common with wm
-	  ))))
     (map-window dpy window)
     pager))
 
 (define (pager-create-button pager client rect)
-  (let* ((dpy (pager:dpy pager))
+  (let ((b (create-button (pager:dpy pager) (pager:window pager)
-	 (options (pager:options pager))
+			  rect (pager:in-channel pager)
-	 (colors (get-option options 'pager-colors))
+			  (cons 'button client)
-	 (main-color (second colors))
+			  (pager:button-options pager))))
-	 (light (third colors))
+    (button-set-content! b (client-name (pager:dpy pager) client))
-	 (dark (fourth colors))
+    b))
-	 (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)))))
 
 (define (calc-pager-rect wm)
   (let ((dpy (wm:dpy wm))

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)
+		     titlebar-options)))
-		     (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))))))
 
 (define (deinit-client wm client)
   (let ((dpy (wm:dpy wm)))

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

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

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
+  (let ((special-options (create-options dpy #f
-	     (manager-type split)
+					 split-special-options-spec
-	     external-in-channel
+					 special-options)))
-	     (lambda (wm in-channel)
+    (create-wm dpy parent options special-options children
-	       (init-split-wm wm in-channel
+	       (manager-type split)
-			      (create-options dpy #f
+	       external-in-channel
-					      split-special-options-spec
+	       (lambda (wm in-channel)
-					      special-options))
+		 (init-split-wm wm in-channel)
-	       wm)))
+		 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!)
+  (second-client data:second-client set-data:second-client!))
-  (options data:options))
 
-(define (init-split-wm wm channel options)
+(define (init-split-wm wm channel)
-  (let* ((data (make-split-data #f #f #f options))
+  (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))
+	 (orientation (get-option-value special-options 'orientation))
-	 (aspect (get-option-value (data:options data) 'aspect))
+	 (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)

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)
+(define (create-client-titlebar channel wm data client)
-  (let ((options (wm:options wm)))
+  (create-titlebar channel (wm:dpy wm) (wm:window wm)
-    (create-titlebar channel (wm:dpy wm) (wm:window wm)
+		   (data:titlebar-options data)))
-		     (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-empty-titlebar wm)
   (let* ((options (wm:options wm))
-	 (tb
+	 (get (lambda (id) (get-option-value options id)))
-	  (create-titlebar #f (wm:dpy wm) (wm:window wm) (wm:colormap wm)
+	 (tb-options
-		   (list
+	  (build-options (options:dpy options) (options:colormap options)
-		    (cons 'normal-colors
+			 titlebar-options-spec
-			  (get-option options 'titlebar-colors))
+			 `((buttons . ())
-		    (cons 'active-colors
+			   (normal-colors . ,(get 'titlebar-colors))
-			  (get-option options 'titlebar-colors-active))
+			   (active-colors . ,(get 'titlebar-colors-active))
-		    (cons 'focused-colors
+			   (focused-colors . ,(get 'titlebar-colors-focused))
-			  (get-option options 'titlebar-colors-focused))
+			   (border-style . ,(get 'titlebar-style))
-		    (cons 'border-style
+			   (font . ,(get 'font))
-			  (get-option options 'titlebar-style))
+			   (button-down-colors . ,(get 'titlebar-button-down-colors))
-		    (cons 'buttons '())))))
+			   (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 "<empty frame>")
     tb))
 

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 . "<unnamed>")
+	     (type . standard)
+	     (initial-state . up))))
+	 ;; TODO: border-style -> colors
 	 (buttons (map (lambda (id)
-			 (create-button dpy window colormap
+			 (let ((b (create-button dpy window
-					(make-rectangle 0 0 1 1)
+						 (make-rectangle 0 0 1 1)
-					button-channel id
+						 button-channel id
-					;; TODO: border-style -> colors
+						 button-options)))
-					`((content . ,id))))
+			   (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)
+       (free-gc dpy gc)))
-       ;; colormap might not exists anymore...
-       (free-options options #t)))
     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))
 

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)
+	(type-alist (options-spec-types spec))
-			   (cons (first s) (second s)))
+	(default-alist (options-spec-defaults spec)))
-			 spec))
-	(default-alist (map (lambda (s)
-			      (cons (first s) (third s)))
-			    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))