From 5809bc7790249e9cd5debfb29d09097189f9bcea Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 15 Sep 2010 18:00:30 -0600 Subject: [PATCH] fix slider value display and 'plain option --- collects/mred/private/wx/cocoa/queue.rkt | 3 +- collects/mred/private/wx/cocoa/slider.rkt | 123 ++++++++++++++++++---- collects/mred/private/wx/gtk/slider.rkt | 4 + collects/tests/gracket/item.rkt | 12 ++- 4 files changed, 113 insertions(+), 29 deletions(-) diff --git a/collects/mred/private/wx/cocoa/queue.rkt b/collects/mred/private/wx/cocoa/queue.rkt index 9b2c2fea44..3557c15f80 100644 --- a/collects/mred/private/wx/cocoa/queue.rkt +++ b/collects/mred/private/wx/cocoa/queue.rkt @@ -259,8 +259,7 @@ (define (try-to-sync-refresh) (atomically - (pre-event-sync #t) - (check-one-event #f #f))) + (pre-event-sync #t))) ;; ------------------------------------------------------------ ;; Install an alternate "sleep" function (in the PLT Scheme core) diff --git a/collects/mred/private/wx/cocoa/slider.rkt b/collects/mred/private/wx/cocoa/slider.rkt index 246d402df3..477cd96ddb 100644 --- a/collects/mred/private/wx/cocoa/slider.rkt +++ b/collects/mred/private/wx/cocoa/slider.rkt @@ -19,7 +19,7 @@ ;; ---------------------------------------- -(import-class NSSlider) +(import-class NSSlider NSTextField NSView) (define-objc-class MySlider NSSlider #:mixins (FocusResponder KeyMouseResponder CursorDisplayer) @@ -27,6 +27,7 @@ (-a _void (changed: [_id sender]) (let ([wx (->wx wxb)]) (when wx + (send wx update-message) (queue-window-event wx (lambda () (send wx changed))) (constrained-reply (send wx get-eventspace) @@ -40,31 +41,104 @@ x y w style font) - (inherit get-cocoa register-as-child) + (inherit get-cocoa register-as-child + init-font) + + (define vert? (memq 'vertical style)) + + (define slider-cocoa + (let ([cocoa (as-objc-allocation + (tell (tell MySlider alloc) init))]) + (tellv cocoa setMinValue: #:type _double* lo) + (tellv cocoa setMaxValue: #:type _double* hi) + (tellv cocoa setDoubleValue: #:type _double* val) + (tellv cocoa setNumberOfTickMarks: #:type _NSUInteger (add1 (- hi lo))) + (tellv cocoa setAllowsTickMarkValuesOnly: #:type _BOOL #t) + (tellv cocoa setFrame: #:type _NSRect (make-NSRect + (make-NSPoint 0 0) + (make-NSSize (if vert? 24 32) + (if vert? 64 24)))) + (tellv cocoa setContinuous: #:type _BOOL #t) + ;; (tellv cocoa sizeToFit) + cocoa)) + + (define-values (message-cocoa message-w message-h) + (if (memq 'plain style) + (values #f #f #f) + (let ([cocoa (as-objc-allocation + (tell (tell NSTextField alloc) init))]) + (init-font cocoa font) + (tellv cocoa setSelectable: #:type _BOOL #f) + (tellv cocoa setEditable: #:type _BOOL #f) + (tellv cocoa setBordered: #:type _BOOL #f) + (tellv cocoa setDrawsBackground: #:type _BOOL #f) + (tellv cocoa setTitleWithMnemonic: #:type _NSString (format "~a" hi)) + (tellv cocoa sizeToFit) + (let ([r1 (tell #:type _NSRect cocoa frame)]) + (tellv cocoa setTitleWithMnemonic: #:type _NSString (format "~a" lo)) + (tellv cocoa sizeToFit) + (let ([r2 (tell #:type _NSRect cocoa frame)]) + (tellv cocoa setTitleWithMnemonic: #:type _NSString (format "~a" val)) + (values cocoa + (max (NSSize-width (NSRect-size r1)) + (NSSize-width (NSRect-size r2))) + (max (NSSize-height (NSRect-size r1)) + (NSSize-height (NSRect-size r2))))))))) + + (define cocoa + (if message-cocoa + (let* ([f (tell #:type _NSRect slider-cocoa frame)] + [w (+ (if vert? + message-w + 0) + (NSSize-width (NSRect-size f)))] + [h (+ (if vert? + 0 + message-h) + (NSSize-height (NSRect-size f)))]) + (let ([cocoa (as-objc-allocation + (tell (tell NSView alloc) + initWithFrame: #:type _NSRect (make-NSRect + (make-init-point x y) + (make-NSSize w h))))]) + (tellv cocoa addSubview: slider-cocoa) + (tellv cocoa addSubview: message-cocoa) + (arrange-parts w h) + cocoa)) + slider-cocoa)) + + (define/private (arrange-parts w h) + (tellv slider-cocoa setFrame: #:type _NSRect (make-NSRect + (make-NSPoint 0 + (if vert? 0 message-h)) + (make-NSSize (- w (if vert? message-w 0)) + (- h (if vert? 0 message-h))))) + (tellv message-cocoa setFrame: #:type _NSRect (make-NSRect + (make-NSPoint (if vert? + (- w message-w) + (/ (- w message-w) 2)) + (if vert? + (/ (- h message-h) 2) + 0)) + (make-NSSize message-w message-h)))) + + (define/override (set-size x y w h) + (super set-size x y w h) + (when message-cocoa + (arrange-parts w h))) + + (when message-cocoa + (set-ivar! slider-cocoa wxb (->wxb this))) (super-new [parent parent] - [cocoa (let ([cocoa (as-objc-allocation - (tell (tell MySlider alloc) init))] - [vert? (memq 'vertical style)]) - (tellv cocoa setMinValue: #:type _double* lo) - (tellv cocoa setMaxValue: #:type _double* hi) - (tellv cocoa setDoubleValue: #:type _double* val) - (tellv cocoa setNumberOfTickMarks: #:type _NSUInteger (add1 (- hi lo))) - (tellv cocoa setAllowsTickMarkValuesOnly: #:type _BOOL #t) - (tellv cocoa setFrame: #:type _NSRect (make-NSRect - (make-NSPoint 0 0) - (make-NSSize (if vert? 24 32) - (if vert? 64 24)))) - (tellv cocoa setContinuous: #:type _BOOL #t) - ; (tellv cocoa sizeToFit) - cocoa)] + [cocoa cocoa] [callback cb] [no-show? (memq 'deleted style)]) - (define cocoa (get-cocoa)) + (define/override (get-cocoa-control) slider-cocoa) - (tellv cocoa setTarget: cocoa) - (tellv cocoa setAction: #:type _SEL (selector changed:)) + (tellv slider-cocoa setTarget: slider-cocoa) + (tellv slider-cocoa setAction: #:type _SEL (selector changed:)) (define callback cb) (define/public (changed) @@ -74,9 +148,14 @@ (define/public (set-value v) - (tellv cocoa setDoubleValue: #:type _double* v)) + (atomically + (tellv slider-cocoa setDoubleValue: #:type _double* v) + (update-message v))) (define/public (get-value) - (inexact->exact (floor (tell #:type _double cocoa doubleValue)))) + (inexact->exact (floor (tell #:type _double slider-cocoa doubleValue)))) + + (define/public (update-message [val (get-value)]) + (tellv message-cocoa setTitleWithMnemonic: #:type _NSString (format "~a" val))) (define/override (maybe-register-as-child parent on?) (register-as-child parent on?))) diff --git a/collects/mred/private/wx/gtk/slider.rkt b/collects/mred/private/wx/gtk/slider.rkt index edcf5ad94c..c2888a2514 100644 --- a/collects/mred/private/wx/gtk/slider.rkt +++ b/collects/mred/private/wx/gtk/slider.rkt @@ -21,6 +21,7 @@ (define-gtk gtk_range_set_increments (_fun _GtkWidget _double* _double* -> _void)) (define-gtk gtk_range_set_value (_fun _GtkWidget _double* -> _void)) (define-gtk gtk_range_get_value (_fun _GtkWidget -> _double)) +(define-gtk gtk_scale_set_draw_value (_fun _GtkWidget _gboolean -> _void)) (define-signal-handler connect-changed "value-changed" (_fun _GtkWidget -> _void) @@ -51,6 +52,9 @@ (gtk_range_set_increments gtk 1.0 1.0) (gtk_range_set_value gtk val) + (when (memq 'plain style) + (gtk_scale_set_draw_value gtk #f)) + (set-auto-size) (connect-changed gtk) diff --git a/collects/tests/gracket/item.rkt b/collects/tests/gracket/item.rkt index 0027c1cd20..e8bd6f9a00 100644 --- a/collects/tests/gracket/item.rkt +++ b/collects/tests/gracket/item.rkt @@ -1561,7 +1561,7 @@ (instructions p "choice-list-steps.txt") (send f show #t)) -(define (slider-frame) +(define (slider-frame style) (define f (make-frame frame% "Slider Test")) (define p (make-object vertical-panel% f)) (define old-list null) @@ -1570,7 +1570,8 @@ (lambda (sl e) (check-callback-event s sl e commands #f) (printf "slid: ~a\n" (send s get-value))) - 3)) + 3 + (cons 'horizontal style))) (define c (make-object button% "Check" p (lambda (c e) (for-each @@ -2168,17 +2169,18 @@ (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 button% "Make Slider Frame" gsp (lambda (b e) (slider-frame null))) +(make-object button% "Make Plain Slider Frame" gsp (lambda (b e) (slider-frame '(plain)))) (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)))) +(make-object vertical-pane% tp) ; filler +(make-object button% "Make Modified Frame" tp (lambda (b e) (test-modified-frame))) (define cnp (make-object horizontal-pane% ap)) (send cnp stretchable-width #t)