;; Buttons: Knöpfe mit Beschriftung

(define (make-button label action-thunk widget-env)
  (let* ((bitmap (widget-env-bitmap widget-env))
	 (rectangle (bitmap-rectangle bitmap))
	 (button-width (rectangle-width rectangle))
	 (button-height (rectangle-height rectangle)))
    (call-with-values
     (lambda () (bitmap-text-size bitmap label))
     (lambda (height width ascent)
       (let*  ((text-origin
		(make-point (max 0
				 (quotient (- button-width
					      width)
					   2))
			    (min (- button-height 1)
				 (+ (quotient (- button-height
						 height)
					      2)
				    ascent)))))

	 (bitmap-draw-rectangle bitmap 'copy
				(make-rectangle 0 0
						(- button-width 1)
						(- button-height 1)))

	 (bitmap-draw-text bitmap 'copy text-origin label)
	 (make-channel-sink (widget-env-keyboard-channel widget-env))

	 (spawn
	  (lambda ()
	    (let loop ((was-in-and-up? #f))

	      (define (mouse-state message)
		(values (mouse-message-down? message)
			(point-in-rectangle? (mouse-message-position message)
					     rectangle)))

	      (define (handle-mouse message)
		(call-with-values
		 (lambda () (mouse-state message))
		 (lambda (down? in?)
		   (if (and was-in-and-up? down? in?)
		       (begin
			 (action-thunk)
			 (loop #f))
		       (loop (and (not down?) in?))))))

	      (define (handle-control message)
		(case (control-message-type message)
		  ((delete)
		   (send-async (widget-env-control-out-channel widget-env)
			       message))
		  (else
		   (loop was-in-and-up?))))

	      (select
	       (list
		(wrap (receive-rv (widget-env-mouse-channel widget-env))
		      handle-mouse)
		(wrap (receive-rv (widget-env-control-in-channel widget-env))
		      handle-control))))))

	 widget-env)))))