(define-options-spec button-options-spec
  ;; colors: (background top-left-border button-right-border font-img-color)
  (up-colors colors '("gray" "white" "black" "black"))
  (down-colors colors '("gray" "black" "white" "black"))
  (font font "-*-helvetica-medium-r-normal-*-12-*-*-*-*-*-*-*")
  (initial-content sexp 'none) ;; string | 'kill | 'iconify | 'maximize
  (type sexp 'standard) ;; 'standard | 'switch (remains pressed)
  (initial-state sexp 'up) ;; 'up | 'down
  )

(define-record-type button :button
  (make-button dpy window options in-channel)
  button?
  (dpy button:dpy)
  (window button:window)
  (options button:options)
  (in-channel button:in-channel))

(define-record-discloser :button
  (lambda (b)
    `(Button ,(button:window b))))

(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)
				       (rectangle:width rect)
				       (rectangle:height rect)
				       0 (black-pixel dpy)
				       bgcolor))
	 (gc (create-gc dpy window '()))
	 (in-channel (make-channel))
	 (abutton (make-button dpy window options in-channel))
	 (type (get-option-value options 'type)))
    (spawn*
     (list 'button abutton)
     (lambda (release)
       (call-with-event-channel
	dpy window (event-mask exposure structure-notify
			       button-press button-release)
	(lambda (event-channel)
	  (release)
	  (call-with-current-continuation
	   (lambda (exit)
	     (let ((state (get-option-value options 'initial-state))
		   (content (get-option-value options 'initial-content)))
	       (let loop ()
		 (select*
		  (wrap (receive-rv in-channel)
			(lambda (msg)
			  (case (car msg)
			    ((get-state)
			     (placeholder-set! (second msg) state))
			    ((set-state!)
			     (let ((s (second msg)))
			       (if (not (eq? s state))
				   (draw-button abutton gc s content))
			       (set! state s)))
			    ((set-content!)
			     (let ((c (second msg)))
			       (if (not (equal? c content))
				   (draw-button abutton gc state c))
			       (set! content c))))))
		  (wrap (receive-rv event-channel)
			(lambda (e)
			  (cond
			   ((and (expose-event? e) (window-exists? dpy window))
			    (draw-button abutton gc state content))
			   ((destroy-window-event? e) (exit 'destroyed))
			   ((and (button-event? e) (window-exists? dpy window)
				 (eq? (button-event-button e)
				      (button button1)))
			    (let ((new-state
				   (if (eq? (event-type button-press)
					    (button-event-type e))
				       (if (eq? type 'standard)
					   'down
					   (if (eq? state 'up)
					       'down
					       'up))
				       (if (eq? type 'standard)
					   'up
					   #f))))
			      (if new-state
				  (begin
				    (draw-button abutton gc new-state content)
				    (set! state new-state)))
			      (if (and (eq? type 'standard)
				       (eq? new-state 'up))
				  (send out-channel
					(list message (button-event-time e)
					      'click)))
			      (if (and (eq? type 'switch) new-state)
				  (send out-channel
					(list message (button-event-time e)
					      new-state)))))))))
		 (loop)))))
	  (free-gc dpy gc)))))
    abutton))

(define (destroy-button button)
  (destroy-window (button:dpy button) (button:window button)))

(define (map-button button)
  (map-window (button:dpy button) (button:window button)))

(define (unmap-button button)
  (unmap-window (button:dpy button) (button:window button)))

(define (move-resize-button button r)
  (move-resize-window* (button:dpy button) (button:window button) r))

(define (button-get-state button)
  (let ((ph (make-placeholder)))
    (send (button:in-channel button)
	  (list 'get-state ph))
    (placeholder-value ph)))

(define (button-set-state! button state)
  (send (button:in-channel button)
	(list 'set-state! state)))

(define (button-set-content! button content)
  (send (button:in-channel button)
	(list 'set-content! content)))


(define (draw-button button gc state content)
  (let ((dpy (button:dpy button))
	(window (button:window button))
	(options (button:options button)))
    (let ((colors (get-option-value options
				    (if (eq? state 'up)
					'up-colors
					'down-colors)))
	  (font (get-option-value options 'font))
	  (r (clip-rectangle dpy window)))
      (set-gc-foreground! dpy gc (first colors))
      (fill-rectangle* dpy window gc r)
      (draw-shadow-rectangle dpy window gc r (second colors) (third colors))
      (if (string? content)
	  (let ((x.y (text-center-pos r font content)))
	    (change-gc dpy gc (make-gc-value-alist
			       (font (font-struct:fid font))
			       (foreground (fourth colors))
			       (background (first colors))))
	    (draw-image-string dpy window gc (car x.y) (cdr x.y)
			       content))
	  (let* ((ww (window-width dpy window))
		 (wh (window-height dpy window))
		 (bw (max 2 (quotient ww 5)))
		 (sw (max 1 (quotient ww 10))))
	    (case content
	      ((kill)
	       (change-gc dpy gc
			  (make-gc-value-alist
			   (line-width bw)
			   (cap-style (cap-style round))
			   (foreground (fourth colors))))
	       (draw-line dpy window gc bw bw (- ww (* 2 bw)) (- wh (* bw 2)))
	       (draw-line dpy window gc bw (- wh (* bw 2)) (- ww (* bw 2)) bw))
	      ((iconify)
	       (change-gc dpy gc
			  (make-gc-value-alist
			   (line-width bw)
			   (cap-style (cap-style round))
			   (foreground (fourth colors))))
	       (draw-line dpy window gc bw (- wh (+ bw 1))
			  (- ww (+ bw 1)) (- wh (+ bw 1))))
	      ((maximize)
	       (change-gc dpy gc
			  (make-gc-value-alist
			   (line-width sw)
			   (cap-style (cap-style round))
			   (foreground (fourth colors))))
	       (draw-rectangle dpy window gc bw bw
			       (- ww (* 2 bw)) (- wh (* 2 bw)))
	       (draw-line dpy window gc bw (+ bw sw)
			  (- ww (* bw 2)) (+ bw sw)))
	      ))))))