1#lang racket/base 2(require racket/class 3 ffi/unsafe 4 ffi/unsafe/objc 5 "../../syntax.rkt" 6 "item.rkt" 7 "types.rkt" 8 "const.rkt" 9 "utils.rkt" 10 "window.rkt" 11 "queue.rkt" 12 "../common/event.rkt" 13 "../common/queue.rkt" 14 "../common/freeze.rkt" 15 "../../lock.rkt") 16 17(provide 18 (protect-out slider%)) 19 20;; ---------------------------------------- 21 22(import-class NSSlider NSTextField NSView) 23 24(define-objc-class RacketSlider NSSlider 25 #:mixins (FocusResponder KeyMouseResponder CursorDisplayer) 26 [wxb] 27 (-a _void (changed: [_id sender]) 28 (let ([wx (->wx wxb)]) 29 (when wx 30 (send wx update-message) 31 (queue-window-event wx (lambda () (send wx changed))) 32 (constrained-reply 33 (send wx get-eventspace) 34 (lambda () (let loop () (pre-event-sync #t) (when (yield/no-sync) (loop)))) 35 (void)))))) 36 37(defclass slider% item% 38 (init parent cb 39 label 40 val lo hi 41 x y w 42 style 43 font) 44 (inherit get-cocoa register-as-child 45 init-font) 46 47 (define vert? (memq 'vertical style)) 48 49 (define slider-lo lo) 50 (define slider-hi hi) 51 52 (define slider-cocoa 53 (let ([cocoa (as-objc-allocation 54 (tell (tell RacketSlider alloc) init))]) 55 (tellv cocoa setMinValue: #:type _double* lo) 56 (tellv cocoa setMaxValue: #:type _double* hi) 57 (tellv cocoa setDoubleValue: #:type _double* (flip val)) 58 ;; heuristic: show up to tick marks: 59 (when ((- hi lo) . < . 64) 60 (tellv cocoa setNumberOfTickMarks: #:type _NSUInteger (add1 (- hi lo))) 61 (tellv cocoa setAllowsTickMarkValuesOnly: #:type _BOOL #t)) 62 (tellv cocoa setFrame: #:type _NSRect (make-NSRect 63 (make-NSPoint 0 0) 64 (make-NSSize (if vert? 24 32) 65 (if vert? 64 24)))) 66 (tellv cocoa setContinuous: #:type _BOOL #t) 67 ;; (tellv cocoa sizeToFit) 68 cocoa)) 69 70 (define-values (message-cocoa message-w message-h) 71 (if (memq 'plain style) 72 (values #f #f #f) 73 (let ([cocoa (as-objc-allocation 74 (tell (tell NSTextField alloc) init))]) 75 (init-font cocoa font) 76 (tellv cocoa setSelectable: #:type _BOOL #f) 77 (tellv cocoa setEditable: #:type _BOOL #f) 78 (tellv cocoa setBordered: #:type _BOOL #f) 79 (tellv cocoa setDrawsBackground: #:type _BOOL #f) 80 (tellv cocoa setStringValue: #:type _NSString (format "~a" hi)) 81 (tellv cocoa sizeToFit) 82 (let ([r1 (tell #:type _NSRect cocoa frame)]) 83 (tellv cocoa setStringValue: #:type _NSString (format "~a" lo)) 84 (tellv cocoa sizeToFit) 85 (let ([r2 (tell #:type _NSRect cocoa frame)]) 86 (tellv cocoa setStringValue: #:type _NSString (format "~a" val)) 87 (values cocoa 88 (max (NSSize-width (NSRect-size r1)) 89 (NSSize-width (NSRect-size r2))) 90 (max (NSSize-height (NSRect-size r1)) 91 (NSSize-height (NSRect-size r2))))))))) 92 93 (define cocoa 94 (if message-cocoa 95 (let* ([f (tell #:type _NSRect slider-cocoa frame)] 96 [w (+ (if vert? 97 message-w 98 0) 99 (NSSize-width (NSRect-size f)))] 100 [h (+ (if vert? 101 0 102 message-h) 103 (NSSize-height (NSRect-size f)))]) 104 (let ([cocoa (as-objc-allocation 105 (tell (tell NSView alloc) 106 initWithFrame: #:type _NSRect (make-NSRect 107 (make-init-point x y) 108 (make-NSSize w h))))]) 109 (tellv cocoa addSubview: slider-cocoa) 110 (tellv cocoa addSubview: message-cocoa) 111 (arrange-parts w h) 112 cocoa)) 113 slider-cocoa)) 114 115 (define/private (arrange-parts w h) 116 (tellv slider-cocoa setFrame: #:type _NSRect (make-NSRect 117 (make-NSPoint 0 118 (if vert? 0 message-h)) 119 (make-NSSize (- w (if vert? message-w 0)) 120 (- h (if vert? 0 message-h))))) 121 (tellv message-cocoa setFrame: #:type _NSRect (make-NSRect 122 (make-NSPoint (if vert? 123 (- w message-w) 124 (/ (- w message-w) 2)) 125 (if vert? 126 (/ (- h message-h) 2) 127 0)) 128 (make-NSSize message-w message-h)))) 129 130 (define/override (set-size x y w h) 131 (super set-size x y w h) 132 (when message-cocoa 133 (arrange-parts w h))) 134 135 (when message-cocoa 136 (set-ivar! slider-cocoa wxb (->wxb this))) 137 138 (super-new [parent parent] 139 [cocoa cocoa] 140 [callback cb] 141 [no-show? (memq 'deleted style)]) 142 143 (define/override (get-cocoa-control) slider-cocoa) 144 145 (tellv slider-cocoa setTarget: slider-cocoa) 146 (tellv slider-cocoa setAction: #:type _SEL (selector changed:)) 147 148 (define callback cb) 149 (define/public (changed) 150 (callback this (new control-event% 151 [event-type 'slider] 152 [time-stamp (current-milliseconds)]))) 153 154 (define/private (flip v) 155 (if vert? 156 (+ slider-lo (- slider-hi v)) 157 v)) 158 159 (define/public (set-value v) 160 (atomically 161 (tellv slider-cocoa setDoubleValue: #:type _double* (flip v)) 162 (update-message v))) 163 (define/public (get-value) 164 (flip (inexact->exact (floor (tell #:type _double slider-cocoa doubleValue))))) 165 166 (define/public (update-message [val (get-value)]) 167 (tellv message-cocoa setStringValue: #:type _NSString (format "~a" val)) 168 (tellv message-cocoa sizeToFit)) 169 170 (inherit get-cocoa-window) 171 (define/override (post-mouse-down) 172 ;; For some reason, dragging a slider disabled mouse-moved 173 ;; events for the window, so turn them back on: 174 (tellv (get-cocoa-window) setAcceptsMouseMovedEvents: #:type _BOOL #t)) 175 176 (define/override (maybe-register-as-child parent on?) 177 (register-as-child parent on?))) 178 179