scheme48/scheme/toy-window-examples/button.scm

;; Buttons: Knöpfe mit Beschriftung

;; ,open threads rendezvous rendezvous-channels rendezvous-async-channels \
;;       toy-geometry toy-display-system toy-window-system

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

;; Tests

(define (test-button)
  (let* ((root-widget-env 
	  (make-window-system "Button Test" 320 200))
	 (button-bitmap 
	  (make-bitmap (widget-env-bitmap root-widget-env)
		       (make-rectangle 10 10 100 50)))
	 (button-widget-env 
	  (make-widget-env button-bitmap 
			   (widget-env-mouse-channel root-widget-env)
			   (widget-env-keyboard-channel root-widget-env)
			   (widget-env-control-in-channel root-widget-env)
			   (widget-env-control-out-channel root-widget-env))))
    (make-button "Click me!"
		 (lambda () 
		   (display "Click!")
		   (newline))
		 button-widget-env)))