From edd12a64b8fabcba74441bc446e44c2302b3ecef Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 13 Jun 2010 09:26:44 -0600 Subject: [PATCH] implement labels for radio-box%, etc. --- collects/mred/private/gdi.rkt | 24 +- collects/mred/private/mritem.rkt | 1 + collects/mred/private/te.rkt | 19 + collects/mred/private/wx/cocoa/panel.rkt | 2 +- collects/mred/private/wx/cocoa/radio-box.rkt | 17 +- collects/mred/private/wx/cocoa/window.rkt | 1 - collects/mred/private/wx/gtk/window.rkt | 1 - collects/mred/private/wx/win32/window.rkt | 1 - collects/mred/private/wxitem.rkt | 166 +-------- collects/mred/private/wxlitem.rkt | 370 +++++++++++++++++++ collects/mred/private/wxtextfield.rkt | 2 +- collects/mred/private/wxwindow.rkt | 9 + 12 files changed, 424 insertions(+), 189 deletions(-) create mode 100644 collects/mred/private/te.rkt create mode 100644 collects/mred/private/wxlitem.rkt diff --git a/collects/mred/private/gdi.rkt b/collects/mred/private/gdi.rkt index 6c7cdb591d..15b66935ed 100644 --- a/collects/mred/private/gdi.rkt +++ b/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 combine?) - (check-string 'get-window-text-extent string) - (check-instance 'get-window-text-extent wx:font% 'font% #f font) - (unless bm - (set! bm (make-object wx:bitmap% 2 2)) - (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)))]))) - + (case-lambda + [(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) + (let-values ([(w h d a) (get-window-text-extent* string font combine?)]) + (values (inexact->exact (ceiling w)) (inexact->exact (ceiling h))))])) (define ugly? (lambda (a) diff --git a/collects/mred/private/mritem.rkt b/collects/mred/private/mritem.rkt index 31231d5c1e..6e8fa4704c 100644 --- a/collects/mred/private/mritem.rkt +++ b/collects/mred/private/mritem.rkt @@ -11,6 +11,7 @@ "helper.ss" "wx.ss" "wxitem.ss" + "wxlitem.ss" "mrwindow.ss" "mrcontainer.ss") diff --git a/collects/mred/private/te.rkt b/collects/mred/private/te.rkt new file mode 100644 index 0000000000..884c4cc1cb --- /dev/null +++ b/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))]))) diff --git a/collects/mred/private/wx/cocoa/panel.rkt b/collects/mred/private/wx/cocoa/panel.rkt index 881da5eb56..097df99f7a 100644 --- a/collects/mred/private/wx/cocoa/panel.rkt +++ b/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) diff --git a/collects/mred/private/wx/cocoa/radio-box.rkt b/collects/mred/private/wx/cocoa/radio-box.rkt index df2a694075..88db164233 100644 --- a/collects/mred/private/wx/cocoa/radio-box.rkt +++ b/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) - numberOfColumns: #:type _NSInteger 1))]) + numberOfRows: #:type _NSInteger (if horiz? 1 (length labels)) + numberOfColumns: #:type _NSInteger (if horiz? (length labels) 1)))]) (for ([label (in-list labels)] [i (in-naturals)]) (let ([button (tell cocoa - cellAtRow: #:type _NSInteger i - column: #:type _NSInteger 0)]) + cellAtRow: #:type _NSInteger (if horiz? 0 i) + 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)) diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index 72b9b34250..807f93e7d3 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/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) diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt index 22ccf89ec1..afe8079bbe 100644 --- a/collects/mred/private/wx/gtk/window.rkt +++ b/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) diff --git a/collects/mred/private/wx/win32/window.rkt b/collects/mred/private/wx/win32/window.rkt index 8931831e6b..30221b710e 100644 --- a/collects/mred/private/wx/win32/window.rkt +++ b/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) diff --git a/collects/mred/private/wxitem.rkt b/collects/mred/private/wxitem.rkt index fe6497cb95..e3b1dd62d8 100644 --- a/collects/mred/private/wxitem.rkt +++ b/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-gauge% - wx-list-box% - wx-radio-box% - wx-slider%)) + wx-message%)) ;; 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)))) - - (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?)))))))) - - ) + (sequence (super-init mred proxy style parent label x y (cons 'deleted style) font))))) diff --git a/collects/mred/private/wxlitem.rkt b/collects/mred/private/wxlitem.rkt new file mode 100644 index 0000000000..54f5b469e2 --- /dev/null +++ b/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?))))) + +) diff --git a/collects/mred/private/wxtextfield.rkt b/collects/mred/private/wxtextfield.rkt index c8f8c23745..629b070cda 100644 --- a/collects/mred/private/wxtextfield.rkt +++ b/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 diff --git a/collects/mred/private/wxwindow.rkt b/collects/mred/private/wxwindow.rkt index 2df610d25e..66ab6dff50 100644 --- a/collects/mred/private/wxwindow.rkt +++ b/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?)])