;; auf Knopfdruck verschiedene Texturen durchschalten

;; ,open threads rendezvous rendezvous-channels rendezvous-async-channels toy-button toy-geometry toy-display-system toy-window-system srfi-1

(define (texture-demo)
  (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)))
	 (texture-bitmap
	  (make-bitmap (widget-env-bitmap root-widget-env)
		       (make-rectangle 120 10 100 100)))
	 (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))))

    (let ((textures
	   (list texture-solid texture-grey
		 texture-horizontal-stripes-1 texture-horizontal-stripes-2
		 texture-vertical-stripes-1 texture-vertical-stripes-2
		 texture-checker)))

      (set-cdr! (last-pair textures) textures)

      (letrec ((callback
		(let ((textures textures))
		  (lambda ()
		    (bitmap-clear texture-bitmap)
		    (bitmap-fill-rectangle 
		     texture-bitmap 'set (car textures)
		     (make-rectangle 0 0 100 100))
		    (set! textures (cdr textures))))))

	(make-button "Next" callback button-widget-env)))))

(texture-demo)
