suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix slider value display and 'plain option

Browse Source
This commit is contained in:
Matthew Flatt 2010-09-15 18:00:30 -06:00
parent 10455daf54
commit 5809bc7790
4 changed files with 113 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/mred/private/wx/cocoa/queue.rkt
View File

@ -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)

123
collects/mred/private/wx/cocoa/slider.rkt
View File

@ -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?)))

4
collects/mred/private/wx/gtk/slider.rkt
View File

@ -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)

12
collects/tests/gracket/item.rkt
View File

@ -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)