; GUI Demo
(define (go)
  (set! *resdb*
    (dm-open-db "GUIdemo" 1))
  (frm-popup 10 1777 
    (let ((f 1000)) 
      (lambda (e . a)
	(case e
	  ((frm-open)
		(ctl-set-val 1101 #t))
	  ((lst-select)
	    (fld-set-text 1002 
	    (lst-get-text 1100 (cadr a))))
	  ((timeout) 
	    (fld-set-text 1004
		(current-ticks)))
	  ((menu)
	      (case (car a)
		((2223)
		  (lst-set-sel 1100
		  (string->object
		    (fld-get-text 1001))))
		((2224)
		 (fld-set-text 1001
			(lst-get-sel 1100)))))
	  ((ctl-repeat)
	      (case (car a)
		((1600)
		  (sound (integer (set! f 
			(/ f 1.03))) 50) #f)
		((1601)
		  (sound (integer (set! f 
			(* f 1.03))) 50) #f)))
	  ((ctl-select)
	      (case (car a)
		((1801) (scroller))
		((1900)
		  (fld-set-text 1002 
			(fld-get-text 1001)))
		((1901)
		  (ctl-set-val 1102
		   (not (ctl-get-val 1102))))
		((1902)
		  (frm-return
			(fld-get-text 1002)))
		((1903)
		  (fld-set-text 1001
		    (nested)))
		((1101)
		  (frm-show 1903 (cadr a)))
		(else #f)))
	  ((pop-select) (write a) #f)
	  ((frm-close) (message "Bye")
		#f)
	  ((scl-repeat) (sound (+ 100 (* 100 (caddr a))) 50) #f)
	  (else #f))))))

(define (nested)
  (frm-popup 1888 
      (lambda (e . a)
	(case e
	  ((ctl-select)
	      (case (car a)
		((1001) (frm-return
			(fld-get-text 1000)))
		((1002) (frm-return 42))))
	  (else #f)))))

(define (chain . hs)
  (lambda a
    (if (null? hs) #f
      (or (apply (car hs) a)
	(apply (apply chain (cdr hs))
		     a)))))

(define (scroller)
  (frm-popup 1666 (chain
    (scroll-handler 2000 2050)
    (scroll-handler 2100 2150)
      (lambda (e . a)
	(case e
	  ((frm-open)
		(fld-set-text 2000
		"The quick brown fox jumped over the lazy dog.")
		(fld-set-text 2100
		"Ein Neger mit Gazelle zagt im Regen nie."))
	  ((ctl-select) (frm-return #n))
	  (else #f))))))

; a generic scroll handler
(define (scroll-handler fld-id scl-id)
  (define (max a b) (if (>= a b) a b))
  (define (update-scroll) 
    (let ((p (fld-get-scroll fld-id)))
      (scl-set-val scl-id (list (car p)
	0 (max 0 (- (cadr p) (caddr p)))
	(caddr p)))))
  (lambda (event . args)
    (case event
      ((key-down) 
	(if (eq? fld-id (frm-get-focus))
	  (begin
	    (case (car args)
	      ((##0b) ; hw up button
		(fld-scroll fld-id -1))
	      ((##0c) ; hw down button
		(fld-scroll fld-id 1))
	      (else #n))
	    (update-scroll) #f)
	  #f))
      ((scl-repeat) 
	(if (eq? scl-id (car args))
	   (fld-scroll fld-id 
	       (- (cadr args) (caddr args))) 
	    #f)
	#f) ; to make repeat work
      ((fld-changed) 
	(if (eq? fld-id (car args))
	  (update-scroll)
	  #f))
      (else #f))))