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