#lang scheme/gui

(require mzlib/class
	 mzlib/class100
	 mzlib/etc)

(define my-txt #f)
(define my-lb #f)
(define noisy? #f)

(define mdi-frame #f)
(define (mdi)
  (set! mdi-frame (make-object frame% "Item Test" #f
			       #f #f #f #f
			       '(mdi-parent)))
  (send mdi-frame maximize #t)
  (send mdi-frame show #t))

(define default-parent-frame #f)
(define (parent-frame)
  (set! default-parent-frame (make-object frame% "Item Test Parent" #f
			       100 100))
  (send default-parent-frame show #t))

(when (namespace-variable-value 'mdi? #t (lambda () #f))
  (mdi))

(define (add-frame-style style)
  (let* ([style (if use-metal?
		    (cons 'metal style)
		    style)]
	 [style (if float-frame?
		    (cons 'float style)
		    style)]
	 [style (if no-caption?
		    (cons 'no-caption style)
		    style)])
    style))

(define make-frame
  (opt-lambda (% name [parent #f] [x #f] [y #f] [w #f] [h #f] [style '()])
    (make-object % name
		 (or parent mdi-frame default-parent-frame)
		 x y w h
		 (if mdi-frame
		     (cons 'mdi-child style)
		     (add-frame-style style)))))

(define special-font (send the-font-list find-or-create-font
			   20 'decorative 
			   'normal 'bold
			   #f))
(define ($ font) (or font normal-control-font))

(define (make-h&s cp f)
  (make-object button% "Hide and Show" cp
	       (lambda (b e) (send f show #f) (send f show #t))))

(define (add-hide name w cp)
  (let ([c (make-object check-box% (format "Show ~a" name) cp
			(lambda (c e) (send w show (send c get-value))))])
    (send c set-value #t)))

(define (add-disable name w ep)
  (let ([c (make-object check-box% (format "Enable ~a" name) ep
			(lambda (c e) (send w enable (send c get-value))))])
    (send c set-value (send w is-enabled?))))

(define (add-disable-radio name w i ep)
  (let ([c (make-object check-box% (format "Enable ~a" name) ep
			(lambda (c e) (send w enable i (send c get-value))))])
    (send c set-value #t)))

(define (add-change-label name w lp orig other)
  (make-object button% (format "Relabel ~a" name) lp
	       (let ([orig-name (if orig orig (send w get-label))]
		     [changed? #f])
		 (lambda (b e)
		   (if changed?
		       (unless (null? orig-name)
			 (send w set-label orig-name))
		       (send w set-label other))
		   (set! changed? (not changed?))))))

(define (add-focus-note frame panel)
  (define m (make-object message% "focus: ??????????????????????????????" panel))
  (send
   (make-object
    (class100-asi timer%
      (inherit start)
      (override
	[notify
	 (lambda ()
	   (when (send frame is-shown?)
	     (send m set-label
		   (let* ([w (with-handlers ([void (lambda (x) #f)])
			       (let ([f (get-top-level-focus-window)])
				 (and f (send f get-focus-window))))]
			  [l (and w (send w get-label))])
		     (let ([s (format "focus: ~a ~a" (or l "") w)])
		       (substring s 0 (min 200 (string-length s))))))
	     (start 1000 #t)))])))
   start 1000 #t))

(define (add-pre-note frame panel)
  (define m (make-object message% "pre: ??????????????????????????????" panel))
  (define cm (make-object check-box% "Drop Mouse Events" panel void))
  (define ck (make-object check-box% "Drop Key Events" panel void))
  (lambda (win e)
    (let ([m? (is-a? e mouse-event%)])
      (send m set-label
	    (let ([s (format "pre: ~a ~a ~a,~a"
			     (if m? "mouse" "key")
			     (let ([l (send win get-label)])
			       (if (not l)
				   win
				   l))
			     (send e get-x)
			     (send e get-y))])
	      (substring s 0 (min 200 (string-length s)))))
      (and (not (or (eq? win cm) (eq? win ck)))
	   (or (and m? (send cm get-value))
	       (and (not m?) (send ck get-value)))))))

(define (add-enter/leave-note frame panel)
  (define m (make-object message% "enter: ??????????????????????????????" panel))
  (lambda (win e)
    (when (memq (send e get-event-type) '(enter leave))
      (let ([s (format "~a: ~a"
		    (send e get-event-type)
		    (let ([l (send win get-label)])
		      (if (not l)
			  win
			  l)))])
	(when noisy? (printf "~a~n" s))
	(send m set-label (substring s 0 (min 200 (string-length s))))))))

(define (add-click-intercept frame panel)
  (define cp (make-object check-box% "Popup on Click" panel void))
  (lambda (win e)
    (if (and (send e button-down?)
	     (not (eq? cp win))
	     (send cp get-value))
	(let ([m (make-object popup-menu%)])
	  (make-object menu-item% (format "Click on ~a" win)
		       m (lambda (i e)
			   (unless (eq? (send m get-popup-target) win)
			     (printf "Wrong owner!~n"))))
	  (send win popup-menu m 
		(inexact->exact (send e get-x))
		(inexact->exact (send e get-y)))
	  #t)
	#f)))

(define (add-cursors frame panel ctls)
  (let ([old #f]
	[f-old #f]
	[bc (make-object cursor% 'bullseye)]
	[cc (make-object cursor% 'cross)])
    (make-object check-box% "Control Bullseye Cursors" panel
		 (lambda (c e)
		   (printf "~a~n" e)
		   (if (send c get-value)
		       (set! old 
			     (map (lambda (b) 
				    (begin0
				     (send b get-cursor)
				     (send b set-cursor bc)))
				  ctls))
		       (map (lambda (b c) (send b set-cursor c))
			    ctls old))))
    (make-object check-box% "Frame Cross Cursor" panel
		 (lambda (c e)
		   (if (send c get-value)
		       (begin
			 (set! f-old (send frame get-cursor))
			 (send frame set-cursor cc))
		       (send frame set-cursor f-old))))
    (make-object check-box% "Busy Cursor" panel
		 (lambda (c e)
		   (if (send c get-value)
		       (begin-busy-cursor)
		       (end-busy-cursor))))))
		       
(define OTHER-LABEL "XXXXXXXXXXXXXXXXXXXXXX")

(define-values (icons-path local-path)
  (let ([d (this-expression-source-directory)])
    (values
     (lambda (n)
       (build-path (collection-path "icons") n))
     (lambda (n)
       (build-path d n)))))

(define on-demand-menu-item%
  (class100 menu-item% (-name . args)
    (private-field
     [name -name])
    (override
      [on-demand
       (lambda ()
	 (printf "Menu item ~a demanded~n" name))])
    (sequence
      (apply super-init name args))))

(define popup-test-canvas%
  (class100 canvas% (-objects -names . args)
    (inherit popup-menu get-dc refresh)
    (private-field
      [objects -objects]
      [names -names]
      [tab-in? #f]
      [last-m null]
      [last-choice #f])
    (override
      [on-paint
       (lambda ()
	 (let ([dc (get-dc)])
	   (send dc clear)
	   (send dc draw-text "Left: popup hide state" 0 0)
	   (send dc draw-text "Right: popup previous" 0 20)
	   (send dc draw-text (format "Last pick: ~s" last-choice) 0 40)
	   (when tab-in?
	     (send dc draw-text "Tab in" 0 60))))]
      [on-event
       (lambda (e)
	 (when (send e button-down?)
	     (let ([x (send e get-x)]
		   [y (send e get-y)]
		   [m (if (or (null? last-m)
			      (send e button-down? 'left)
			      (send e button-down? 'middle))
			  (let ([m (make-object popup-menu% "T&itle"
						(lambda (m e)
						  (unless (is-a? m popup-menu%)
						    (error "bad menu object"))
						  (unless (and (is-a? e control-event%)
							       (memq (send e get-event-type)
								     '(menu-popdown menu-popdown-none)))
						    (error "bad event object"))
						  (printf "popdown ok~n")))]
				[make-callback 
				 (let ([id 0])
				   (lambda ()
				     (set! id (add1 id))
				     (let ([id id])
				       (lambda (m e)
					 (set! last-choice id)
					 (on-paint)))))])
			    (for-each
			     (lambda (obj name)
			       (make-object menu-item%
					    (string-append
					     name ": "
					     (if (send obj is-shown?)
						 "SHOWN"
						 "<h i d d e n>"))
					    m
					    (make-callback)))
			     objects names)
			    (make-object on-demand-menu-item%
					 "[on-demand hook]"
					 m
					 void)
			    (let mloop ([m m][sub-at-50? #t])
			      (let ([sm (if (and sub-at-50?
						 (send e button-down? 'middle))
					    m
					    (make-object menu% "Too Tall" m))])
				(let loop ([n 1])
				  (unless (= n 101)
				    (if (and sub-at-50? (= n 50))
					(let ([m (make-object menu% "Item 50" sm)])
					  (mloop m #f))
					(make-object menu-item% (format "Item ~a" n) sm void))
				    (when (zero? (modulo (- n 5) 10))
				      (make-object separator-menu-item% sm))
				    (loop (add1 n))))))
			    m)
			  last-m)])
	       (set! last-m m)
	       (popup-menu m (inexact->exact x) (inexact->exact y)))))]
      [on-tab-in (lambda () (set! tab-in? #t) (refresh))]
      [on-focus (lambda (on?)
		  (when (and tab-in? (not on?))
		    (set! tab-in? #f)
		    (refresh)))])
    (sequence
      (apply super-init args))))

(define prev-frame #f)

(define bitmap2%
  (class100 bitmap% args
    (inherit ok?)
    (sequence
      (apply super-init args)
      (unless (ok?)
	(printf "bitmap failure: ~s~n" args)))))

(define (active-mixin %)
  (class %
    (define pre-on void)
    (define click-i void)
    (define el void)
    (override* [on-subwindow-event (lambda args 
                                     (apply el args)
                                     (or (apply pre-on args)
                                         (apply click-i args)
                                         (super on-subwindow-event . args)))]
               [on-subwindow-char (lambda args 
                                    (or (apply pre-on args)
                                        (super on-subwindow-char . args)))]
               [on-activate (lambda (on?) (printf "active: ~a~n" on?))]
               [on-move (lambda (x y) (printf "moved: ~a ~a~n" x y))]
               [on-size (lambda (x y) (printf "sized: ~a ~a~n" x y))])
    (public* [set-info
              (lambda (ep)
                (set! pre-on (add-pre-note this ep))
                (set! click-i (add-click-intercept this ep))
                (set! el (add-enter/leave-note this ep)))])
    (super-new)))

(define active-frame% (active-mixin frame%))
(define active-dialog% (active-mixin dialog%))

(define (trace-mixin c%)
  (class100 c% (-name . args)
    (private-field [name -name])
    (override
      [on-superwindow-show
       (lambda (on?)
	 (printf "~a ~a~n" name (if on? "show" "hide")))]
      [on-superwindow-enable
       (lambda (on?)
	 (printf "~a ~a~n" name (if on? "on" "off")))])
    (sequence
      (apply super-init name args))))

(define (auto-mixin c% v)
  (class c%
    (super-new [auto-resize v])))

(define return-bmp 
  (make-object bitmap2% (icons-path "return.xbm") 'xbm))
(define bb-bmp
  (make-object bitmap2% (icons-path "bb.gif") 'gif))
(define mred-bmp
  (make-object bitmap2% (icons-path "mred.xbm") 'xbm))
(define nruter-bmp
  (make-object bitmap2% (local-path "nruter.xbm") 'xbm))

(define (add-label-direction label-h? l)
  (if (not label-h?)
      (cons 'vertical-label l)
      l))

(define (make-ctls ip cp lp add-testers ep radio-h? label-h? null-label? stretchy? alt-inits? msg-auto? font)
  
  (define-values (l il)
    (let ([p (make-object horizontal-panel% ip)])
      (send p stretchable-width stretchy?)
      (send p stretchable-height stretchy?)
      
      (let ()
	(define l (make-object (trace-mixin (auto-mixin message% msg-auto?)) "L\u03B9&st" p null ($ font)))
	(define il (make-object (trace-mixin (auto-mixin message% msg-auto?)) return-bmp p null ($ font)))
	
	(add-testers "Message" l)
	(add-change-label "Message" l lp #f OTHER-LABEL)
	
	(add-testers "Image Message" il)
	(add-change-label "Image Message" il lp return-bmp nruter-bmp)
	
	(values l il))))
  
  (define b (make-object (trace-mixin button%)
			 "H\u03A3&llo" ip ; \u03A3 is eta
			 (lambda (b e)
			   (send b enable #f)
			   (sleep/yield 5)
			   (send b enable #t))
			 null ($ font)))
  
  (define ib (make-object (trace-mixin button%) bb-bmp ip void null ($ font)))
  
  ; (define ib2 (make-object button% return-bmp ip void))
  
  (define lb (make-object (trace-mixin list-box%)
			  (if null-label? #f "L\u03B9&st") ; \u03B9 is iota
			  '("Appl\u03A3" "Banana" "Coconut & Donuts" "Eclair" "French Fries" "Gatorade" "Huevos Rancheros") ; \u03A3 is eta
			  ip void
			  (add-label-direction label-h? '(single))
			  (if alt-inits? 2 #f)
			  (or font view-control-font) ($ font)))
  
  (define cb (make-object (trace-mixin check-box%) "C&h\u03A3ck" ip void null alt-inits? ($ font))) ; \u03A3 is eta
  
  (define icb (make-object (trace-mixin check-box%) mred-bmp ip void null alt-inits? ($ font)))
  
  (define rb (make-object (trace-mixin radio-box%)
			  (if null-label? #f "R&ad\u03B9o") ; \u03B9 is iota
			  '("F\u03B9rst" "Dos" "T&rio")
			  ip void 
			  (add-label-direction 
			   label-h? 
			   (if radio-h?
			       '(horizontal)
			       '(vertical)))
			  (if alt-inits? 2 0)
			  ($ font)))
  
  (define irb (make-object (trace-mixin radio-box%)
			   (if null-label? #f "Image Ra&dio")
			   (list return-bmp nruter-bmp)
			    ip void 
			    (add-label-direction 
			     label-h? 
			     (if radio-h?
				 '(horizontal)
				 '(vertical)))
			  (if alt-inits? 1 0)
			  ($ font)))
  
  (define ch (make-object (trace-mixin choice%)
			  (if null-label? #f "Ch&o\u03B9ce") ; \u03B9 is iota
			  '("Alpha" "Beta" "Gamma" "Delta & R\u03A3st") ; \u03A3 is eta
			  ip void
			  (add-label-direction label-h? null)
			  (if alt-inits? 3 0)
			  ($ font)))
  
  (define txt (make-object (trace-mixin text-field%)
			   (if null-label? #f "T\u03A3&xt") ; \u03A3 is eta
			   ip void
			   "initial & starting"
			   (add-label-direction label-h? '(single))
			   ($ font)))
  
  (set! my-txt txt)
  (set! my-lb lb)

  (add-testers "Button" b)
  (add-change-label "Button" b lp #f OTHER-LABEL)
  
  (add-testers "Image Button" ib)
  (add-change-label "Image Button" ib lp bb-bmp return-bmp)
  
  (add-testers "List" lb)
  (add-change-label "List" lb lp #f OTHER-LABEL)
  
  (add-testers "Checkbox" cb)
  (add-change-label "Checkbox" cb lp #f OTHER-LABEL)
  
  (add-testers "Image Checkbox" icb)
  (add-change-label "Image Checkbox" icb lp mred-bmp bb-bmp)
  
  (add-testers "Radiobox" rb)
  (add-disable-radio "Radio Item `First'" rb 0 ep)
  (add-disable-radio "Radio Item `Dos'" rb 1 ep)
  (add-disable-radio "Radio Item `Trio'" rb 2 ep)
  (add-change-label "Radiobox" rb lp #f OTHER-LABEL)
  
  (add-testers "Image Radiobox" irb)
  (add-disable-radio "Radio Image Item 1" irb 0 ep)
  (add-disable-radio "Radio Image Item 2" irb 1 ep)
  (add-change-label "Image Radiobox" irb lp #f OTHER-LABEL)
  
  (add-testers "Choice" ch)
  (add-change-label "Choice" ch lp #f OTHER-LABEL)
  
  (add-testers "Text" txt)
  (add-change-label "Text" txt lp #f OTHER-LABEL)
  
  (let ([items (list l il 
		     b ib 
		     lb
		     cb icb 
		     rb irb 
		     ch
		     txt)]
	[names (list "label" "image label"
		     "button" "image button"
		     "list box"
		     "checkbox" "image checkbox"
		     "radio box" "image radiobox"
		     "choice"
		     "text")])
    (make-object choice%
		 "Set Focus"
		 (cons "..." names)
		 lp
		 (lambda (c e)
		   (let ([v (send c get-selection)])
		     (when (positive? v)
		       (send (list-ref items (sub1 v)) focus)
		       (send c set-selection 0)))))
    (cons (make-object popup-test-canvas% 
		       items
		       names
		       cp)
	  items)))

(define (add-deleted-adds panel l)
  (define v #f)
  
  (make-object choice% "New Deleted"
	       (list*
		"..."
		"*Activate Last*"
		(map car l))
	       panel
	       (lambda (c e)
		 (let ([i (send c get-selection)])
		   (send c set-selection 0)
		   (case i
		     [(0) (void)]
		     [(1) (send (send v get-parent) add-child v)]
		     [else (set! v ((cadr (list-ref l (- i 2)))))])))))

(define (add-big-deleted-adds panel)
  (add-deleted-adds
   panel
   (list (list "Message" (lambda () (instantiate message% ("Hello" panel) [style '(deleted)])))
	 (list "Bitmap Message" (lambda () (instantiate message% (bb-bmp panel) [style '(deleted)])))
	 (list "Icon Message" (lambda () (instantiate message% ('app panel) [style '(deleted)])))
	 (list "Button" (lambda () (instantiate button% ("Hello" panel void) [style '(deleted)])))
	 (list "Bitmap Button" (lambda () (instantiate button% (bb-bmp panel void) [style '(deleted)])))
	 (list "Checkbox" (lambda () (instantiate check-box% ("Hello" panel void) [style '(deleted)])))
	 (list "Bitmap Checkbox" (lambda () (instantiate check-box% (bb-bmp panel void) [style '(deleted)])))
	 (list "Radio Box" (lambda () (instantiate radio-box% ("Hello" (list "A" "B" "C") panel void) [style '(vertical deleted)])))
	 (list "Bitmap Radio Box" (lambda () (instantiate radio-box% ("Hello" (list bb-bmp bb-bmp) panel void) [style '(vertical deleted)]))))))

(define (add-med-deleted-adds panel)
  (add-deleted-adds
   panel
   (list (list "Canvas" (lambda () (instantiate canvas% (panel) [style '(deleted)])))
	 (list "Editor Canvas" (lambda () (instantiate editor-canvas% (panel) [style '(deleted)])))
	 (list "Slider" (lambda () (instantiate slider% ("Hello" 1 3 panel void) [style '(deleted vertical)])))
	 (list "Gauge" (lambda () (instantiate gauge% ("Hello" 3 panel) [style '(deleted vertical)])))
	 (list "Tab Panel" (lambda () (instantiate tab-panel% ('("Hello" "Bye") panel void) [style '(deleted)])))
	 (list "Group Box Panel" (lambda () (instantiate group-box-panel% ('"Hello" panel) [style '(deleted)])))
	 (list "Panel" (lambda () (instantiate panel% (panel) [style '(deleted border)]))))))

(define use-dialogs? #f)
(define use-metal? #f)
(define float-frame? #f)
(define no-caption? #f)

(define (big-frame h-radio? v-label? null-label? stretchy? font initially-disabled? alternate-init? msg-auto?)
  (define f (make-frame (if use-dialogs?
			    active-dialog%
			    active-frame%)
			"T\u03A3ster")) ; \u03A3 is eta
  
  (define hp (make-object horizontal-panel% f))
  
  (define ip (make-object vertical-panel% hp))
  (define cp (make-object vertical-panel% hp))
  (define ep (make-object vertical-panel% hp))
  (define lp (make-object vertical-panel% hp))
  
  (define (basic-add-testers name w)
    (add-hide name w cp)
    (add-disable name w ep))
  
  (define add-testers
    (if stretchy?
	(lambda (name control)
	  (send control stretchable-width #t)
	  (send control stretchable-height #t)
	  (basic-add-testers name control))
	basic-add-testers))
  
  (define fp (make-object vertical-panel% ip))
  
  (define tp 
    (if #f
	(make-object group-box-panel% "Sub" fp null (or font small-control-font))
	(make-object tab-panel% '("Sub" "Panel") fp void '(no-border) ($ font))))

  (when initially-disabled?
    (send tp enable #f))
    
  (make-h&s cp f)
  
  (add-testers "Sub-panel" fp)
  
  (send tp set-label "Sub-sub panel")
  (add-testers "Sub-sub-panel" tp)

  (let ([ctls (make-ctls tp cp lp add-testers ep h-radio? v-label? null-label? stretchy? alternate-init? msg-auto? font)])
    (add-focus-note f ep)
    (send f set-info ep)
    
    (add-cursors f lp ctls)

    (add-big-deleted-adds lp))

  (send f show #t)
  (set! prev-frame f)
  f)

(define (med-frame plain-slider? label-h? null-label? stretchy? font initially-disabled? alternate-init? msg-auto?)
  (define f2 (make-frame (if use-dialogs?
			    active-dialog%
			    active-frame%)
			 "Tester2"))

  (define hp2 (make-object horizontal-panel% f2))
  
  (define ip2-0 (make-object vertical-panel% hp2))
  (define cp2 (make-object vertical-panel% hp2))
  (define ep2 (make-object vertical-panel% hp2))
  (define lp2 (make-object vertical-panel% hp2))
  
  (define (basic-add-testers2 name w)
    (add-hide name w cp2)
    (add-disable name w ep2))
  
  (define add-testers2
    (if stretchy?
	(lambda (name control)
	  (send control stretchable-width #t)
	  (send control stretchable-height #t)
	  (basic-add-testers2 name control))
	basic-add-testers2))

  (define fp2 (make-object vertical-panel% ip2-0))
  (define ip2 (make-object group-box-panel% "Sub" fp2))

  (when initially-disabled?
    (send ip2 enable #f))

  (make-h&s cp2 f2)
  
  (add-testers2 "Sub-panel" fp2)
  (send ip2 set-label "Sub-sub panel")
  (add-testers2 "Sub-sub-panel" ip2)
  
  (make-object text-field% #f ip2 void "start focus here")

  (when prev-frame
    (add-disable "Previous Tester Frame" prev-frame ep2))
  
  (let ()
    (define co
      (make-object combo-field% "Greet:" '("Hola" "Ni Hao") ip2 void "hello" null ($ font)))

    (define sh (make-object slider% 
			    (if null-label? #f "H S&lid\u03A3r") 0 10 ip2
			    (lambda (s e)
			      (send gh set-value (* 10 (send sh get-value))))
			    5
			    (add-label-direction 
			     label-h? 
			     (if plain-slider? '(horizontal plain) '(horizontal)))
			    ($ font)))
    
    (define sv (make-object slider% 
			    (if null-label? #f "V Sl&id\u03A3r") 0 10 ip2 
			    (lambda (s e)
			      (send gv set-value (* 10 (send sv get-value))))
			    5
			    (add-label-direction 
			     label-h? 
			     (if plain-slider? '(vertical plain) '(vertical)))
			    ($ font)))
    
    (define gh (make-object gauge% 
			    (if null-label? #f "H G&aug\u03A3") 100 ip2
			    (add-label-direction 
			     label-h? 
			     '(horizontal))
			    ($ font)))
    
    (define gv (make-object gauge% 
			    (if null-label? #f "V Ga&ug\u03A3") 100 ip2
			    (add-label-direction 
			     label-h? 
			     '(vertical))
			    ($ font)))
    
    (define txt (make-object text-field% 
			     (if null-label? #f "T&ext \u7238") ; \u7238 is Chinese "father"
			     ip2 void 
			     "initial & starting"
			     (add-label-direction 
			      label-h? 
			      '(multiple))
			     ($ font)))

    (define tab (make-object tab-panel% 
			     '("Appl\u03A3" "B&anana") ip2 void
			     null
			     ($ font)))

    (define grp (make-object group-box-panel% 
			     "Group\u03A3" ip2
			     null (or font small-control-font)))

    (make-object button% "OK" tab void)
    (make-object button% "Cancel" grp void)

    (add-testers2 "Combo" co)
    (add-testers2 "Horiz Slider" sh)
    (add-testers2 "Vert Slider" sv)
    (add-testers2 "Horiz Gauge" gh)
    (add-testers2 "Vert Gauge" gv)
    ; (add-testers2 "Text Message" cmt)
    ; (add-testers2 "Image Message" cmi)
    (add-testers2 "Text" txt)
    (add-testers2 "Tab" tab)
    (add-testers2 "Group" grp)
    
    (add-change-label "Combo" co lp2 #f OTHER-LABEL)
    (add-change-label "Horiz Slider" sh lp2 #f OTHER-LABEL)
    (add-change-label "Vert Slider" sv lp2 #f OTHER-LABEL)
    (add-change-label "Horiz Gauge" gh lp2 #f OTHER-LABEL)
    (add-change-label "Vert Gauge" gv lp2 #f OTHER-LABEL)
    (add-change-label "Text" txt lp2 #f OTHER-LABEL)
    (add-change-label "Group" grp lp2 #f OTHER-LABEL)
    
    (let* ([items (list co
			sh sv
			gh gv
			; cmt cmi
			txt
			tab grp)]
	   [canvas  (make-object popup-test-canvas% 
				 items
				 (list "h slider" "v slider"
				       "v gauge" "v gauge"
				       ; "text msg" "image msg"
				       "text"
				       "tab" "group")
				 cp2 '(hscroll vscroll))])
      (send canvas accept-tab-focus #t)
      (send canvas init-auto-scrollbars 300 300 0.0 0.0)
      (add-disable "Canvas" canvas ep2)

      (add-focus-note f2 ep2)
      (send f2 set-info ep2)
      
      (add-cursors f2 lp2 (cons canvas items))

      (add-med-deleted-adds lp2))

    (unless use-dialogs?
      (send f2 create-status-line)
      (send f2 set-status-text "This is the status line"))
    (send f2 show #t)
    (set! prev-frame f2)
    f2))

; Need: check, check-test, and enable via menubar
; All operations on Submenus
(define f%
  (class100 frame% args
    (private-field
      ADD-APPLE
      ADD-BANANA
      ADD-COCONUT
      DELETE-APPLE
      DELETE-EXTRA-BANANA
      DELETE-BANANA
      DELETE-COCONUT-0
      DELETE-COCONUT
      DELETE-COCONUT-2
      COCONUT-ID
      DELETE-ONCE
      APPLE-CHECK-ID
      CHINESE)
    (private-field
      menu-bar
      main-menu
      apple-menu
      banana-menu
      coconut-menu
      baseball-ids
      hockey-ids
      enable-item)
    (sequence (apply super-init args))
    (public
      [make-menu-bar
       (lambda ()
	 (let* ([mb (make-object menu-bar% this)]
		[menu (make-object menu% "&Tester" mb)]
		[new (case-lambda 
		      [(l help parent) (make-object menu-item% l parent (lambda (o e) (callback o e)) #f help)]
		      [(l help) (make-object menu-item% l menu (lambda (o e) (callback o e)) #f help)]
		      [(l) (make-object menu-item% l menu (lambda (o e) (callback o e)))])]
		[sep (lambda () (make-object separator-menu-item% menu))])
	   (set! menu-bar mb)
	   (set! main-menu menu)

	   (set! ADD-APPLE (new "Add Apple" "Adds the Apple menu"))
	   (set! ADD-BANANA (new "Add Banana"))
	   (set! ADD-COCONUT (new "Add Coconut"))
	   
	   (make-object on-demand-menu-item% "Append Donut" menu
			(lambda (m e) 
			  (make-object menu-item% "Donut" apple-menu void)))
	   (sep)
	   (set! DELETE-COCONUT-0 (new "Delete Coconut"))
	   (make-object menu-item% "Delete Apple" menu
			(lambda (m e) 
			  (send apple-menu delete)
			  (set! apple-installed? #f)))
	   
	   (sep)
	   (set! enable-item
		 (make-object checkable-menu-item% "Apple Once Disabled" menu
			      (lambda (m e)
				(send DELETE-ONCE enable
				      (not (send enable-item is-checked?))))))
	   
	   (let ([mk-enable (lambda (on?)
			      (lambda (m e)
				(let ([l (send menu-bar get-items)])
				  (unless (null? (cdr l))
				    (send (cadr l) enable on?)))))])
	     (make-object menu-item% "Disable Second" menu (mk-enable #f))
	     (make-object menu-item% "Enable Second" menu (mk-enable #t)))

	   (set! CHINESE (make-object menu-item% "Chinese: \U7238" menu void))
	   
	   (let ([make-menu
		  (opt-lambda (title parent help-string)
		    (let ([m (make-object menu% title parent help-string)])
		      (send m delete)
		      m))])
	     (set! apple-menu (make-menu "Apple" mb #f))
	     (set! banana-menu (make-menu "Banana" mb #f))
	     (set! coconut-menu (make-menu "Coconut" apple-menu "Submenu")))
	   
	   (set! COCONUT-ID coconut-menu)

	   (set! DELETE-ONCE (new "Delete Once" #f apple-menu))
	   (set! DELETE-APPLE (new "Delete Apple" "Deletes the Apple menu" apple-menu))
	   (set! APPLE-CHECK-ID (make-object checkable-menu-item% "Checkable" apple-menu void))

	   (set! DELETE-BANANA (new "Delete Banana" #f banana-menu))
	   (set! DELETE-EXTRA-BANANA (new "Delete First Banana Item" #f banana-menu))

	   (set! DELETE-COCONUT (new "Delete Coconut" #f coconut-menu))
	   (set! DELETE-COCONUT-2 (new "Delete Coconut By Position" #f coconut-menu))))]
      
      [callback
       (lambda (op ev)
	 (cond
	  [(eq? op ADD-APPLE)
	   (send apple-menu restore)
	   (set! apple-installed? #t)]
	  [(eq? op ADD-BANANA)
	   (send banana-menu restore)]
	  [(eq? op ADD-COCONUT)
	   (send coconut-menu restore)]
	  [(eq? op DELETE-ONCE)
	   (send DELETE-ONCE delete)]
	  [(eq? op DELETE-APPLE)
	   (send apple-menu delete)
	   (set! apple-installed? #f)]
	  [(eq? op DELETE-BANANA)
	   (send banana-menu delete)]
	  [(eq? op DELETE-EXTRA-BANANA)
	   (send (car (send banana-menu get-items)) delete)]
	  [(or (eq? op DELETE-COCONUT) (eq? op DELETE-COCONUT-0))
	   (send COCONUT-ID delete)]
	  [(eq? op DELETE-COCONUT-2)
	   (send (list-ref (send apple-menu get-items) 3) delete)]))])
    (private-field
	[mfp (make-object vertical-panel% this)]
	[mc (make-object editor-canvas% mfp)]
	[restp (make-object vertical-panel% mfp)]
	[sbp (make-object horizontal-panel% restp)]
	[mfbp (make-object horizontal-panel% restp)]
	[lblp (make-object horizontal-panel% restp)]
	[badp (make-object horizontal-panel% restp)]
	[e (make-object text%)])
      (sequence
	(send restp stretchable-height #f)
	(send mc min-height 250)
	(send mc set-editor e)
	(send e load-file (local-path "menu-steps.txt")))
      (public
	[make-test-button
	 (lambda (name pnl menu id)
	   (make-object button%
			(format "Test ~a" name) pnl 
			(lambda (b e)
			  (message-box
			   "Checked?"
			   (if (send id is-checked?)
			       "yes"
			       "no")))))]
	[compare
	 (lambda (expect v kind)
	   (unless (or (and (string? expect) (string? v)
			    (string=? expect v))
		       (eq? expect v))
	     (error 'test-compare "~a mismatch: ~s != ~s" kind expect v)))]
	[check-parent
	 (lambda (menu id)
	   (unless use-menubar?
	     (unless (eq? (send id get-parent) menu)
	       (error 'check-parent "parent mismatch: for ~a, ~a != ~a"
		      (send id get-label)
		      (send menu get-label)
		      (send (send (send id get-parent) get-item) get-label)))))]
	[label-test
	 (lambda (menu id expect)
	   (check-parent menu id)
	   (let ([v (send id get-label)])
	     (compare expect v "label")))]
	[top-label-test
	 (lambda (pos expect)
	   (let ([i (send menu-bar get-items)])
	     (and (> (length i) pos)
		  (let ([v (send (list-ref i pos) get-label)])
		    (compare expect v "top label")))))]
	[help-string-test
	 (lambda (menu id expect)
	   (check-parent menu id)
	   (let ([v (send id get-help-string)])
	     (compare expect v "help string")))]
	[find-test
	 (lambda (menu title expect string)
	   (letrec ([find
		     (lambda (menu str)
		       (let ([items (send menu get-items)])
			 (ormap (lambda (i)
				  (and (is-a? i labelled-menu-item<%>)
				       (equal? (send i get-plain-label) str)
				       i))
				items)))]
		    [find-item
		     (lambda (menu str)
		       (or (find menu str)
			   (let ([items (send menu get-items)])
			     (ormap (lambda (i)
				      (and (is-a? i menu%)
					   (find-item i str)))
				    items))))]
		    [v (if use-menubar? 
			   (let ([item (find menu-bar title)])
			     (if item
				 (find-item item string)
				 -1))
			   (find-item menu string))])
	     (compare expect v (format "label search: ~a" string))))]
	[tell-ok
	 (lambda ()
	   (printf "ok~n"))])
      (private-field
	[temp-labels? #f]
	[use-menubar? #f]
	[apple-installed? #f])
      (public
	[via (lambda (menu) (if use-menubar? menu-bar menu))]
	[tmp-pick (lambda (a b) (if temp-labels? a b))]
	[apple-pick (lambda (x a b) (if (and use-menubar? (not apple-installed?))
					x
					(tmp-pick a b)))])
      (sequence
	(make-menu-bar)

	(send apple-menu restore)

	(make-object button%
		     "Delete Tester" sbp 
		     (lambda args
		       (send main-menu delete)))
	(make-object button%
		     "Delete First Menu" sbp
		     (lambda args
		       (send (car (send menu-bar get-items)) delete)))
	(make-object button%
		     "Add Tester" sbp
		     (lambda args
		       (send main-menu restore)))
	(make-object button%
		     "Add Delete Banana" sbp
		     (lambda args
		       (send DELETE-BANANA restore)))
	(make-object button%
		     "Counts" sbp
		     (lambda args
		       (message-box
			"Counts"
			(format "MB: ~a; T: ~a; A: ~a; B: ~a"
				(length (send menu-bar get-items))
				(length (send main-menu get-items))
				(length (send apple-menu get-items))
				(length (send banana-menu get-items))))))

	(make-test-button "Apple Item" mfbp apple-menu APPLE-CHECK-ID)
	(make-object button%
		     "Check in Apple" mfbp
		     (lambda args
		       (send APPLE-CHECK-ID check #t)))
	(make-object button%
		     "Delete/Restore Check" mfbp
		     (lambda args
                       (if (send APPLE-CHECK-ID is-deleted?)
                           (send APPLE-CHECK-ID restore)
                           (send APPLE-CHECK-ID delete))))
	(make-object button%
		     "Toggle Menubar Enable" mfbp
		     (lambda args
		       (send menu-bar enable (not (send menu-bar is-enabled?)))))
	(make-object button%
		     "Toggle Apple Enable" mfbp
		     (lambda args
		       (send apple-menu enable (not (send apple-menu is-enabled?)))))
	
	(make-object button%
		     "Test Labels" lblp 
		     (lambda args
		       (label-test (via main-menu) ADD-APPLE (tmp-pick "Apple Adder" "Add Apple"))
		       (help-string-test (via main-menu) ADD-APPLE (tmp-pick "ADDER" "Adds the Apple menu"))
		       (label-test (via apple-menu) DELETE-APPLE (apple-pick #f "Apple Deleter" "Delete Apple"))
		       (help-string-test (via apple-menu) DELETE-APPLE (apple-pick #f "DELETER"
										   "Deletes the Apple menu"))
		       (label-test (via apple-menu) COCONUT-ID (apple-pick #f "Coconut!" "Coconut"))
		       (help-string-test (via apple-menu) COCONUT-ID (apple-pick #f "SUBMENU" "Submenu"))
		       (label-test (via coconut-menu) DELETE-COCONUT (apple-pick #f "Coconut Deleter" "Delete Coconut")) ; submenu test
		       (help-string-test (via coconut-menu) DELETE-COCONUT (apple-pick #f "CDELETER" #f))
		       (top-label-test 0 (if temp-labels? "Hi" "&Tester"))
		       (top-label-test 1 (if apple-installed? "Apple" #f))
		       (tell-ok)))
	(make-object button%
		     "Find Labels" lblp
		     (lambda args
		       (find-test main-menu (tmp-pick "Hi" "&Tester")
				  ADD-APPLE (tmp-pick "Apple Adder" "Add Apple"))
		       (find-test apple-menu "Apple" (apple-pick -1 DELETE-APPLE DELETE-APPLE)
				  (tmp-pick "Apple Deleter" "Delete Apple"))
		       (find-test apple-menu "Apple" (apple-pick -1 COCONUT-ID COCONUT-ID)
				  (tmp-pick "Coconut!" "Coconut"))
		       (find-test apple-menu "Apple" (apple-pick -1 DELETE-COCONUT DELETE-COCONUT)
				  (tmp-pick "Coconut Deleter" "Delete Coconut"))
		       (tell-ok)))
	(make-object button%
		     "Toggle Labels" lblp
		     (lambda args
		       (set! temp-labels? (not temp-labels?))
		       (let ([menu (via main-menu)])
			 (send ADD-APPLE set-label (tmp-pick "Apple Adder" "Add Apple"))
			 (send DELETE-APPLE set-label (tmp-pick "Apple Deleter" "Delete Apple"))
			 (send COCONUT-ID set-label (tmp-pick "Coconut!" "Coconut"))
			 (send DELETE-COCONUT set-label (tmp-pick "Coconut Deleter" "Delete Coconut"))
			 (send ADD-APPLE set-help-string (tmp-pick "ADDER" "Adds the Apple menu"))
			 (send DELETE-APPLE set-help-string (tmp-pick "DELETER" "Deletes the Apple menu"))
			 (send COCONUT-ID set-help-string (tmp-pick "SUBMENU" "Submenu"))
			 (send DELETE-COCONUT set-help-string (tmp-pick "CDELETER" #f))
			 (send CHINESE set-label (tmp-pick "Chinese: \U7239" "Chinese: \U7238"))
			 (send CHINESE set-shortcut (tmp-pick #\C #\K))
			 (send main-menu set-label (if temp-labels? "Hi" "&Tester")))))
	(letrec ([by-bar (make-object check-box%
				      "Via Menubar" lblp
				      (lambda args
					(set! use-menubar? (send by-bar get-value))))])
	  by-bar)
	
	#f)))

(define (menu-frame)
  (define mf (make-frame f% "Menu Test"))
  (set! prev-frame mf)
  (send mf show #t)
  mf)

(define (panel-frame)
  (define make-p% 
    (lambda (panel%)
      (class100 panel% (parent)
	(override
	  [container-size
	   (lambda (l)
	     (values (apply + (map car l))
		     (apply + (map cadr l))))]
	  [place-children
	   (lambda (l w h)
	     (let-values ([(mw mh) (container-size l)])
	       (let* ([num-x-stretch (apply + (map (lambda (x) (if (caddr x) 1 0)) l))]
		      [num-y-stretch (apply + (map (lambda (x) (if (cadddr x) 1 0)) l))]
		      [dx (floor (/ (- w mw) num-x-stretch))]
		      [dy (floor (/ (- h mh) num-y-stretch))])
		 (let loop ([l l][r null][x 0][y 0])
		   (if (null? l)
		       (reverse r)
		       (let ([w (+ (caar l) (if (caddr (car l)) dx 0))]
			     [h (+ (cadar l) (if (cadddr (car l)) dy 0))])
			 (loop (cdr l)
			       (cons (list x y w h) r)
			       (+ x w) (+ y h))))))))])
	(sequence (super-init parent)))))
  (define f (make-frame frame% "Panel Tests"))
  (define h (make-object horizontal-panel% f))
  (define kind (begin
		 (send h set-alignment 'center 'top)
		 (make-object radio-box%
			      "Kind"
			      '("Panel" "Pane")
			      h
			      void)))
  (define direction (make-object radio-box%
				 "Direction"
				 '("Horionztal" "Vertical" "Diagonal" "None")
				 h
				 void))
  (define h-align (make-object radio-box%
			       "H Alignment"
			       '("Left" "Center" "Right")
			       h
			       void))
  (define v-align (make-object radio-box%
			       "V Alignment"
			       '("Top" "Center" "Bottom")
			       h
			       void))
  (make-object button% "Make Container" f
	       (lambda (b e) (do-panel-frame
			      (let ([kind (send kind get-selection)]
				    [direction (send direction get-selection)])
				(case kind
				  [(0) (case direction
					 [(0) horizontal-panel%]
					 [(1) vertical-panel%]
					 [(2) (make-p% panel%)]
					 [else panel%])]
				  [(1) (case direction
					 [(0) horizontal-pane%]
					 [(1) vertical-pane%]
					 [(2) (make-p% pane%)]
					 [else pane%])]))
			      (case (send h-align get-selection)
				[(0) 'left]
				[(1) 'center]
				[(2) 'right])
			      (case (send v-align get-selection)
				[(0) 'top]
				[(1) 'center]
				[(2) 'bottom]))))
  (send f show #t))

(define (do-panel-frame p% va ha)
  (define f (make-frame frame% "Container Test"))
  (define p (make-object p% f))
  (define b (make-object button% "Add List or Bad" p
			 (lambda (b e)
			   (send p add-child 
				 (if (send c get-value)
				     m1
				     l)))))
  (define c (make-object check-box% "Remove List" p
			 (lambda (c e)
			   (if (send c get-value)
			       (send p delete-child l)
			       (send p add-child l)))))
  (define l (make-object list-box% "List Box" '("A" "B" "C") p
			 (lambda (l e)
			   (if (eq? (send e get-event-type) 'list-box)
			       (send p get-children)
			       (send p change-children reverse)))))
  (define p2 (make-object vertical-panel% p '(border)))
  (define m1 (make-object message% "1" p2))
  (define m2 (make-object message% "2" p2))
  (send p set-alignment va ha)
  (send f show #t))

(define (check-callback-event orig got e types silent?)
  (unless (eq? orig got)
    (error "object not the same"))
  (unless (is-a? e control-event%)
    (error "bad event object"))
  (let ([type (send e get-event-type)])
    (unless (memq type types)
      (error (format "bad event type: ~a" type))))
  (unless silent?
    (printf "Callback Ok~n")))

(define (instructions v-panel file)
  (define c (make-object editor-canvas% v-panel))
  (define m (make-object text%))
  (send c set-editor m)
  (send m load-file (local-path file))
  (send m lock #t)
  (send c min-width 520)
  (send c min-height 200))

(define (open-file file)
  (define f (make-object frame% file #f 300 300))
  (instructions f file)
  (send f show #t))

(define (button-frame frame% style)
  (define f (make-frame frame% "Button Test"))
  (define p (make-object vertical-panel% f))
  (define old-list null)
  (define commands (list 'button))
  (define hit? #f)
  (define b (make-object button%
			 "Hit Me" p
			 (lambda (bx e)
			   (set! hit? #t)
			   (set! old-list (cons e old-list))
			   (check-callback-event b bx e commands #f))
			 style))
  (define c (make-object button%
			 "Check" p
			 (lambda (c e)
			   (for-each
			    (lambda (e)
			      (check-callback-event b b e commands #t))
			    old-list)
			   (printf "All Ok~n"))))
  (define e (make-object button%
			 "Disable Test" p
			 (lambda (c e)
			   (sleep 1)
			   (set! hit? #f)
			   (let ([sema (make-semaphore)])
			     (send b enable #f)
			     (thread (lambda () (sleep 0.5) (semaphore-post sema)))
			     (yield sema)
			     (when hit?
			       (printf "un-oh~n"))
			     (send b enable #t)))))
  (instructions p "button-steps.txt")
  (send f show #t))

(define (checkbox-frame)
  (define f (make-frame frame% "Checkbox Test"))
  (define p f)
  (define old-list null)
  (define commands (list 'check-box))
  (define cb (make-object check-box%
			  "On" p
			  (lambda (cx e)
			    (set! old-list (cons e old-list))
			    (check-callback-event cb cx e commands #f))))
  (define t (make-object button%
			 "Toggle" p
			 (lambda (t e)
			   (let ([on? (send cb get-value)])
			     (send cb set-value (not on?))))))
  (define t2 (make-object button%
			  "Simulation Toggle" p
			  (lambda (t e)
			    (let ([on? (send cb get-value)]
				  [e (make-object control-event% 'check-box)])
			      (send cb set-value (not on?))
			      (send cb command e)))))
  (define c (make-object button%
			 "Check" p
			 (lambda (c e)
			   (for-each
			    (lambda (e)
			      (check-callback-event cb cb e commands #t))
			    old-list)
			   (printf "All Ok~n"))))
  (instructions p "checkbox-steps.txt")
  (send f show #t))

(define (radiobox-frame)
  (define f (make-frame frame% "Radiobox Test"))
  (define p f)
  (define old-list null)
  (define commands (list 'radio-box))
  (define hp (make-object horizontal-panel% p))
  (define _ (send hp stretchable-height #f))
  (define callback (lambda (rb e)
		     (set! old-list (cons (cons rb e) old-list))
		     (check-callback-event rb rb e commands #f)))
  (define rb1-l (list "Singleton"))
  (define rb1 (make-object radio-box% "&Left" rb1-l hp callback))
  (define rb2-l (list "First" "Last"))
  (define rb2 (make-object radio-box% "&Center" rb2-l hp callback))
  (define rb3-l (list "&Top" "&Middle" "&Bottom"))
  (define rb3 (make-object radio-box% "&Right" rb3-l hp callback))

  (define rbs (list rb1 rb2 rb3))
  (define rbls (list rb1-l rb2-l rb3-l))
  (define normal-sel (lambda (rb p) (send rb set-selection p)))
  (define simulate-sel (lambda (rb p)
			 (let ([e (make-object control-event% 'radio-box)])
			   (send rb set-selection p)
			   (send rb command e))))
  (define (mk-err exn?)
    (lambda (f)
      (lambda (rb p)
	(with-handlers ([exn? void])
	  (f rb p)
	  (error "no exn raisd")))))
  (define type-err (mk-err exn:fail:contract?))
  (define mismatch-err (mk-err exn:fail:contract?))

  (define do-sel (lambda (sel n) (for-each (lambda (rb) (sel rb (n rb))) rbs)))
  (define sel-false (lambda (sel) (do-sel sel (lambda (rb) #f))))
  (define sel-minus (lambda (sel) (do-sel (type-err sel) (lambda (rb) -1))))
  (define sel-first (lambda (sel) (do-sel sel (lambda (rb) 0))))
  (define sel-middle (lambda (sel) (do-sel sel (lambda (rb) (floor (/ (send rb get-number) 2))))))
  (define sel-last (lambda (sel) (do-sel sel (lambda (rb) (sub1 (send rb get-number))))))
  (define sel-N (lambda (sel) (do-sel (mismatch-err sel) (lambda (rb) (send rb get-number)))))
  (define (make-selectors title sel)
    (define hp2 (make-object horizontal-panel% p))
    (send hp2 stretchable-height #f)
    (make-object button% (format "Select -1~a" title) hp2 (lambda (b e) (sel-minus sel)))
    (make-object button% (format "Select First~a" title) hp2 (lambda (b e) (sel-first sel)))
    (make-object button% (format "Select Middle ~a" title) hp2 (lambda (b e) (sel-middle sel)))
    (make-object button% (format "Select Last~a" title) hp2 (lambda (b e) (sel-last sel)))
    (make-object button% (format "Select N~a" title) hp2 (lambda (b e) (sel-N sel)))
    (when (equal? title "")
      (make-object button% (format "Select #f~a" title) hp2 (lambda (b e) (sel-false sel)))))
  (make-selectors "" normal-sel)
  (make-selectors " by Simulate" simulate-sel)
  (make-object button% "Check" p
	       (lambda (c e)
		 (for-each
		  (lambda (rb l)
		    (let loop ([n 0][l l])
		      (unless (null? l)
			(let ([a (car l)]
			      [b (send rb get-item-label n)])
			  (unless (string=? a b)
			    (error "item name mismatch: ~s != ~s" a b)))
			(loop (add1 n) (cdr l)))))
		  rbs rbls)
		 (for-each
		  (lambda (rbe)
		    (check-callback-event (car rbe) (car rbe) (cdr rbe) commands #t))
		  old-list)
		 (printf "All Ok~n")))
  (instructions p "radiobox-steps.txt")
  (send f show #t))

(define (choice-or-list-frame list? list-style empty?)
  (define f (make-frame frame% (if list? "List Test" "Choice Test")))
  (define p f)
  (define-values (actual-content actual-user-data)
    (if empty?
	(values null null)
	(values '("Alpha" "Beta" "Gamma")
		(list #f #f #f))))
  (define commands 
    (if list?
	(list 'list-box 'list-box-dclick)
	(list 'choice)))
  (define old-list null)
  (define multi? (or (memq 'multiple list-style)
		     (memq 'extended list-style)))
  (define callback
    (lambda (cx e)
      (when (zero? (send c get-number))
	    (error "Callback for empty choice/list"))
      (set! old-list (cons e old-list))
      (cond
       [(eq? (send e get-event-type) 'list-box-dclick)
	; double-click
	(printf "Double-click~n")
	(unless (send cx get-selection)
	  (error "no selection for dclick"))]
       [else
	; misc multi-selection
	(printf "Changed: ~a~n" (if list?
				    (send cx get-selections)
				    (send cx get-selection)))])
      (check-callback-event c cx e commands #f)))
  (define c (if list?
		(make-object list-box% "Tester" actual-content p callback list-style)
		(make-object choice% "Tester" actual-content p callback)))
  (define counter 0)
  (define append-with-user-data? #f)
  (define ab (make-object button%
			  "Append" p
			  (lambda (b e)
			    (set! counter (add1 counter))
			    (let ([naya (format "~aExtra ~a" 
						(if (= counter 10)
						    (string-append
						     "This is a Really Long Named Item That Would Have Used the Short Name, Yes "
						     "This is a Really Long Named Item That Would Have Used the Short Name ")
						    "")
						counter)]
				  [naya-data (box 0)])
			      (set! actual-content (append actual-content (list naya)))
			      (set! actual-user-data (append actual-user-data (list naya-data)))
			      (if (and list? append-with-user-data?)
				  (send c append naya naya-data)
				  (begin
				    (send c append naya)
				    (when list?
					  (send c set-data 
						(sub1 (send c get-number))
						naya-data))))
			      (set! append-with-user-data?
				    (not append-with-user-data?))))))
  (define cs (when list? 
	       (make-object button%
			    "Visible Indices" p
			    (lambda (b e)
			      (printf "top: ~a~nvisible count: ~a~n"
				      (send c get-first-visible-item)
				      (send c number-of-visible-items))))))
  (define cdp (make-object horizontal-panel% p))
  (define rb (make-object button% "Clear" cdp
			  (lambda (b e)
			    (set! actual-content null)
			    (set! actual-user-data null)
			    (send c clear))))
  (define (gone l n)
    (if (zero? n)
        (cdr l)
        (cons (car l) (gone (cdr l) (sub1 n)))))
  (define (delete p)
    (send c delete p)
    (when (<= 0 p (sub1 (length actual-content)))
      (set! actual-content (gone actual-content p))
      (set! actual-user-data (gone actual-user-data p))))
  (define db (if list?
		 (make-object button%
			      "Delete" cdp
			      (lambda (b e)
				(let ([p (send c get-selection)])
				  (delete p))))
		 null))
  (define dab (if list?
		  (make-object button%
			       "Delete Above" cdp
			       (lambda (b e)
				 (let ([p (send c get-selection)])
				   (delete (sub1 p)))))
		  null))
  (define dbb (if list?
		  (make-object button%
			       "Delete Below" cdp
			       (lambda (b e)
				 (let ([p (send c get-selection)])
				   (delete (add1 p)))))
		  null))
  (define setb (if list?
		   (make-object button%
				"Reset" cdp
				(lambda (b e)
				  (send c set '("Alpha" "Beta" "Gamma"))
				  (set! actual-content '("Alpha" "Beta" "Gamma"))
				  (set! actual-user-data (list #f #f #f))))
		   null))
  (define sel (if list?
		  (make-object button%
			       "Add Select First" cdp
			       (lambda (b e)
				 (send c select 0 #t)))
		  null))
  (define unsel (if list?
		    (make-object button%
				 "Unselect" cdp
				 (lambda (b e)
				   (send c select (send c get-selection) #f)))
		    null))
  (define change-button-name (if list? 
                                 (make-object button%
                                              "Change Name" cdp
                                              (lambda (b e)
						(let ([p (send c get-selection)])
						  (when p
						    (send c set-string p "New Name")
						    (set! actual-content
							  (let loop ([ac actual-content][p p])
							    (if (zero? p)
								(cons "New Name" (cdr ac))
								(cons (car ac)
								      (loop (cdr ac) (sub1 p))))))))))
                                 null))
  (define (make-selectors method mname numerical?)
    (define p2 (make-object horizontal-panel% p))
    (send p2 stretchable-height #f)
    (when numerical?
	  (make-object button%
		       (string-append "Select Bad -1" mname) p2
		       (lambda (b e)
			 (with-handlers ([exn:fail:contract? void])
			   (method -1)
			   (error "expected a type exception")))))
    (make-object button%
		 (string-append "Select First" mname) p2
		 (lambda (b e)
		   (method 0)))
    (make-object button%
		 (string-append "Select Middle" mname) p2
		 (lambda (b e)
		   (method (floor (/ (send c get-number) 2)))))
    (make-object button%
		 (string-append  "Select Last" mname) p2
		 (lambda (b e)
		   (method (sub1 (send c get-number)))))
    (make-object button%
		 (string-append "Select Bad X" mname) p2
		 (lambda (b e)
		   (with-handlers ([exn:fail:contract? void]) 
		     (method (if numerical?
				 (send c get-number)
				 #f))
		     (error "expected a mismatch exception"))))
    #f)
  (define dummy-1 (make-selectors (lambda (v) (send c set-selection v)) "" #t))
  (define dummy-2 (make-selectors (lambda (p) 
				    (if p
					(when (positive? (length actual-content))
					      (send c set-string-selection 
						    (list-ref actual-content p)))
					(send c set-string-selection "nada")))
				  " by Name"
				  #f))
  (define dummy-3 (make-selectors (lambda (p)
				    (let ([e (make-object control-event% (if list? 'list-box 'choice))])
				      (send c set-selection p)
				      (when list? (send c set-first-visible-item p))
				      (send c command e)))
				  " by Simulate" #t))
  (define tb (make-object button%
			  "Check" p
			  (lambda (b e)
			    (let ([c (send c get-number)])
			      (unless (= c (length actual-content))
				(error "bad number response")))
			    (let loop ([n 0][l actual-content][lud actual-user-data])
			      (unless (null? l)
				      (let ([s (car l)]
					    [sud (car lud)]
					    [sv (send c get-string n)]
					    [sudv (if list?
						      (send c get-data n)
						      #f)])
					(unless (string=? s sv)
					  (error "get-string mismatch"))
					(unless (or (not list?) (eq? sud sudv))
					  (error 'get-data "mismatch at ~a: ~s != ~s"
						 n sud sudv))
					(unless (= n (send c find-string s))
					  (error "bad find-string result")))
				      (loop (add1 n) (cdr l) (cdr lud))))
			    (let ([bad (lambda (exn? i)
					 (with-handlers ([exn? void])
					   (send c get-string i)
					   (error "out-of-bounds: no exn")))])
			      (bad exn:fail:contract? -1)
			      (bad exn:fail:contract? (send c get-number)))
			    (unless (not (send c find-string "nada"))
			      (error "find-string of nada wasn't #f"))
			    (for-each
			     (lambda (e)
			       (check-callback-event c c e commands #t))
			     old-list)
			    (printf "content: ~s~n" actual-content)
			    (when multi?
			      (printf "selections: ~s~n" (send c get-selections))))))
  (send c stretchable-width #t)
  (instructions p "choice-list-steps.txt")
  (send f show #t))

(define (slider-frame)
  (define f (make-frame frame% "Slider Test"))
  (define p (make-object vertical-panel% f))
  (define old-list null)
  (define commands (list 'slider))
  (define s (make-object slider% "Slide Me" -1 11 p
			 (lambda (sl e)
			   (check-callback-event s sl e commands #f)
			   (printf "slid: ~a~n" (send s get-value)))
			 3))
  (define c (make-object button% "Check" p
			 (lambda (c e)
			   (for-each
			    (lambda (e)
			      (check-callback-event s s e commands #t))
			    old-list)
			   (printf "All Ok~n"))))
  (define (simulate v)
    (let ([e (make-object control-event% 'slider)])
      (send s set-value v)
      (send s command e)))
  (define p2 (make-object horizontal-panel% p))
  (define p3 (make-object horizontal-panel% p))
  (send p3 stretchable-height #f)
  (make-object button%
	       "Up" p2
	       (lambda (c e)
		 (send s set-value (add1 (send s get-value)))))
  (make-object button%
	       "Down" p2
	       (lambda (c e)
		 (send s set-value (sub1 (send s get-value)))))
  (make-object button%
	       "Simulate Up" p2
	       (lambda (c e)
		 (simulate (add1 (send s get-value)))))
  (make-object button%
	       "Simulate Down" p2
	       (lambda (c e)
		 (simulate (sub1 (send s get-value)))))
  (make-object check-box%
	       "Disabled" p2
	       (lambda (c e)
		 (send s enable (not (send c get-value)))))
  (instructions p "slider-steps.txt")
  (send f show #t))

(define (gauge-frame)
  (define f (make-frame frame% "Gauge Test"))
  (define p (make-object vertical-panel% f))
  (define g (make-object gauge% "Tester" 10 p))
  (define (move d name)
    (make-object button%
		 name p
		 (lambda (c e)
		   (send g set-value (+ d (send g get-value))))))
  (define (size d name)
    (make-object button%
		 name p
		 (lambda (c e)
		   (send g set-range (+ d (send g get-range))))))
  (move 1 "+")
  (move -1 "-")
  (size 1 "Bigger")
  (size -1 "Smaller")
  (instructions p "gauge-steps.txt")
  (send f show #t))

(define (text-frame style)
  (define (handler get-this)
    (lambda (c e)
      (unless (eq? c (get-this))
	(printf "callback: bad item: ~a~n" c))
      (let ([t (send e get-event-type)])
	(cond
	 [(eq? t 'text-field)
	  (printf "Changed: ~a~n" (send c get-value))]
	 [(eq? t 'text-field-enter)
	  (printf "Return: ~a~n" (send c get-value))]))))

  (define f (make-frame frame% "Text Test"))
  (define p (make-object vertical-panel% f))
  (define t1 (make-object text-field% #f p (handler (lambda () t1)) "This should just fit!" style))
  (define t2 (make-object text-field% "Another" p (handler (lambda () t2)) "This too!" style))
  (define t3 (make-object text-field% "Catch Returns" p (handler (lambda () t3)) "And, yes, this!"
			  (cons 'hscroll style)))
  (send t1 stretchable-width #f)
  (send t2 stretchable-width #f)
  (send t3 stretchable-width #f)
  (send f show #t))

(define (canvas-frame flags)
  (define f (make-frame frame% "Canvas Test" #f #f 250))
  (define p (make-object vertical-panel% f))
  (define c% (class canvas%
               (init -name -swapped-name p)
	       (inherit get-dc get-scroll-pos get-scroll-range get-scroll-page
			get-client-size get-virtual-size get-view-start)
	       (define name -name)
               (define swapped-name -swapped-name)
               (define auto? #f)
               (define incremental? #f)
               (define vw 10)
               (define vh 10)
	       (public*
		 [inc-mode (lambda (x) (set! incremental? x))]
		 [set-vsize (lambda (w h) (set! vw w) (set! vh h))])
	       (override*
		[on-paint
		 (lambda ()
		   (let ([s (format "V: p: ~s r: ~s g: ~s H: ~s ~s ~s"
				    (get-scroll-pos 'vertical)
				    (get-scroll-range 'vertical)
				    (get-scroll-page 'vertical)
				    (get-scroll-pos 'horizontal)
				    (get-scroll-range 'horizontal)
				    (get-scroll-page 'horizontal))]
			 [dc (get-dc)])
		     (let-values ([(w h) (get-client-size)]
				  [(w2 h2) (get-virtual-size)]
				  [(x y) (get-view-start)])
		       ; (send dc set-clipping-region 0 0 w2 h2)
		       (unless incremental? (send dc clear))
		       (send dc draw-text (if (send ck-w get-value) swapped-name name) 3 3)
		       ; (draw-line 3 12 40 12)
		       (send dc draw-text s 3 15)
		       (send dc draw-text (format "client: ~s x ~s  virtual: ~s x ~s  view: ~s x ~s" 
						  w h
						  w2 h2
						  x y)
			     3 27)
		       (send dc draw-line 0 vh vw vh)
		       (send dc draw-line vw 0 vw vh))))]
		[on-event
		 (lambda (e)
		   (let ([s (format "~a ~a" (send e get-x) (send e get-y))])
		     (send f set-status-text s)))]
		[on-scroll
		 (lambda (e) 
		   (when auto? (printf "Hey - on-scroll called for auto scrollbars~n"))
		   (unless incremental? (on-paint)))]
		[init-auto-scrollbars (lambda x
					(set! auto? #t)
					(super init-auto-scrollbars . x))]
		[init-manual-scrollbars (lambda x
					  (set! auto? #f)
					  (super init-manual-scrollbars . x))])
               (super-init p flags)))
  (define un-name "Unmanaged scroll")
  (define m-name "Automanaged scroll")
  (define c1 (make-object c% un-name m-name p))
  (define c2 (make-object c% m-name un-name p))
  (define (reset-scrolls for-small?)
    (let* ([h? (send ck-h get-value)]
	   [v? (send ck-v get-value)]
	   [small? (send ck-s get-value)]
	   [swap? (send ck-w get-value)])
      (send c1 set-vsize 10 10)
      (if swap?
	  (send c1 init-auto-scrollbars (and h? 10) (and v? 10) .1 .1)
	  (send c1 init-manual-scrollbars (and h? 10) (and v? 10) 3 3 1 1))
      ; (send c1 set-scrollbars (and h? 1) (and v? 1) 10 10 3 3 1 1 swap?)
      (send c2 set-vsize (if small? 50 500) (if small? 20 200))
      (if swap?
	  (send c2 init-manual-scrollbars (if small? 2 20) (if small? 2 20) 3 3 1 1)
	  (send c2 init-auto-scrollbars (and h? (if small? 50 500)) (and v? (if small? 20 200)) .2 .2))
      ; (send c2 set-scrollbars (and h? 25) (and v? 10) (if small? 2 20) (if small? 2 20) 3 3 1 1 (not swap?))
      (if for-small?
	  ; Specifically refresh the bottom canvas
	  (send c2 refresh)
	  ; Otherwise, we have to specifically refresh the unmanaged canvas
	  (send (if swap? c2 c1) refresh))))
  (define (reset-show)
    (for-each
     (lambda (c)
       (send c show-scrollbars 
	     (and (not (send sh-h get-value)) (memq 'hscroll flags))
	     (and (not (send sh-v get-value)) (memq 'vscroll flags))))
     (list c1 c2)))
  (define p2 (make-object horizontal-panel% p))
  (define junk (send p2 stretchable-height #f))
  (define ck-v (make-object check-box% "Vertical Scroll" p2 (lambda (b e) (reset-scrolls #f))))
  (define ck-h (make-object check-box% "Horizontal Scroll" p2 (lambda (b e) (reset-scrolls #f))))
  (define ck-s (make-object check-box% "Small" p2 (lambda (b e) (reset-scrolls #t))))
  (define ck-w (make-object check-box% "Swap" p2 (lambda (b e) (reset-scrolls #f))))
  (define p3 (make-object horizontal-panel% p))
  (define junk2 (send p3 stretchable-height #f))
  (define sh-v (make-object check-box% "Hide Vertical" p3 (lambda (b e) (reset-show))))
  (define sh-h (make-object check-box% "Hide Horizontal" p3 (lambda (b e) (reset-show))))
  (define ip (make-object horizontal-panel% p))
  (send ip stretchable-height #f)
  (make-object button%
	       "Get Instructions" ip
	       (lambda (b e) (open-file "canvas-steps.txt")))
  (make-object button%
	       "&1/5 Scroll" ip
	       (lambda (b e) (send c2 scroll 0.2 0.2)))
  (make-object button%
	       "&4/5 Scroll" ip
	       (lambda (b e) (send c2 scroll 0.8 0.8)))
  (make-object check-box%
	       "Inc" ip
	       (lambda (c e) 
		 (send c1 inc-mode (send c get-value))
		 (send c2 inc-mode (send c get-value))))
  (make-object check-box%
	       "x2" ip
	       (lambda (c e) 
		 (let ([s (if (send c get-value)
			      2
			      1)])
		   (send (send c2 get-dc) set-scale s s)
		   (send c2 refresh))))
  (send c1 set-vsize 10 10)
  (send c2 set-vsize 500 200)
  (send f create-status-line)
  (send f show #t))

(define (no-clear-canvas-frame)
  (define f (new frame% 
		 [label "No-Clear Canvas Test"]
		 [height 250]
		 [width 300]
		 [style (add-frame-style null)]))
  (define p (make-object vertical-panel% f))
  (define c% (class canvas%
               (inherit get-dc refresh)
	       (define delta 0)
	       (define/override (on-paint)
		 (let ([red (send the-brush-list find-or-create-brush "RED" 'solid)]
		       [blue (send the-brush-list find-or-create-brush "BLUE" 'solid)]
		       [dc (get-dc)])
		   (let loop ([x 0])
		     (unless (= x 500)
		       (send dc set-brush red)
		       (send dc draw-rectangle (- x delta) 0 25 30)
		       (send dc draw-rectangle (- x delta) 40 25 390)
		       (send dc set-brush blue)
		       (send dc draw-rectangle (- (+ x 25) delta) 0 25 30)
		       (send dc draw-rectangle (- (+ x 25) delta) 40 25 390)
		       (loop (+ x 50))))))
	       (define/override (on-event evt)
		 (when (send evt dragging?)
		   (set! delta (modulo (add1 delta) 100))
		   (refresh)))
	       (super-new)))
  (new c% [parent p][style '(border)])
  (new c% [parent p][style '(transparent)])
  (new c% [parent p][style '(no-autoclear border)])
  (send f show #t)
  f)

(define (editor-frame canvas-style canvas-bg)
  (define f (new frame% 
		 [label "No-Clear Canvas Test"]
		 [height 250]
		 [width 300]
		 [style (add-frame-style null)]))
  (define c (new editor-canvas%
		 [parent f]
		 [style canvas-style]))
  (define mb (make-object menu-bar% f))
  (define edit-menu (make-object menu% "Edit" mb))
  (define font-menu (make-object menu% "Font" mb))

  (when canvas-bg
    (send c set-canvas-background (make-object color% canvas-bg)))
  (send c set-editor (new text%))

  (append-editor-operation-menu-items edit-menu #f)
  (append-editor-font-menu-items font-menu)

  (send f show #t))

(define (editor-canvas-oneline-frame)
  (define f (make-frame frame% "x" #f 200 #f))
  
  (define (try flags)
    (define c (make-object editor-canvas% f #f flags))
    
    (define e (make-object text%))
    
    (send e insert "Xy!")
    
    (send c set-line-count 1)
    
    (send c set-editor e)
    (send c stretchable-height #f))

  (send f show #t)
  
  (try '(no-hscroll no-vscroll))
  (try '(no-vscroll))
  (try '(no-hscroll))
  (try '()))

(define (minsize-frame)
  (define f (make-frame frame% "x"))
  
  (define bp (make-object horizontal-panel% f))
  (define tb (make-object button% "Toggle Stretch" bp
			  (lambda (b e)
			    (for-each
			     (lambda (p)
			       (send p stretchable-width (not (send p stretchable-width)))
			       (send p stretchable-height (not (send p stretchable-height))))
			     containers))))
  (define ps (make-object button% "Print Sizes" bp
			  (lambda (b e)
			    (newline)
			    (for-each
			     (lambda (p)
			       (let ([c (car (send p get-children))])
				 (let-values ([(w h) (send c get-size)]
					      [(cw ch) (send c get-client-size)])
				   (printf "~a: (~a x ~a) client[~a x ~a] diff<~a x ~a> min{~a x ~a}~n"
					   c w h cw ch
					   (- w cw) (- h ch)
					   (send c min-width) (send c min-height)))))
			     (reverse containers))
			    (newline))))
  
  (define containers null)

  (define (make-container p)
    (let ([p (make-object vertical-panel% p '())])
      (send p stretchable-width #f)
      (send p stretchable-height #f)
      (set! containers (cons p containers))
      p))
  
  (define hp0 (make-object horizontal-panel% f))

  (define p (make-object panel% (make-container hp0)))
  (define pb (make-object panel% (make-container hp0) '(border)))

  (define hp1 (make-object horizontal-panel% f))

  (define c (make-object canvas% (make-container hp1)))
  (define cb (make-object canvas% (make-container hp1) '(border)))
  (define ch (make-object canvas% (make-container hp1) '(hscroll)))
  (define cv (make-object canvas% (make-container hp1) '(vscroll)))
  (define chv (make-object canvas% (make-container hp1) '(hscroll vscroll)))
  (define cbhv (make-object canvas% (make-container hp1) '(border hscroll vscroll)))

  (define hp2 (make-object horizontal-panel% f))

  (define ec (make-object editor-canvas% (make-container hp2) #f '(no-hscroll no-vscroll)))
  (define ech (make-object editor-canvas% (make-container hp2) #f '(no-vscroll)))
  (define ecv (make-object editor-canvas% (make-container hp2) #f '(no-hscroll)))
  (define echv (make-object editor-canvas% (make-container hp2) #f '()))

  (define hp3 (make-object horizontal-panel% f))
  
  (define pec (make-object editor-canvas% (make-container hp3) #f '(no-border no-hscroll no-vscroll)))
  (define pech (make-object editor-canvas% (make-container hp3) #f '(no-border no-vscroll)))
  (define pecv (make-object editor-canvas% (make-container hp3) #f '(no-border no-hscroll)))
  (define pechv (make-object editor-canvas% (make-container hp3) #f '(no-border )))

  (define hp4 (make-object horizontal-panel% f))
  (define chvh (make-object canvas% (make-container hp4) '(border hscroll vscroll)))
  (define chvv (make-object canvas% (make-container hp4) '(border hscroll vscroll)))
  (send chvh show-scrollbars #t #f)
  (send chvv show-scrollbars #f #t)

  (send f show #t))

;----------------------------------------------------------------------

(define (test-tab-panel no-border?)
  (define f (make-object frame% "Tabby"))
  (define p (make-object tab-panel% '("App&le" "B&anana" "Co&conut") 
			 f
			 (lambda (p e)
			   (send m set-label (format "Selected: ~a" (send p get-selection))))
			 (if no-border?
			     '(no-border)
			     '())))
  (define p2 (if no-border?
		 (new vertical-panel% [parent f])
		 p))
  (define count 3)
  (define on? #t)
  (define m (make-object message% (format "Selected: ~a" (send p get-selection)) p2))

  (when no-border?
    (make-object vertical-pane% p2))

  (make-object button% "Append" p2 (lambda (b e) 
				    (send p append (format "N&ew ~a" count))
				    (set! count (add1 count))))
  (make-object button% "Delete" p2 (lambda (b e)
				     (send p delete 0)))
  (make-object button% "First" p2 (lambda (b e)
				    (send p set-selection 0)))
  (make-object button% "Last" p2 (lambda (b e)
				   (send p set-selection (sub1 (send p get-number)))))
  (make-object button% "Rename" p2 (lambda (b e)
				     (send p set-item-label (quotient (send p get-number) 2) "Do&nut")))
  (make-object button% "Labels" p2 (lambda (b e)
				     (printf "~s~n"
					     (reverse
					      (let loop ([i (send p get-number)])
						(if (zero? i)
						    null
						    (cons (send p get-item-label (sub1 i)) (loop (sub1 i)))))))))
  (make-object button% "Set" p2 (lambda (b e)
				  (send p set '("New One" "New Second" "New Third"))))
  (when no-border?
    (make-object button% "Toggle" p2 (lambda (b e)
				       (if on?
					   (send f delete-child p)
					   (send f change-children
						 (lambda (l) (cons p l))))
				       (set! on? (not on?)))))

  (send f show #t))

;----------------------------------------------------------------------

(define (test-modified-frame)
  (define f (new (class frame% 
		   (define/override (on-toolbar-button-click)
		     (send f modified (not (send f modified))))
		   (super-make-object))
		 [label "Modifiable"]
		 [style '(toolbar-button)]))

  (make-object button% "Toggle" f (lambda (b e)
				    (send f on-toolbar-button-click)))
  (make-object message% "Mac OS X: toolbar button also toggles" f)
  (send f show #t))

;----------------------------------------------------------------------

(define (message-boxes parent)
  (define (check expected got)
    (unless (eq? expected got)
      (fprintf (current-error-port) "bad result: - expected ~e, got ~e~n"
	       expected got)))
  (define (big s)
    (format "~a~n~a~n~a~n~a~n" s
	    (make-string 500 #\x)
	    (make-string 500 #\x)
	    (make-string 500 #\x)))

  (check 'ok (message-box "Title" "Message OK!" parent '(ok)))
  (check 'ok (message-box "Title" (big "Message OK!") parent '(ok)))

  (check 'cancel (message-box "Title" "Cancel Me" parent '(ok-cancel)))
  (check 'ok (message-box "Title" "Ok Me" parent '(ok-cancel)))
  (check 'ok (message-box "Title" (big "Ok Me") parent '(ok-cancel)))

  (check 'yes (message-box "Title" "Yes, please" parent '(yes-no)))
  (check 'no (message-box "Title" "No, please" parent '(yes-no)))

  (check 'yes (message-box "Title" "Caution sign?" parent '(yes-no caution)))
  (check 'yes (message-box "Title" "Stop sign?" parent '(yes-no stop)))

  (check 1 (message-box/custom "Title" "Hello"
				"Hi" #f #f
				parent
				'(default=1)))
  (check 2 (message-box/custom "Title" "Hello"
			       #f "Howdy" #f
			       parent))
  (check 3 (message-box/custom "Title" "Hello (response should be on left for Mac OS)"
				#f #f "Howdy"
				parent))
  (check #f (message-box/custom "Title" "Escape to close, please"
				 "Hi" #f #f
				 parent))
  (check 'closed (message-box/custom "Title" "Escape to close, again, please"
				     "Hi" #f #f
				     parent
				     '(default=1)
				     'closed))
  (check 'closed (message-box/custom "Title" "Escape to close, again, please"
				     #f #f #f
				     parent
				     '(default=1)
				     'closed))
  (check 1 (message-box/custom "Title" "Try to escape to close"
				"I can't" #f #f
				parent
				'(default=1 disallow-close)
				'closed))

  (message-box/custom "Title" "Buttons out of order in Mac OS"
		       "One" "Two" "Three"
		       parent)
  (message-box/custom "Title" "Buttons in order on all platforms"
		       "One" "Two" "Three"
		       parent
		       '(default=1 number-order))
		       
  )

;----------------------------------------------------------------------

(define (cursors)
  (define f (make-object frame% "Cursors"))
  (for-each (lambda (s)
	      (make-object button%
			   (format "~a" s)
			   f
			   (lambda (b e)
			     (send f set-cursor (make-object cursor% s)))))
	    '(arrow bullseye cross hand ibeam watch arrow-watch blank size-n/s size-e/w size-ne/sw size-nw/se))
  (send f show #t))


;----------------------------------------------------------------------

(define selector (make-frame frame% "Test Selector"))
(define ap (make-object vertical-panel% selector))

; Test timers while we're at it. And create the "Instructions" button.
(let ([clockp (make-object horizontal-panel% ap)]
      [selector selector])
  (make-object button% "Get Instructions" clockp
	       (lambda (b e) 
		 (open-file "frame-steps.txt")))
  (make-object check-box% "Use Dialogs" clockp
	       (lambda (c e)
		 (set! use-dialogs? (send c get-value))))
  (make-object check-box% "Metal" clockp
	       (lambda (c e)
		 (set! use-metal? (send c get-value))))
  (make-object check-box% "Float" clockp
	       (lambda (c e)
		 (set! float-frame? (send c get-value))))
  (make-object check-box% "No Title" clockp
	       (lambda (c e)
		 (set! no-caption? (send c get-value))))
  (make-object vertical-panel% clockp) ; filler
  (let ([time (make-object message% "XX:XX:XX" clockp)])
    (make-object
     (class100 timer% ()
       (inherit start)
       (override
	 [notify
	  (lambda ()
	    (let* ([now (seconds->date (current-seconds))]
		   [pad (lambda (pc d)
			  (let ([s (number->string d)])
			    (if (= 1 (string-length s))
				(string-append pc s)
				s)))]
		   [s (format "~a:~a:~a"
			      (pad " " (let ([h (modulo (date-hour now) 12)])
					 (if (zero? h)
					     12
					     h)))
			      (pad "0" (date-minute now))
			      (pad "0" (date-second now)))])
	      (send time set-label s)
	      (when (send selector is-shown?)
		(start 1000 #t))))])
       (sequence
	 (super-init)
	 (start 1000 #t))))))

(define bp0 (make-object vertical-panel% ap '(border)))
(define bp1 (make-object horizontal-panel% bp0))
(define bp2 (make-object horizontal-pane% bp0))
(define mp (make-object vertical-panel% ap '(border)))
(define mp1 (make-object horizontal-panel% mp))
(define mp2 (make-object horizontal-pane% mp))

(define pp (make-object horizontal-pane% ap))
(send bp0 stretchable-height #f)
(make-object button% "Make Menus Frame" pp (lambda (b e) (menu-frame)))
(make-object horizontal-pane% pp)
(make-object button% "Make Panel Frame" pp (lambda (b e) (panel-frame)))
(make-object horizontal-pane% pp)
(make-object button% "Editor Canvas One-liners" pp (lambda (b e) (editor-canvas-oneline-frame)))
(make-object horizontal-pane% pp)
(make-object button% "Minsize Windows" pp (lambda (b e) (minsize-frame)))
(define bp (make-object horizontal-pane% ap))
(send bp stretchable-width #f)
(make-object button% "Make Button Frame" bp (lambda (b e) (button-frame frame% null)))
(make-object button% "Make Default Button Frame" bp (lambda (b e) (button-frame frame% '(border))))
(make-object button% "Make Button Dialog" bp (lambda (b e) (button-frame dialog% null)))
(define crp (make-object horizontal-pane% ap))
(send crp stretchable-height #f)
(make-object button% "Make Checkbox Frame" crp (lambda (b e) (checkbox-frame)))
(make-object vertical-pane% crp) ; filler
(make-object button% "Message Boxes" crp (lambda (b e) (message-boxes #f)))
(make-object vertical-pane% crp) ; filler
(make-object button% "Cursors" crp (lambda (b e) (cursors)))
(make-object vertical-pane% crp) ; filler
(make-object button% "Make Radiobox Frame" crp (lambda (b e) (radiobox-frame)))
(define cp (make-object horizontal-pane% ap))
(send cp stretchable-width #f)
(make-object button% "Make Choice Frame" cp (lambda (b e) (choice-or-list-frame #f null #f)))
(make-object button% "Make Empty Choice Frame" cp (lambda (b e) (choice-or-list-frame #f null #t)))
(define lp (make-object horizontal-pane% ap))
(send lp stretchable-width #f)
(make-object button% "Make List Frame" lp (lambda (b e) (choice-or-list-frame #t '(single) #f)))
(make-object button% "Make Empty List Frame" lp (lambda (b e) (choice-or-list-frame #t '(single) #t)))
(make-object button% "Make MultiList Frame" lp (lambda (b e) (choice-or-list-frame #t '(multiple) #f)))
(make-object button% "Make MultiExtendList Frame" lp (lambda (b e) (choice-or-list-frame #t '(extended) #f)))
(define gsp (make-object horizontal-pane% ap))
(send gsp stretchable-height #f)
(make-object button% "Make Gauge Frame" gsp (lambda (b e) (gauge-frame)))
(make-object vertical-pane% gsp) ; filler
(make-object button% "Make Slider Frame" gsp (lambda (b e) (slider-frame)))
(make-object vertical-pane% gsp) ; filler
(make-object button% "Make Tab Panel" gsp (lambda (b e) (test-tab-panel #f)))
(make-object button% "Make Tabs" gsp (lambda (b e) (test-tab-panel #t)))
(make-object vertical-pane% gsp) ; filler
(make-object button% "Make Modified Frame" gsp (lambda (b e) (test-modified-frame)))

(define tp (make-object horizontal-pane% ap))
(send tp stretchable-width #f)
(make-object button% "Make Text Frame" tp (lambda (b e) (text-frame '(single))))
(make-object button% "Make Multitext Frame" tp (lambda (b e) (text-frame '(multiple))))

(define cnp (make-object horizontal-pane% ap))
(send cnp stretchable-width #t)
(send cnp set-alignment 'right 'center)
(let ([mkf (lambda (flags name)
	     (make-object button%
			  (format "Make ~aCanvas Frame" name) cnp 
			  (lambda (b e) (canvas-frame flags))))])
  (mkf '(hscroll vscroll) "HV")
  (mkf '(hscroll) "H")
  (mkf '(vscroll) "V")
  (mkf null "")
  (make-object grow-box-spacer-pane% cnp))
(make-object button%
	     "Make No-Clear Canvas" cnp 
	     (lambda (b e) (no-clear-canvas-frame)))

(define edp (new horizontal-pane% 
		 [parent ap]
		 [alignment '(center center)]))
(make-object button%
	     "Make Editor" edp 
	     (lambda (b e) (editor-frame null #f)))
(make-object button%
	     "Make Transparent Editor" edp 
	     (lambda (b e) (editor-frame '(transparent) #f)))
(make-object button%
	     "Make Blue Editor" edp 
	     (lambda (b e) (editor-frame null "blue")))

(define (choose-next radios)
  (let loop ([l radios])
    (let* ([c (car l)]
	   [rest (cdr l)]
	   [n (send c number)]
	   [v (send c get-selection)])
      (if (< v (sub1 n))
	  (send c set-selection (add1 v))
	  (if (null? rest)
	      (map (lambda (c) (send c set-selection 0)) radios)
	      (begin
		(send c set-selection 0)
		(loop rest)))))))

(define make-next-button
  (lambda (p l)
    (make-object button%
		 "Next Configuration" p
		 (lambda (b e) (choose-next l)))))

(define make-selector-and-runner
  (lambda (p1 p2 radios? msg? size maker)
    (define (make-radio-box lbl choices panel cb)
      (let ([g (instantiate group-box-panel% (lbl panel))])
	(if (= (length choices) 2)
	    (make-object radio-box% #f choices g cb)
	    (make-object choice% #f choices g cb))))
    (define radio-h-radio
      (make-radio-box 
       (if radios? "Radio Box Orientation" "Slider Style")
       (if radios? '("Vertical" "Horizontal") '("Numbers" "Plain"))
       p1 void))
    (define label-h-radio
      (make-radio-box "Label Orientation" '("Vertical" "Horizontal")
		      p1 void))
    (define label-null-radio
      (make-radio-box "Optional Labels" '("Use Label" "No Label")
		      p1 void))
    (define stretchy-radio
      (make-radio-box "Stretchiness" '("Normal" "All Stretchy")
		      p1 void))
    (define font-radio
      (make-radio-box "Label Font" '("Normal" "Small" "Tiny" "Big")
		      p1 void))
    (define enabled-radio
      (make-radio-box "Initially" '("Enabled" "Disabled")
		      p1 void))
    (define selection-radio
      (make-radio-box "Selection" '("Default" "Alternate")
		      p1 void))
    (define next-button
      (make-next-button p2 (list radio-h-radio label-h-radio label-null-radio 
				 stretchy-radio font-radio
				 enabled-radio selection-radio)))
    (define go-button
      (make-object button% (format "Make ~a Frame" size) p2
		   (lambda (b e)
		     (maker
		      (positive? (send radio-h-radio get-selection))
		      (positive? (send label-h-radio get-selection))
		      (positive? (send label-null-radio get-selection))
		      (positive? (send stretchy-radio get-selection))
		      (list-ref (list #f
				      small-control-font
				      tiny-control-font
				      special-font)
				(send font-radio get-selection))
		      (positive? (send enabled-radio get-selection))
		      (positive? (send selection-radio get-selection))
                      (and message-auto
                           (send message-auto get-value))))))

    (define message-auto
      (and msg?
           (new check-box% 
                [parent p2]
                [label "Auto-Size Message"])))
    
    #t))

(make-selector-and-runner bp1 bp2 #t #t "Big" big-frame)
(make-selector-and-runner mp1 mp2 #f #f "Medium" med-frame)

(send selector show #t)