(define-record-type control-message :control-message
  (make-control-message type rectangle)
  control-message?
  (type control-message-type)
  (rectangle control-message-rectangle)) ; or #f

(define-record-type widget-env :widget-env
  (make-widget-env bitmap
		   mouse-channel
		   keyboard-channel
		   control-in-channel
		   control-out-channel)
  widget-env?
  (bitmap widget-env-bitmap)
  (mouse-channel widget-env-mouse-channel)
  (keyboard-channel widget-env-keyboard-channel)
  (control-in-channel widget-env-control-in-channel)
  (control-out-channel widget-env-control-out-channel))

(define (make-vanilla-widget-env bitmap)
  (make-widget-env bitmap
		   (make-channel)
		   (make-channel)
		   (make-channel)
		   (make-async-channel)))

(define (widget-env=? widget-env-1 widget-env-2)
  (eq? widget-env-1 widget-env-2))

(define (make-channel-sink channel)
  (spawn
   (lambda ()
     (let loop ()
       (receive channel)
       (loop)))))

(define (realize-widget parent-bitmap child-rectangle
			realization-proc)
  (let* ((child-bitmap (make-bitmap parent-bitmap child-rectangle))
	 (child-env (make-vanilla-widget-env child-bitmap)))
    (realization-proc child-env)))

(define (make-window-system label width height)
  (call-with-values
   (lambda () (make-display label width height))
   (lambda (root-bitmap mouse-channel keyboard-channel)
     (make-widget-env root-bitmap
		      mouse-channel
		      keyboard-channel
		      (make-channel)
		      (make-async-channel)))))

