implement labels for radio-box%, etc.

collects/mred/private/gdi.rkt

@@ -6,6 +6,7 @@
 	   "lock.ss"
 	   "check.ss"
 	   "wx.ss"
+           "te.rkt"
 	   "mrtop.ss"
 	   "mrcanvas.ss")
 
@@ -179,21 +180,14 @@
 	     (as-exit (lambda () (super-init p)))))))))
 
   (define get-window-text-extent
-    (let ([bm #f][dc #f])
     (case-lambda
-       [(string font) (get-window-text-extent string font #f)]
+     [(string font)
+      (get-window-text-extent string font #f)]
      [(string font combine?)
       (check-string 'get-window-text-extent string)
       (check-instance 'get-window-text-extent wx:font% 'font% #f font)
-	(unless bm
+      (let-values ([(w h d a) (get-window-text-extent* string font combine?)])
-	  (set! bm (make-object wx:bitmap% 2 2))
+        (values (inexact->exact (ceiling w)) (inexact->exact (ceiling h))))]))
-	  (set! dc (make-object wx:bitmap-dc%))
-	  (send dc set-bitmap bm))
-	(unless (send bm ok?)
-	  (error 'get-window-text-extent "couldn't allocate sizing bitmap"))
-	(let-values ([(w h d a) (send dc get-text-extent string font combine?)])
-	  (values (inexact->exact w) (inexact->exact h)))])))
-
   
   (define ugly?
     (lambda (a)

collects/mred/private/mritem.rkt

@@ -11,6 +11,7 @@
 	   "helper.ss"
 	   "wx.ss"
 	   "wxitem.ss"
+           "wxlitem.ss"
 	   "mrwindow.ss"
 	   "mrcontainer.ss")
 

collects/mred/private/te.rkt

@@ -0,0 +1,19 @@
+#lang racket/base
+(require racket/class
+         racket/draw)
+
+(provide get-window-text-extent*)
+
+(define get-window-text-extent*
+  (let ([bm #f][dc #f])
+    (case-lambda
+     [(string font) (get-window-text-extent* string font #f)]
+     [(string font combine?)
+      (unless bm
+        (set! bm (make-object bitmap% 2 2))
+        (set! dc (make-object bitmap-dc%))
+        (send dc set-bitmap bm))
+      (unless (send bm ok?)
+        (error 'get-window-text-extent "couldn't allocate sizing bitmap"))
+      (let-values ([(w h d a) (send dc get-text-extent string font combine?)])
+        (values w h d a))])))

collects/mred/private/wx/cocoa/panel.rkt

@@ -16,7 +16,7 @@
 
 (define (panel-mixin %)
   (class %
-    (define lbl-pos 'vertical)
+    (define lbl-pos 'horizontal)
     (super-new)
     
     (define/public (get-label-position) lbl-pos)

collects/mred/private/wx/cocoa/radio-box.rkt

@@ -65,6 +65,8 @@
         font)
   (inherit get-cocoa set-focus)
 
+  (define horiz? (and (memq 'horizontal style) #t))
+
   (super-new [parent parent]
              [cocoa
               (let ([cocoa
@@ -76,13 +78,13 @@
                             cellClass: (if (andmap string? labels)
                                            NSButtonCell
                                            MyImageButtonCell)
-                            numberOfRows: #:type _NSInteger (length labels)
+                            numberOfRows: #:type _NSInteger (if horiz? 1 (length labels))
-                            numberOfColumns: #:type _NSInteger 1))])
+                            numberOfColumns: #:type _NSInteger (if horiz? (length labels) 1)))])
                 (for ([label (in-list labels)]
                       [i (in-naturals)])
                   (let ([button (tell cocoa 
-                                      cellAtRow: #:type _NSInteger i 
+                                      cellAtRow: #:type _NSInteger (if horiz? 0 i)
-                                      column: #:type _NSInteger 0)])
+                                      column: #:type _NSInteger (if horiz? i 0))])
                     (if (and (not (string? label))
                              (send label ok?))
                         (begin
@@ -112,7 +114,10 @@
         (set-focus)))
 
   (define/public (set-selection i)
-    (tellv (get-cocoa) selectCellAtRow: #:type _NSInteger i column: #:type _NSInteger 0))
+    (tellv (get-cocoa) selectCellAtRow: #:type _NSInteger (if horiz? 0 i)
+           column: #:type _NSInteger (if horiz? i 0)))
   (define/public (get-selection)
-    (tell #:type _NSInteger (get-cocoa) selectedRow))
+    (if horiz?
+        (tell #:type _NSInteger (get-cocoa) selectedColumn)
+        (tell #:type _NSInteger (get-cocoa) selectedRow)))
   (define/public (number) count))

collects/mred/private/wx/cocoa/window.rkt

@@ -297,7 +297,6 @@
     (def/public-unimplemented set-phantom-size)
     (def/public-unimplemented popup-menu)
     (define/public (center a b) (void))
-    (def/public-unimplemented get-text-extent)
     (def/public-unimplemented refresh)
 
     (def/public-unimplemented screen-to-client)

collects/mred/private/wx/gtk/window.rkt

@@ -299,7 +299,6 @@
     (def/public-unimplemented set-phantom-size)
     (def/public-unimplemented popup-menu)
     (define/public (center a b) (void))
-    (def/public-unimplemented get-text-extent)
     (define/public (refresh) (void))
 
     (define/public (screen-to-client x y)

collects/mred/private/wx/win32/window.rkt

@@ -21,7 +21,6 @@
   (def/public-unimplemented get-height)
   (def/public-unimplemented popup-menu)
   (def/public-unimplemented center)
-  (def/public-unimplemented get-text-extent)
   (def/public-unimplemented get-parent)
   (def/public-unimplemented refresh)
   (def/public-unimplemented screen-to-client)

collects/mred/private/wxitem.rkt

@@ -2,7 +2,6 @@
   (require mzlib/class
 	   mzlib/class100
 	   mzlib/etc
-	   mzlib/file
 	   (prefix wx: "kernel.ss")
 	   "lock.ss"
 	   "helper.ss"
@@ -16,12 +15,7 @@
 		    make-simple-control%
 		    wx-button%
 		    wx-check-box%
-		    wx-choice%
+		    wx-message%))
-		    wx-message%
-		    wx-gauge%
-		    wx-list-box%
-		    wx-radio-box%
-		    wx-slider%))
 
   ;; make-item%: creates items which are suitable for placing into
   ;;  containers.
@@ -246,162 +240,8 @@
 					  (set-value (not (get-value)))
 					  (command (make-object wx:control-event% 'check-box)))))])
 			  (sequence (super-init mred proxy style parent cb label x y w h (cons 'deleted style) font))))
-  (define wx-choice% (class100 (make-window-glue% (make-simple-control% wx:choice%)) (mred proxy parent cb label x y w h choices style font)
+
-		       (override 
-			 [handles-key-code 
-			  (lambda (x alpha? meta?) 
-			    (or (memq x '(up down))
-				(and alpha? (not meta?))))])
-		       (sequence (super-init mred proxy style parent cb label x y w h choices (cons 'deleted style) font))))
   (define wx-message% (class100 (make-window-glue% (make-simple-control% wx:message%)) (mred proxy parent label x y style font)
 			(override [gets-focus? (lambda () #f)])
-			(sequence (super-init mred proxy style parent label x y (cons 'deleted style) font))))
+			(sequence (super-init mred proxy style parent label x y (cons 'deleted style) font)))))
-
-  (define wx-gauge%
-    (make-window-glue% 
-     (class100 (make-control% wx:gauge% 
-			      const-default-x-margin const-default-y-margin 
-			      #f #f)
-	 (parent label range style font)
-       (inherit get-client-size get-width get-height set-size 
-		stretchable-in-x stretchable-in-y set-min-height set-min-width
-		get-parent)
-       (override [gets-focus? (lambda () #f)])
-       (private-field
-	;; # pixels per unit of value.
-	[pixels-per-value 1])
-       (sequence
-	 (super-init style parent label range -1 -1 -1 -1 (cons 'deleted style) font)
-
-	 (let-values ([(client-width client-height) (get-two-int-values 
-						     (lambda (a b) (get-client-size a b)))])
-	   (let ([delta-w (- (get-width) client-width)]
-		 [delta-h (- (get-height) client-height)]
-		 [vertical-labels? (eq? (send (send (get-parent) get-window) get-label-position) 'vertical)]
-		 [horizontal? (memq 'horizontal style)])
-	     (set-min-width (if horizontal?
-				(let ([cw (min const-max-gauge-length
-					       (* range pixels-per-value))])
-				  (max (if vertical-labels?
-					   cw
-					   (+ cw delta-w))
-				       (get-width)))
-				;; client-height is the default
-				;; dimension in the minor direction.
-				(+ client-width delta-w)))
-	     (set-min-height (if horizontal?
-				 (+ client-height delta-h)
-				 (let ([ch (min const-max-gauge-length
-						(* range pixels-per-value))])
-				   (max (if vertical-labels?
-					    (+ ch delta-h)
-					    ch)
-					(get-height)))))))
-
-	 (if (memq 'horizontal style)
-	     (begin
-	       (stretchable-in-x #t)
-	       (stretchable-in-y #f))
-	     (begin
-	       (stretchable-in-x #f)
-	       (stretchable-in-y #t)))))))
-
-  (define list-box-wheel-step #f)
-
-  (define wx-list-box%
-    (make-window-glue% 
-     (class100 (make-control% wx:list-box%
-			      const-default-x-margin const-default-y-margin 
-			      #t #t) (parent cb label kind x y w h choices style font label-font)
-       (inherit get-first-item
-		set-first-visible-item)
-       (private
-	 [scroll (lambda (dir)
-		   (unless list-box-wheel-step
-		     (set! list-box-wheel-step (get-preference '|MrEd:wheelStep| (lambda () 3)))
-		     (unless (and (number? list-box-wheel-step)
-				  (exact? list-box-wheel-step)
-				  (integer? list-box-wheel-step)
-				  (<= 1 list-box-wheel-step 100))
-		       (set! list-box-wheel-step 3)))
-		   (let ([top (get-first-item)])
-		     (set-first-visible-item
-                      (max 0 (+ top (* list-box-wheel-step dir))))))])
-       (override
-	 [handles-key-code (lambda (x alpha? meta?)
-			     (case x
-			       [(up down) #t]
-			       [else (and alpha? (not meta?))]))]
-	 [pre-on-char (lambda (w e)
-			(or (super pre-on-char w e)
-			    (case (send e get-key-code)
-			      [(wheel-up) (scroll -1) #t]
-			      [(wheel-down) (scroll 1) #t]
-			      [else #f])))])
-       (sequence (super-init style parent cb label kind x y w h choices (cons 'deleted style) font label-font)))))
-
-  (define wx-radio-box%
-    (make-window-glue% 
-     (class100 (make-simple-control% wx:radio-box%) (parent cb label x y w h choices major style font)
-       (inherit number orig-enable set-selection command)
-       (override
-	 [enable
-	  (case-lambda
-	   [(on?) (super enable on?)]
-	   [(which on?) (when (< -1 which (number))
-			  (vector-set! enable-vector which (and on? #t))
-			  (orig-enable which on?))])]
-	 [is-enabled?
-	  (case-lambda
-	   [() (super is-enabled?)]
-	   [(which) (and (< -1 which (number))
-			 (vector-ref enable-vector which))])])
-
-       (private-field [is-vertical? (memq 'vertical style)])
-       (public
-	 [vertical? (lambda () is-vertical?)]
-	 [char-to-button (lambda (i)
-			   (as-exit
-			    (lambda ()
-			      (set-selection i)
-			      (command (make-object wx:control-event% 'radio-box)))))])
-
-       (sequence (super-init style parent cb label x y w h choices major (cons 'deleted style) font))
-
-       (private-field [enable-vector (make-vector (number) #t)]))))
-
-  (define wx-slider%
-    (make-window-glue% 
-     (class100 (make-control% wx:slider% 
-			      const-default-x-margin const-default-y-margin 
-			      #f #f)
-	 (parent func label value min-val max-val style font)
-       (inherit set-min-width set-min-height stretchable-in-x stretchable-in-y
-		get-client-size get-width get-height get-parent)
-       (private-field
-	;; # pixels per possible setting.
-	[pixels-per-value 3])
-       ;; 3 is good because with horizontal sliders under Xt, with 1 or 2
-       ;; pixels per value, the thumb is too small to display the number,
-       ;; which looks bad.
-       
-       (sequence
-	 (super-init style parent func label value min-val max-val -1 -1 -1 (cons 'deleted style) font)
-	 
-	 (let-values ([(client-w client-h) (get-two-int-values (lambda (a b)
-								 (get-client-size a b)))])
-	   (let* ([horizontal? (memq 'horizontal style)]
-		  [vertical-labels? (eq? (send (send (get-parent) get-window) get-label-position) 'vertical)]
-		  [range (+ (* pixels-per-value (add1 (- max-val min-val)))
-			    (cond
-			     [(and horizontal? (not vertical-labels?)) (- (get-width) client-w)]
-			     [(and (not horizontal?) vertical-labels?) (- (get-height) client-h)]
-			     [else 0]))])
-	     ((if horizontal? (lambda (v) (set-min-width v)) (lambda (v) (set-min-height v)))
-	      (max ((if horizontal? (lambda () (get-width)) (lambda () (get-height))))
-		   (min const-max-gauge-length range)))
-	     (stretchable-in-x horizontal?)
-	     (stretchable-in-y (not horizontal?))))))))
-
-  )
 

collects/mred/private/wxlitem.rkt

@@ -0,0 +1,370 @@
+(module wxlitem mzscheme
+  (require mzlib/class
+	   mzlib/class100
+           mzlib/file
+           (only racket/base remq)
+	   (prefix wx: "kernel.ss")
+	   "lock.ss"
+	   "helper.ss"
+	   "const.ss"
+	   "wx.ss"
+	   "check.ss"
+	   "wxwindow.ss"
+	   "wxitem.ss"
+           "wxpanel.ss")
+
+  (provide (protect wx-choice%
+                    wx-list-box%
+                    wx-radio-box%
+                    wx-gauge%
+                    wx-slider%))
+
+  ;; ----------------------------------------
+
+  (define (is-horiz? style parent)
+    (cond
+     [(memq 'vertical-label style) #f]
+     [(memq 'horizontal-label style) #t]
+     [else (eq? (send (send parent get-window) get-label-position) 'horizontal)]))
+
+  (define (make-sub horiz? proxy this ha va)
+    (if horiz?
+        (begin
+          (send this alignment ha va)
+          this)
+        (let ([p (make-object wx-vertical-pane% #f proxy this null #f)])
+          (send p skip-subwindow-events? #t)
+          (send (send p area-parent) add-child p)
+          (send p alignment ha va)
+          p)))
+
+  (define (make-label label proxy p font)
+    (and label 
+         (let ([l (make-object wx-message% #f proxy p label -1 -1 null font)])
+           (send l skip-subwindow-events? #t)
+           l)))
+
+  (define (filter-style style)
+    (remq 'deleted style))
+
+  (define-syntax-rule (bounce c (m arg ...) ...)
+    (begin
+      (define/public m (lambda (arg ...) (send c m arg ...)))
+      ...))
+
+  ;; ----------------------------------------
+  
+  (define wx-label-panel%
+    (class wx-horizontal-panel% 
+      (init proxy parent label style font valign)
+      (inherit area-parent)
+      (define c #f)
+
+      (define/override (enable on?) (if c (send c enable on?) (void)))
+      (define/override (is-window-enabled?) (if c (send c is-window-enabled?) #t))
+
+      (super-init #f proxy parent (if (memq 'deleted style) '(deleted) null) #f)
+      (unless (memq 'deleted style)
+        (send (area-parent) add-child this))
+      (define horiz? (is-horiz? style parent))
+      (define p (make-sub horiz? proxy this 'left valign))
+
+      (define l (make-label label proxy p font))
+      (define/public (set-label s) (when l (send l set-label s)))
+      (define/public (get-label) (and l (send l get-label)))
+
+      (define/public (get-p) p)
+      (define/public (set-c v) 
+        (set! c v)
+        (send c stretchable-in-x #t)
+        (send c stretchable-in-y #t)
+        (send c skip-subwindow-events? #t))))
+
+  ;; ----------------------------------------
+
+  (define wx-internal-choice% 
+    (class100 (make-window-glue% (make-simple-control% wx:choice%)) (mred proxy parent cb label x y w h choices style font)
+      (override 
+        [handles-key-code 
+         (lambda (x alpha? meta?) 
+           (or (memq x '(up down))
+               (and alpha? (not meta?))))])
+      (sequence (super-init mred proxy style parent cb label x y w h choices (cons 'deleted style) font))))
+
+  (define wx-choice%
+    (class wx-label-panel% 
+      (init mred proxy parent cb label x y w h choices style font)
+      (inherit stretchable-in-y stretchable-in-x get-p set-c)
+
+      (super-init proxy parent label style font 'center)
+
+      (define c (make-object wx-internal-choice% mred proxy (get-p) cb label x y w h choices 
+                             (filter-style style) font))
+      (set-c c)
+
+      (bounce 
+       c
+       (set-selection i)
+       (get-selection)
+       (number)
+       (clear)
+       (append lbl))
+
+      (stretchable-in-y #f)
+      (stretchable-in-x #f)))
+
+  ;; ----------------------------------------
+
+  (define list-box-wheel-step #f)
+
+  (define wx-internal-list-box%
+    (make-window-glue% 
+     (class100 (make-control% wx:list-box%
+			      const-default-x-margin const-default-y-margin 
+			      #t #t) (parent cb label kind x y w h choices style font label-font)
+       (inherit get-first-item
+		set-first-visible-item)
+       (private
+	 [scroll (lambda (dir)
+		   (unless list-box-wheel-step
+		     (set! list-box-wheel-step (get-preference '|MrEd:wheelStep| (lambda () 3)))
+		     (unless (and (number? list-box-wheel-step)
+				  (exact? list-box-wheel-step)
+				  (integer? list-box-wheel-step)
+				  (<= 1 list-box-wheel-step 100))
+		       (set! list-box-wheel-step 3)))
+		   (let ([top (get-first-item)])
+		     (set-first-visible-item
+                      (max 0 (+ top (* list-box-wheel-step dir))))))])
+       (override
+	 [handles-key-code (lambda (x alpha? meta?)
+			     (case x
+			       [(up down) #t]
+			       [else (and alpha? (not meta?))]))]
+	 [pre-on-char (lambda (w e)
+			(or (super pre-on-char w e)
+			    (case (send e get-key-code)
+			      [(wheel-up) (scroll -1) #t]
+			      [(wheel-down) (scroll 1) #t]
+			      [else #f])))])
+       (sequence (super-init style parent cb label kind x y w h choices (cons 'deleted style) font label-font)))))
+
+  (define wx-list-box%
+    (class wx-label-panel% 
+      (init mred proxy parent cb label kind x y w h choices style font label-font)
+      (inherit get-p set-c)
+
+      (super-init proxy parent label style font 'top)
+
+      (define c (make-object wx-internal-list-box% mred proxy (get-p) cb label kind x y w h choices 
+                             (filter-style style) font label-font))
+      (set-c c)
+
+      (bounce
+       c
+       (get-label-font)
+       (set-string i s)
+       (set-selection i)
+       (get-selection)
+       (get-selections)
+       (visible-range)
+       (get-first-item)
+       (number-of-visible-items)
+       (set-first-visible-item i)
+       (number)
+       (get-row n)
+       (set-data i v)
+       (get-data i)
+       (selected? i)
+       (delete i)
+       (clear i)
+       (set choices)
+       (reset))
+      (define/public select 
+        (case-lambda
+         [(i) (send c select i)]
+         [(i on?) (send c select i on?)]
+         [(i on? extend?) (send c select i on? extend?)]))
+      (define/public append
+        (case-lambda
+         [(s) (send c append s)]
+         [(s v) (send c append s v)]))))
+
+  ;; ----------------------------------------
+
+  (define wx-internal-radio-box%
+    (make-window-glue% 
+     (class100 (make-simple-control% wx:radio-box%) (parent cb label x y w h choices major style font)
+       (inherit number orig-enable set-selection command)
+       (override
+	 [enable
+	  (case-lambda
+	   [(on?) (super enable on?)]
+	   [(which on?) (when (< -1 which (number))
+			  (vector-set! enable-vector which (and on? #t))
+			  (orig-enable which on?))])]
+	 [is-enabled?
+	  (case-lambda
+	   [() (super is-enabled?)]
+	   [(which) (and (< -1 which (number))
+			 (vector-ref enable-vector which))])])
+
+       (private-field [is-vertical? (memq 'vertical style)])
+       (public
+	 [vertical? (lambda () is-vertical?)]
+	 [char-to-button (lambda (i)
+			   (as-exit
+			    (lambda ()
+			      (set-selection i)
+			      (command (make-object wx:control-event% 'radio-box)))))])
+
+       (sequence (super-init style parent cb label x y w h choices major (cons 'deleted style) font))
+
+       (private-field [enable-vector (make-vector (number) #t)]))))
+
+  (define wx-radio-box%
+    (class wx-label-panel% 
+      (init mred proxy parent cb label x y w h choices major style font)
+      (inherit stretchable-in-y stretchable-in-x get-p set-c)
+
+      (super-init proxy parent label style font 'center)
+
+      (define c (make-object wx-internal-radio-box% mred proxy (get-p) cb label x y w h choices 
+                             major (filter-style style) font))
+      (set-c c)
+
+      (bounce 
+       c
+       (button-focus i)
+       (set-selection i)
+       (get-selection))
+      (stretchable-in-y #f)
+      (stretchable-in-x #f)))
+
+  ;; ----------------------------------------
+
+  (define wx-internal-gauge%
+    (make-window-glue% 
+     (class100 (make-control% wx:gauge% 
+			      const-default-x-margin const-default-y-margin 
+			      #f #f)
+	 (parent label range style font)
+       (inherit get-client-size get-width get-height set-size 
+		stretchable-in-x stretchable-in-y set-min-height set-min-width
+		get-parent)
+       (override [gets-focus? (lambda () #f)])
+       (private-field
+	;; # pixels per unit of value.
+	[pixels-per-value 1])
+       (sequence
+	 (super-init style parent label range -1 -1 -1 -1 (cons 'deleted style) font)
+
+	 (let-values ([(client-width client-height) (get-two-int-values 
+						     (lambda (a b) (get-client-size a b)))])
+	   (let ([delta-w (- (get-width) client-width)]
+		 [delta-h (- (get-height) client-height)]
+		 [vertical-labels? (eq? (send (send (get-parent) get-window) get-label-position) 'vertical)]
+		 [horizontal? (memq 'horizontal style)])
+	     (set-min-width (if horizontal?
+				(let ([cw (min const-max-gauge-length
+					       (* range pixels-per-value))])
+				  (max (if vertical-labels?
+					   cw
+					   (+ cw delta-w))
+				       (get-width)))
+				;; client-height is the default
+				;; dimension in the minor direction.
+				(+ client-width delta-w)))
+	     (set-min-height (if horizontal?
+				 (+ client-height delta-h)
+				 (let ([ch (min const-max-gauge-length
+						(* range pixels-per-value))])
+				   (max (if vertical-labels?
+					    (+ ch delta-h)
+					    ch)
+					(get-height)))))))
+
+	 (if (memq 'horizontal style)
+	     (begin
+	       (stretchable-in-x #t)
+	       (stretchable-in-y #f))
+	     (begin
+	       (stretchable-in-x #f)
+	       (stretchable-in-y #t)))))))
+
+  (define wx-gauge%
+    (class wx-label-panel% 
+      (init mred proxy parent label range style font)
+      (inherit stretchable-in-y stretchable-in-x get-p set-c)
+      
+      (super-init proxy parent label style font 'center)
+      
+      (define c (make-object wx-internal-gauge% mred proxy (get-p) label range
+                             (filter-style style) font))
+      (set-c c)
+
+      (bounce 
+       c
+       (get-range)
+       (set-range rng)
+       (get-value)
+       (set-value v))
+      (let ([h? (and (memq 'horizontal style) #t)])
+        (stretchable-in-x h?)
+        (stretchable-in-y (not h?)))))
+
+  ;; ----------------------------------------
+
+  (define wx-internal-slider%
+    (make-window-glue% 
+     (class100 (make-control% wx:slider% 
+			      const-default-x-margin const-default-y-margin 
+			      #f #f)
+	 (parent func label value min-val max-val style font)
+       (inherit set-min-width set-min-height stretchable-in-x stretchable-in-y
+		get-client-size get-width get-height get-parent)
+       (private-field
+	;; # pixels per possible setting.
+	[pixels-per-value 3])
+       ;; 3 is good because with horizontal sliders under Xt, with 1 or 2
+       ;; pixels per value, the thumb is too small to display the number,
+       ;; which looks bad.
+       
+       (sequence
+	 (super-init style parent func label value min-val max-val -1 -1 -1 (cons 'deleted style) font)
+	 
+	 (let-values ([(client-w client-h) (get-two-int-values (lambda (a b)
+								 (get-client-size a b)))])
+	   (let* ([horizontal? (memq 'horizontal style)]
+		  [vertical-labels? (eq? (send (send (get-parent) get-window) get-label-position) 'vertical)]
+		  [range (+ (* pixels-per-value (add1 (- max-val min-val)))
+			    (cond
+			     [(and horizontal? (not vertical-labels?)) (- (get-width) client-w)]
+			     [(and (not horizontal?) vertical-labels?) (- (get-height) client-h)]
+			     [else 0]))])
+	     ((if horizontal? (lambda (v) (set-min-width v)) (lambda (v) (set-min-height v)))
+	      (max ((if horizontal? (lambda () (get-width)) (lambda () (get-height))))
+		   (min const-max-gauge-length range)))
+	     (stretchable-in-x horizontal?)
+	     (stretchable-in-y (not horizontal?))))))))
+
+  (define wx-slider%
+    (class wx-label-panel% 
+      (init mred proxy parent func label value min-val max-val style font)
+      (inherit stretchable-in-y stretchable-in-x get-p set-c)
+
+      (super-init proxy parent label style font 'center)
+
+      (define c (make-object wx-internal-slider% mred proxy (get-p) func label value min-val max-val
+                             (filter-style style) font))
+      (set-c c)
+      
+      (bounce 
+       c
+       (get-value)
+       (set-value v))
+      (let ([h? (and (memq 'horizontal style) #t)])
+        (stretchable-in-x h?)
+        (stretchable-in-y (not h?)))))
+  
+)

collects/mred/private/wxtextfield.rkt

@@ -220,7 +220,7 @@
 	      (set! dy (- dy (unbox ybox))))
 	    
 	    ;; Subtract ascent of label
-	    (send l get-text-extent "hi" wbox hbox ybox abox)
+	    (send l get-text-extent "hi" wbox hbox ybox abox font)
 	    (set! dy (- dy (- (unbox hbox) (unbox ybox))))
 	    
 	    ;; Subtract space above label

collects/mred/private/wxwindow.rkt

@@ -2,6 +2,7 @@
   (require mzlib/class
 	   mzlib/class100
 	   (prefix wx: "kernel.ss")
+           "te.rkt"
 	   "lock.ss"
 	   "helper.ss"
 	   "wx.ss")
@@ -39,6 +40,14 @@
             [() skip-sub-events?]
             [(skip?) (set! skip-sub-events? skip?)])])
 	(public
+          [get-text-extent (lambda (s wb hb db ab font)
+                             (let-values ([(w h d a) (get-window-text-extent* s font #t)])
+                               (let ([set (lambda (b v)
+                                            (when b (set-box! b (inexact->exact (ceiling v)))))])
+                                 (set wb w)
+                                 (set hb h)
+                                 (set db d)
+                                 (set ab a))))]
 	  [on-active
 	   (lambda ()
 	     (let ([act? (is-enabled-to-root?)])