(define-options-spec titlebar-options-spec
  (buttons symbol-list '(kill)) ; kill, iconize, maximize
  (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) ; flat | sunken
  (font font "-*-helvetica-medium-r-normal-*-12-*-*-*-*-*-*-*")
  ;; 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
  (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 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)))
	 (gc (create-gc dpy window '()))
	 (tb (make-titlebar in-channel dpy window "test" 'normal))
	 (button-channel out-channel)
	 (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)
			 (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...
	 )
    (for-each map-button buttons)
    (spawn*
     (list 'titlebar window)
     (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
			 ((or (destroy-window-event? xevent)
			      (not (window-exists? dpy window)))
			  (exit))
			 ((expose-event? xevent)
			  (if (and (= 0 (expose-event-count xevent))
				   (window-exists? dpy window))
			      (draw-titlebar tb options gc)))
			 ((configure-event? xevent)
			  (refit-buttons options buttons
					 (configure-event-width xevent)
					 (configure-event-height xevent))))))
		(wrap (receive-rv in-channel)
		      (lambda (msg)
			(case (car msg)
			  ((title)
			   (let ((title (cdr msg)))
			     (if (not (equal? (titlebar:title tb) title))
				 (begin
				   (set-titlebar:title! tb title)
				   (draw-titlebar tb options gc)))))
			  ((state)
			   (let ((state (cdr msg)))
			     (if (not (equal? (titlebar:state tb) state))
				 (begin
				   (set-titlebar:state! tb (cdr msg))
				   (draw-titlebar tb options gc)))))
			  ((title+state)
			   (let ((title (second msg))
				 (state (third msg)))
			     (if (or (not (equal? (titlebar:title tb) title))
				     (not (equal? (titlebar:state tb) state)))
				 (begin
				   (set-titlebar:title! tb title)
				   (set-titlebar:state! tb state)
				   (draw-titlebar tb options gc))))))))
		)
	       (loop))))))
       (free-gc dpy gc)))
    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)))

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

(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 (set-titlebar-title+state! tb title state)
  (send (titlebar:channel tb) (list 'title+state title 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
	(change-gc dpy gc
		   (make-gc-value-alist
		    (foreground font-color)
		    (background 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))))

(define (refit-buttons options buttons width height)
  (let* ((margin 2)
	 (bs (- height (* 2 margin)))
	 (spacing 2))
    (for-each (lambda (i button)
		(let ((r (make-rectangle (+ margin (* i (+ bs spacing)))
					 margin bs bs)))
		  (move-resize-button button r)))
	      (iota (length buttons))
	      buttons)))