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