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

;; Frames: Fenster mit Rahmen drum

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

(define-record-type frame :frame
  (really-make-frame widget-env highlight-channel)
  frame?
  (widget-env frame-widget-env)
  (highlight-channel frame-highlight-channel))

(define frame-border 8)

(define (make-frame realize widget-env)
  (let* ((frame-bitmap (widget-env-bitmap widget-env))
	 (outer-rectangle (bitmap-rectangle frame-bitmap))
	 (frame-rectangle
	  (make-rectangle 0 0
			  (- (rectangle-width outer-rectangle) 1)
			  (- (rectangle-height outer-rectangle) 1)))
	 (highlight-rectangle
	  (make-rectangle 1 1
			  (- (rectangle-width outer-rectangle) 3)
			  (- (rectangle-height outer-rectangle) 3)))
	 (child-rectangle
	  (make-rectangle frame-border frame-border
			  (- (rectangle-width outer-rectangle)
			     (* 2 frame-border))
			  (- (rectangle-height outer-rectangle)
			     (* 2 frame-border))))
	 (child-mouse-channel (make-channel))
	 (child-widget-env
	  (make-widget-env (make-bitmap frame-bitmap child-rectangle)
			   child-mouse-channel
			   (widget-env-keyboard-channel widget-env)
			   (widget-env-control-in-channel widget-env)
			   (widget-env-control-out-channel widget-env)))
	 
	 
	 (highlight-channel (make-channel))
	 (draw-highlight
	  (lambda (rator)
	    (bitmap-draw-rectangle frame-bitmap rator highlight-rectangle)))
	 (mouse-translation
	  (make-point frame-border frame-border)))

    (bitmap-clear frame-bitmap)
    (bitmap-draw-rectangle frame-bitmap 'set frame-rectangle)
    
    (spawn
     (lambda ()
       (let loop ()
	 (send child-mouse-channel
	       (mouse-message-translate
		mouse-translation
		(receive (widget-env-mouse-channel widget-env))))
	 (loop))))

    (spawn
     (lambda ()
       (let loop ((highlight? #f))
	 (let ((new-highlight? (receive highlight-channel)))
	   (cond
	    ((and highlight? (not new-highlight?))
	     (draw-highlight 'clear))
	    ((and (not highlight?) new-highlight?)
	     (draw-highlight 'copy)))
	   (loop new-highlight?)))))

    (values (really-make-frame widget-env highlight-channel)
	    (realize child-widget-env))))

(define (frame=? frame-1 frame-2)
  (eq? frame-1 frame-2))

(define (frame-highlight! frame highlight?)
  (send (frame-highlight-channel frame) highlight?))

;; Test

(define (test-frame-with-button)
  (make-frame 
   (lambda (widget-env)
     (make-button "Click me!"
		  (lambda ()
		      (display "Click! Click!")
		      (newline))
		  widget-env))
   (make-window-system "Button/Frame Test" 320 200)))