diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index 1c0b2fba47..8b7c86fc82 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -16,6 +16,7 @@ "gc.rkt" "image.rkt" "../common/backing-dc.rkt" + "../common/canvas-mixin.rkt" "../common/event.rkt" "../common/queue.rkt" "../../syntax.rkt" @@ -164,650 +165,620 @@ (define scroll-width (tell #:type _CGFloat NSScroller scrollerWidth)) (define canvas% - (class window% - (init parent - x y w h - style - [ignored-name #f] - [gl-config #f]) + (canvas-mixin + (class window% + (init parent + x y w h + style + [ignored-name #f] + [gl-config #f]) - (inherit get-cocoa get-cocoa-window - get-eventspace - make-graphics-context - is-shown-to-root? - is-shown-to-before-root? - move get-x get-y - on-size - register-as-child - get-size get-position - set-focus - client-to-screen) + (inherit get-cocoa get-cocoa-window + get-eventspace + make-graphics-context + is-shown-to-root? + is-shown-to-before-root? + move get-x get-y + on-size + register-as-child + get-size get-position + set-focus + client-to-screen) - (define vscroll-ok? (and (memq 'vscroll style) #t)) - (define vscroll? vscroll-ok?) - (define hscroll-ok? (and (memq 'hscroll style) #t)) - (define hscroll? hscroll-ok?) + (define vscroll-ok? (and (memq 'vscroll style) #t)) + (define vscroll? vscroll-ok?) + (define hscroll-ok? (and (memq 'hscroll style) #t)) + (define hscroll? hscroll-ok?) - (define auto-scroll? #f) - (define virtual-height #f) - (define virtual-width #f) + (define auto-scroll? #f) + (define virtual-height #f) + (define virtual-width #f) - (define wants-focus? (not (memq 'no-focus style))) - (define is-combo? (memq 'combo style)) - (define has-control-border? (and (not is-combo?) - (memq 'control-border style))) + (define wants-focus? (not (memq 'no-focus style))) + (define is-combo? (memq 'combo style)) + (define has-control-border? (and (not is-combo?) + (memq 'control-border style))) - (define-values (x-margin y-margin x-sb-margin y-sb-margin) - (cond - [has-control-border? (values 3 3 3 3)] - [(memq 'border style) (values 1 1 0 0)] - [else (values 0 0 0 0)])) + (define-values (x-margin y-margin x-sb-margin y-sb-margin) + (cond + [has-control-border? (values 3 3 3 3)] + [(memq 'border style) (values 1 1 0 0)] + [else (values 0 0 0 0)])) - (define canvas-style style) + (define canvas-style style) - (define/override (focus-is-on on?) - (when has-control-border? - (tellv cocoa setFocusState: #:type _BOOL on?) - (tellv cocoa setNeedsDisplay: #:type _BOOL #t)) - (super focus-is-on on?)) + (define/override (focus-is-on on?) + (when has-control-border? + (tellv cocoa setFocusState: #:type _BOOL on?) + (tellv cocoa setNeedsDisplay: #:type _BOOL #t)) + (super focus-is-on on?)) - ;; Avoid multiple queued paints, and also allow cancel - ;; of queued paint: - (define paint-queued #f) ; #f or (box #t) + ;; The `queue-paint' and `paint-children' methods + ;; are defined by `canvas-mixin' from ../common/canvas-mixin + (define/public (queue-paint) (void)) + (define/public (request-canvas-flush-delay) + (request-flush-delay (get-cocoa-window))) + (define/public (cancel-canvas-flush-delay req) + (cancel-flush-delay req)) + (define/public (queue-canvas-refresh-event thunk) + (queue-window-refresh-event this thunk)) - (define/public (queue-paint) - ;; can be called from any thread, including the event-pump thread - (unless paint-queued - (let ([b (box #t)]) - (set! paint-queued b) - (let ([req (request-flush-delay (get-cocoa-window))]) - (queue-window-refresh-event - this - (lambda () (do-on-paint req b))))))) - - (define/private (do-on-paint req b) - ;; only called in the handler thread - (when (or (not b) (unbox b)) - (let ([pq paint-queued]) - (when pq (set-box! pq #f))) - (set! paint-queued #f) - (when (or (not b) (is-shown-to-root?)) - (send dc suspend-flush) - (send dc ensure-ready) - (send dc erase) ; start with a clean slate - (let ([bg (get-canvas-background)]) - (when bg - (let ([old-bg (send dc get-background)]) - (send dc set-background bg) - (send dc clear) - (send dc set-background old-bg)))) - (on-paint) - (send dc resume-flush) - (queue-backing-flush))) - (when req - (cancel-flush-delay req))) - - (define/public (paint-or-queue-paint) - (or (do-backing-flush this dc (tell NSGraphicsContext currentContext) - (if is-combo? 2 0) (if is-combo? 2 0)) - (begin - (queue-paint) - #f))) - - (define/override (paint-children) - (when (or paint-queued - (not (send dc can-backing-flush?))) - (do-on-paint #f #f))) - - (define/public (begin-refresh-sequence) - (send dc suspend-flush)) - (define/public (end-refresh-sequence) - (send dc resume-flush)) - - (define/public (get-flush-window) - (get-cocoa-window)) - - (define/override (refresh) - ;; can be called from any thread, including the event-pump thread - (queue-paint)) - - (define/public (queue-backing-flush) - ;; called atomically (not expecting exceptions) - (tellv content-cocoa setNeedsDisplay: #:type _BOOL #t)) - - (define/override (get-cocoa-content) content-cocoa) - - (super-new - [parent parent] - [cocoa - (as-objc-allocation - (tell (tell (cond - [is-combo? NSView] - [has-control-border? FocusView] - [(memq 'border style) (if (memq 'vscroll style) - CornerlessFrameView - FrameView)] - [else NSView]) - alloc) - initWithFrame: #:type _NSRect (make-NSRect (make-init-point x y) - (make-NSSize (max w (* 2 x-margin)) - (max h (* 2 y-margin))))))] - [no-show? (memq 'deleted style)]) - - (define cocoa (get-cocoa)) - - (define content-cocoa - (let ([r (make-NSRect (make-NSPoint 0 0) - (make-NSSize (max 0 (- w (* 2 x-margin))) - (max 0 (- h (* 2 y-margin)))))]) - (as-objc-allocation - (tell (tell (if is-combo? MyComboBox MyView) alloc) - initWithFrame: #:type _NSRect r)))) - (tell #:type _void cocoa addSubview: content-cocoa) - (set-ivar! content-cocoa wxb (->wxb this)) - - (when is-combo? - (tellv content-cocoa setEditable: #:type _BOOL #f) - (tellv content-cocoa setDelegate: content-cocoa) - (install-control-font content-cocoa #f)) - - (define dc (make-object dc% this)) - - (send dc start-backing-retained) - - (queue-paint) - - (define/public (get-dc) dc) - - (define/public (make-compatible-bitmap w h) - (make-object quartz-bitmap% w h)) - - (define/override (fix-dc [refresh? #t]) - (when (dc . is-a? . dc%) - (send dc reset-backing-retained) - (send dc set-auto-scroll - (if auto-scroll? (scroll-pos h-scroller) 0) - (if auto-scroll? (scroll-pos v-scroller) 0))) - (when refresh? (refresh))) - - (define/override (get-client-size xb yb) - (super get-client-size xb yb) - (when is-combo? - (set-box! yb (max 0 (- (unbox yb) 5))))) - - (define/override (maybe-register-as-child parent on?) - (register-as-child parent on?)) - - (define/public (on-paint) (void)) - - (define/override (set-size x y w h) - (do-set-size x y w h)) - - (define tr 0) - - (define/override (show on?) - ;; FIXME: what if we're in the middle of an on-paint? - (super show on?) - (fix-dc)) - - (define/override (hide-children) - (super hide-children) - (suspend-all-reg-blits)) - - (define/override (show-children) - (super show-children) - (resume-all-reg-blits)) - - (define/private (do-set-size x y w h) - (when (pair? blits) - (atomically (suspend-all-reg-blits))) - (super set-size x y w h) - (when tr - (tellv content-cocoa removeTrackingRect: #:type _NSInteger tr) - (set! tr #f)) - (let ([sz (make-NSSize (- w (if vscroll? scroll-width 0) x-margin x-margin) - (- h (if hscroll? scroll-width 0) y-margin y-margin))] - [pos (make-NSPoint x-margin (+ (if hscroll? scroll-width 0) y-margin))]) - (tellv content-cocoa setFrame: #:type _NSRect (make-NSRect pos sz)) - (set! tr (tell #:type _NSInteger - content-cocoa - addTrackingRect: #:type _NSRect (make-NSRect (make-NSPoint x-margin y-margin) sz) - owner: content-cocoa - userData: #f - assumeInside: #:type _BOOL #f))) - (when v-scroller - (tellv (scroller-cocoa v-scroller) setFrame: #:type _NSRect - (make-NSRect - (make-NSPoint (- w scroll-width x-sb-margin) - (+ (if hscroll? - scroll-width - 0) - y-sb-margin)) - (make-NSSize scroll-width - (max 0 (- h (if hscroll? scroll-width 0) - x-sb-margin x-sb-margin)))))) - (when h-scroller - (tellv (scroller-cocoa h-scroller) setFrame: #:type _NSRect - (make-NSRect - (make-NSPoint x-sb-margin y-sb-margin) - (make-NSSize (max 0 (- w (if vscroll? scroll-width 0) - x-sb-margin x-sb-margin)) - scroll-width)))) - (when (and (pair? blits) - (is-shown-to-root?)) - (atomically (resume-all-reg-blits))) - (fix-dc) - (when auto-scroll? - (reset-auto-scroll 0 0)) - (on-size 0 0)) - - (define/public (show-scrollbars h? v?) - (let ([h? (and h? hscroll-ok?)] - [v? (and v? vscroll-ok?)]) - (unless (and (eq? h? hscroll?) - (eq? v? vscroll?)) - (cond - [(and h? (not hscroll?)) - (tell #:type _void cocoa addSubview: (scroller-cocoa h-scroller))] - [(and hscroll? (not h?)) - (tell #:type _void (scroller-cocoa h-scroller) removeFromSuperview)]) - (set! hscroll? h?) - (cond - [(and v? (not vscroll?)) - (tell #:type _void cocoa addSubview: (scroller-cocoa v-scroller))] - [(and vscroll? (not v?)) - (tell #:type _void (scroller-cocoa v-scroller) removeFromSuperview)]) - (set! vscroll? v?) - (let ([x (box 0)] [y (box 0)] [w (box 0)] [h (box 0)]) - (get-position x y) - (get-size w h) - (do-set-size (unbox x) (unbox y) (unbox w) (unbox h)))))) - - (define/public (set-scrollbars h-step v-step - h-len v-len - h-page v-page - h-pos v-pos - auto?) - (cond - [auto? - (set! auto-scroll? #t) - (set! virtual-width (and (positive? h-len) h-len)) - (set! virtual-height (and (positive? v-len) v-len)) - (reset-auto-scroll h-pos v-pos) - (refresh-for-autoscroll)] - [else - (let ([a? auto-scroll?]) - (set! auto-scroll? #f) - (when a? (fix-dc))) ; disable scroll offsets - (scroll-range h-scroller h-len) - (scroll-page h-scroller h-page) - (scroll-pos h-scroller h-pos) - (when h-scroller - (tell (scroller-cocoa h-scroller) setEnabled: #:type _BOOL (and h-step (positive? h-len)))) - (scroll-range v-scroller v-len) - (scroll-page v-scroller v-page) - (scroll-pos v-scroller v-pos) - (when v-scroller - (tell (scroller-cocoa v-scroller) setEnabled: #:type _BOOL (and v-step (positive? v-len)))) - (set! virtual-width #f) - (set! virtual-height #f)])) - - (define/private (reset-auto-scroll h-pos v-pos) - (let ([xb (box 0)] - [yb (box 0)]) - (get-client-size xb yb) - (let ([cw (unbox xb)] - [ch (unbox yb)]) - (let ([h-len (if virtual-width - (max 0 (- virtual-width cw)) - 0)] - [v-len (if virtual-height - (max 0 (- virtual-height ch)) - 0)] - [h-page (if virtual-width - cw - 0)] - [v-page (if virtual-height - ch - 0)]) - (scroll-range h-scroller h-len) - (scroll-page h-scroller h-page) - (scroll-pos h-scroller h-pos) - (when h-scroller - (tell (scroller-cocoa h-scroller) setEnabled: #:type _BOOL (positive? h-len))) - (scroll-range v-scroller v-len) - (scroll-page v-scroller v-page) - (scroll-pos v-scroller v-pos) - (when v-scroller - (tell (scroller-cocoa v-scroller) setEnabled: #:type _BOOL (positive? v-len))))))) - - (define/private (refresh-for-autoscroll) - (fix-dc) - (refresh)) - - (define (update which scroll- v) - (if (eq? which 'vertical) - (scroll- v-scroller v) - (scroll- h-scroller v))) - - (define/public (set-scroll-page which v) - (update which scroll-page v)) - (define/public (set-scroll-range which v) - (update which scroll-range v)) - (define/public (set-scroll-pos which v) - (update which scroll-pos v)) - - (define/public (get-scroll-page which) - (scroll-page (if (eq? which 'vertical) v-scroller h-scroller))) - (define/public (get-scroll-range which) - (scroll-range (if (eq? which 'vertical) v-scroller h-scroller))) - (define/public (get-scroll-pos which) - (scroll-pos (if (eq? which 'vertical) v-scroller h-scroller))) - - (define v-scroller - (and vscroll-ok? - (make-scroller - (as-objc-allocation - (tell (tell NSScroller alloc) initWithFrame: - #:type _NSRect (make-NSRect - (make-NSPoint (- w scroll-width x-sb-margin) - (+ (if hscroll? - scroll-width - 0) - y-sb-margin)) - (make-NSSize scroll-width - (max (- h (if hscroll? scroll-width 0) - y-sb-margin y-sb-margin) - (+ scroll-width 10)))))) - 1 - 1))) - (define h-scroller - (and hscroll-ok? - (make-scroller - (as-objc-allocation - (tell (tell NSScroller alloc) initWithFrame: - #:type _NSRect (make-NSRect - (make-NSPoint x-sb-margin y-sb-margin) - (make-NSSize (max (- w (if vscroll? scroll-width 0) - x-sb-margin x-sb-margin) - (+ scroll-width 10)) - scroll-width)))) - 1 - 1))) - - (when v-scroller - (tell #:type _void cocoa addSubview: (scroller-cocoa v-scroller)) - (tellv (scroller-cocoa v-scroller) setTarget: content-cocoa) - (tellv (scroller-cocoa v-scroller) setAction: #:type _SEL (selector onVScroll:))) - (when h-scroller - (tell #:type _void cocoa addSubview: (scroller-cocoa h-scroller)) - (tellv (scroller-cocoa h-scroller) setTarget: content-cocoa) - (tellv (scroller-cocoa h-scroller) setAction: #:type _SEL (selector onHScroll:))) - - (define scroll-pos - (case-lambda - [(scroller val) - (when scroller - (tellv (scroller-cocoa scroller) setFloatValue: - #:type _float (max (min 1.0 (/ val (exact->inexact (scroller-range scroller)))) - 0.0)))] - [(scroller) - (if scroller - (->long (round (* (tell #:type _double (scroller-cocoa scroller) floatValue) - (scroller-range scroller)))) - 0)])) - - (define scroll-range - (case-lambda - [(scroller val) - (when scroller - (let ([pos (scroll-pos scroller)] - [page (scroll-page scroller)]) - (set-scroller-range! scroller val) - (tell (scroller-cocoa scroller) setEnabled: #:type _BOOL (positive? val)) - (scroll-pos scroller pos) - (scroll-page scroller page)))] - [(scroller) - (if scroller - (scroller-range scroller) - 1)])) - - (define scroll-page - (case-lambda - [(scroller val) - (when scroller - (set-scroller-page! scroller val) - (tellv (scroller-cocoa scroller) setKnobProportion: - #:type _CGFloat (max (min 1.0 (/ val - (+ val (exact->inexact (scroller-range scroller))))) - 0.0)))] - [(scroller) - (if scroller - (scroller-page scroller) - 1)])) - - (define/public (append-combo-item str) - (tellv content-cocoa addItemWithObjectValue: #:type _NSString str) - #t) - (define/public (on-combo-select i) (void)) - - (define bg-col (make-object color% "white")) - (define/public (get-canvas-background) (if (memq 'transparent canvas-style) - #f - bg-col)) - (define/public (set-canvas-background col) (set! bg-col col)) - (define/public (get-canvas-background-for-clearing) - (and (not (memq 'transparent canvas-style)) - (not (memq 'no-autoclear canvas-style)) - bg-col)) - - (define/public (reject-partial-update r) - ;; Called in the event-pump thread. - ;; A transparent canvas cannot handle a partial update. - (and (or - ;; Multiple clipping rects? - (let ([i (malloc _NSInteger)] - [r (malloc 'atomic _pointer)]) - (tellv content-cocoa getRectsBeingDrawn: #:type _pointer r - count: #:type _pointer i) - ((ptr-ref i _NSInteger) . > . 1)) - ;; Single clipping not whole area? - (let ([s1 (NSRect-size (tell #:type _NSRect content-cocoa frame))] - [s2 (NSRect-size r)]) - (or ((NSSize-width s2) . < . (NSSize-width s1)) - ((NSSize-height s2) . < . (NSSize-height s1))))) + (define/public (paint-or-queue-paint) + (or (do-backing-flush this dc (tell NSGraphicsContext currentContext) + (if is-combo? 2 0) (if is-combo? 2 0)) (begin - (queue-window-event this (lambda () (refresh))) - #t))) + (queue-paint) + #f))) - (define/public (do-scroll direction scroller) - ;; Called from the Cocoa handler thread - (let ([part (tell #:type _int scroller hitPart)]) - (queue-window-event - this - (lambda () - (let ([kind - (cond - [(= part NSScrollerDecrementPage) - (set-scroll-pos direction (- (get-scroll-pos direction) - (get-scroll-page direction))) - 'page-up] - [(= part NSScrollerIncrementPage) - (set-scroll-pos direction (+ (get-scroll-pos direction) - (get-scroll-page direction))) - 'page-down] - [(= part NSScrollerDecrementLine) - (set-scroll-pos direction (- (get-scroll-pos direction) 1)) - 'line-up] - [(= part NSScrollerIncrementLine) - (set-scroll-pos direction (+ (get-scroll-pos direction) 1)) - 'line-down] - [(= part NSScrollerKnob) - 'thumb] - [else #f])]) - (when kind - (if auto-scroll? - (refresh-for-autoscroll) - (on-scroll (new scroll-event% - [event-type kind] - [direction direction] - [position (get-scroll-pos direction)])))))))) - (constrained-reply (get-eventspace) - (lambda () - (let loop () (pre-event-sync #t) (when (yield) (loop)))) - (void))) - (define/public (on-scroll e) (void)) - - (define/override (definitely-wants-event? e) - ;; Called in Cocoa event-handling mode - (when (and wants-focus? - (e . is-a? . mouse-event%) - (send e button-down? 'left)) - (set-focus)) - (or (not is-combo?) - (e . is-a? . key-event%) - (not (send e button-down? 'left)) - (not (on-menu-click? e)))) + (define/public (begin-refresh-sequence) + (send dc suspend-flush)) + (define/public (end-refresh-sequence) + (send dc resume-flush)) - (define/override (gets-focus?) - wants-focus?) - (define/override (can-be-responder?) - wants-focus?) + (define/public (get-flush-window) + (get-cocoa-window)) - (define/private (on-menu-click? e) - ;; Called in Cocoa event-handling mode - (let ([xb (box 0)] - [yb (box 0)]) - (get-client-size xb yb) - ((send e get-x) . > . (- (unbox xb) 22)))) + (define/override (refresh) + ;; can be called from any thread, including the event-pump thread + (queue-paint)) - (define/public (starting-combo) - (set! in-menu-click? #t) - (tellv content-cocoa setStringValue: #:type _NSString current-text)) - - (define/public (ending-combo) - (set! in-menu-click? #f) - (let ([pos (tell #:type _NSInteger content-cocoa indexOfSelectedItem)]) - (when (pos . > . -1) - (queue-window-event this (lambda () (on-combo-select pos))))) - (refresh)) + (define/public (queue-backing-flush) + ;; called atomically (not expecting exceptions) + (tellv content-cocoa setNeedsDisplay: #:type _BOOL #t)) - (define current-text "") - (define/public (set-combo-text t) - (set! current-text t)) + (define/override (get-cocoa-content) content-cocoa) - (define in-menu-click? #f) + (super-new + [parent parent] + [cocoa + (as-objc-allocation + (tell (tell (cond + [is-combo? NSView] + [has-control-border? FocusView] + [(memq 'border style) (if (memq 'vscroll style) + CornerlessFrameView + FrameView)] + [else NSView]) + alloc) + initWithFrame: #:type _NSRect (make-NSRect (make-init-point x y) + (make-NSSize (max w (* 2 x-margin)) + (max h (* 2 y-margin))))))] + [no-show? (memq 'deleted style)]) - (define/public (during-menu-click?) - ;; Called in Cocoa event-handling mode - in-menu-click?) + (define cocoa (get-cocoa)) - (def/public-unimplemented set-background-to-gray) + (define content-cocoa + (let ([r (make-NSRect (make-NSPoint 0 0) + (make-NSSize (max 0 (- w (* 2 x-margin))) + (max 0 (- h (* 2 y-margin)))))]) + (as-objc-allocation + (tell (tell (if is-combo? MyComboBox MyView) alloc) + initWithFrame: #:type _NSRect r)))) + (tell #:type _void cocoa addSubview: content-cocoa) + (set-ivar! content-cocoa wxb (->wxb this)) - (define/public (scroll x y) - (when (x . > . 0) (scroll-pos h-scroller (* x (scroll-range h-scroller)))) - (when (y . > . 0) (scroll-pos v-scroller (* y (scroll-range v-scroller)))) - (when auto-scroll? (refresh-for-autoscroll))) + (when is-combo? + (tellv content-cocoa setEditable: #:type _BOOL #f) + (tellv content-cocoa setDelegate: content-cocoa) + (install-control-font content-cocoa #f)) - (def/public-unimplemented warp-pointer) + (define dc (make-object dc% this)) - (define/public (view-start xb yb) - (if auto-scroll? - (begin - (set-box! xb (if virtual-width - (scroll-pos h-scroller) - 0)) - (set-box! yb (if virtual-height - (scroll-pos v-scroller) - 0))) - (begin - (set-box! xb 0) - (set-box! yb 0)))) + (send dc start-backing-retained) - (define/public (set-resize-corner on?) - (void)) + (queue-paint) + + (define/public (get-dc) dc) - (define/public (get-backing-size xb yb) - (get-client-size xb yb) - (when is-combo? - (set-box! xb (- (unbox xb) 22)))) + (define/public (make-compatible-bitmap w h) + (make-object quartz-bitmap% w h)) - (define/override (get-cursor-width-delta) - (if is-combo? 22 0)) + (define/override (fix-dc [refresh? #t]) + (when (dc . is-a? . dc%) + (send dc reset-backing-retained) + (send dc set-auto-scroll + (if auto-scroll? (scroll-pos h-scroller) 0) + (if auto-scroll? (scroll-pos v-scroller) 0))) + (when refresh? (refresh))) - (define/public (is-flipped?) - (tell #:type _BOOL (get-cocoa-content) isFlipped)) + (define/override (get-client-size xb yb) + (super get-client-size xb yb) + (when is-combo? + (set-box! yb (max 0 (- (unbox yb) 5))))) - (define/public (get-virtual-size xb yb) - (get-client-size xb yb) - (when virtual-width (set-box! xb virtual-width)) - (when virtual-height (set-box! yb virtual-height))) + (define/override (maybe-register-as-child parent on?) + (register-as-child parent on?)) - (define blits null) - (define reg-blits null) + (define/public (on-paint) (void)) - (define/private (suspend-all-reg-blits) - (let ([cocoa-win (get-cocoa-window)]) - (for ([r (in-list reg-blits)]) - (tellv cocoa-win removeChildWindow: (car r)) - (release (car r)) - (scheme_remove_gc_callback (cdr r)))) - (set! reg-blits null)) + (define/override (set-size x y w h) + (do-set-size x y w h)) - (define/public (resume-all-reg-blits) - (unless (pair? reg-blits) - (when (pair? blits) - (set! reg-blits - (for/list ([b (in-list blits)]) - (let-values ([(x y w h img) (apply values b)]) - (register-one-blit x y w h img))))))) + (define tr 0) - (define/private (register-one-blit x y w h img) - (let ([xb (box x)] - [yb (box y)]) - (client-to-screen xb yb #f) - (let* ([cocoa-win (get-cocoa-window)]) - (atomically - (let ([win (as-objc-allocation - (tell (tell NSWindow alloc) - initWithContentRect: #:type _NSRect (make-NSRect (make-NSPoint (unbox xb) - (- (unbox yb) - h)) - (make-NSSize w h)) - styleMask: #:type _int NSBorderlessWindowMask - backing: #:type _int NSBackingStoreBuffered - defer: #:type _BOOL NO))] - [iv (tell (tell NSImageView alloc) init)]) - (tellv iv setImage: img) - (tellv iv setFrame: #:type _NSRect (make-NSRect (make-NSPoint 0 0) - (make-NSSize w h))) - (tellv (tell win contentView) addSubview: iv) - (tellv win setAlphaValue: #:type _CGFloat 0.0) - (tellv cocoa-win addChildWindow: win ordered: #:type _int NSWindowAbove) - (tellv iv release) - (let ([r (scheme_add_gc_callback - (make-gc-action-desc win (selector setAlphaValue:) 1.0) - (make-gc-action-desc win (selector setAlphaValue:) 0.0))]) - (cons win r))))))) - - (define/public (register-collecting-blit x y w h on off on-x on-y off-x off-y) - (let ([on (if (and (zero? on-x) - (zero? on-y) - (= (send on get-width) w) - (= (send on get-height) h)) - on - (let ([bm (make-object bitmap% w h)]) - (let ([dc (make-object bitmap-dc% on)]) - (send dc draw-bitmap-section on 0 0 on-x on-y w h) - (send dc set-bitmap #f) - bm)))]) - (let ([img (bitmap->image on)]) - (atomically - (set! blits (cons (list x y w h img) blits)) - (when (is-shown-to-root?) - (set! reg-blits (cons (register-one-blit x y w h img) reg-blits))))))) + (define/override (show on?) + ;; FIXME: what if we're in the middle of an on-paint? + (super show on?) + (fix-dc)) - (define/public (unregister-collecting-blits) - (atomically - (suspend-all-reg-blits) - (set! blits null))))) + (define/override (hide-children) + (super hide-children) + (suspend-all-reg-blits)) + + (define/override (show-children) + (super show-children) + (resume-all-reg-blits)) + + (define/private (do-set-size x y w h) + (when (pair? blits) + (atomically (suspend-all-reg-blits))) + (super set-size x y w h) + (when tr + (tellv content-cocoa removeTrackingRect: #:type _NSInteger tr) + (set! tr #f)) + (let ([sz (make-NSSize (- w (if vscroll? scroll-width 0) x-margin x-margin) + (- h (if hscroll? scroll-width 0) y-margin y-margin))] + [pos (make-NSPoint x-margin (+ (if hscroll? scroll-width 0) y-margin))]) + (tellv content-cocoa setFrame: #:type _NSRect (make-NSRect pos sz)) + (set! tr (tell #:type _NSInteger + content-cocoa + addTrackingRect: #:type _NSRect (make-NSRect (make-NSPoint x-margin y-margin) sz) + owner: content-cocoa + userData: #f + assumeInside: #:type _BOOL #f))) + (when v-scroller + (tellv (scroller-cocoa v-scroller) setFrame: #:type _NSRect + (make-NSRect + (make-NSPoint (- w scroll-width x-sb-margin) + (+ (if hscroll? + scroll-width + 0) + y-sb-margin)) + (make-NSSize scroll-width + (max 0 (- h (if hscroll? scroll-width 0) + x-sb-margin x-sb-margin)))))) + (when h-scroller + (tellv (scroller-cocoa h-scroller) setFrame: #:type _NSRect + (make-NSRect + (make-NSPoint x-sb-margin y-sb-margin) + (make-NSSize (max 0 (- w (if vscroll? scroll-width 0) + x-sb-margin x-sb-margin)) + scroll-width)))) + (when (and (pair? blits) + (is-shown-to-root?)) + (atomically (resume-all-reg-blits))) + (fix-dc) + (when auto-scroll? + (reset-auto-scroll 0 0)) + (on-size 0 0)) + + (define/public (show-scrollbars h? v?) + (let ([h? (and h? hscroll-ok?)] + [v? (and v? vscroll-ok?)]) + (unless (and (eq? h? hscroll?) + (eq? v? vscroll?)) + (cond + [(and h? (not hscroll?)) + (tell #:type _void cocoa addSubview: (scroller-cocoa h-scroller))] + [(and hscroll? (not h?)) + (tell #:type _void (scroller-cocoa h-scroller) removeFromSuperview)]) + (set! hscroll? h?) + (cond + [(and v? (not vscroll?)) + (tell #:type _void cocoa addSubview: (scroller-cocoa v-scroller))] + [(and vscroll? (not v?)) + (tell #:type _void (scroller-cocoa v-scroller) removeFromSuperview)]) + (set! vscroll? v?) + (let ([x (box 0)] [y (box 0)] [w (box 0)] [h (box 0)]) + (get-position x y) + (get-size w h) + (do-set-size (unbox x) (unbox y) (unbox w) (unbox h)))))) + + (define/public (set-scrollbars h-step v-step + h-len v-len + h-page v-page + h-pos v-pos + auto?) + (cond + [auto? + (set! auto-scroll? #t) + (set! virtual-width (and (positive? h-len) h-len)) + (set! virtual-height (and (positive? v-len) v-len)) + (reset-auto-scroll h-pos v-pos) + (refresh-for-autoscroll)] + [else + (let ([a? auto-scroll?]) + (set! auto-scroll? #f) + (when a? (fix-dc))) ; disable scroll offsets + (scroll-range h-scroller h-len) + (scroll-page h-scroller h-page) + (scroll-pos h-scroller h-pos) + (when h-scroller + (tell (scroller-cocoa h-scroller) setEnabled: #:type _BOOL (and h-step (positive? h-len)))) + (scroll-range v-scroller v-len) + (scroll-page v-scroller v-page) + (scroll-pos v-scroller v-pos) + (when v-scroller + (tell (scroller-cocoa v-scroller) setEnabled: #:type _BOOL (and v-step (positive? v-len)))) + (set! virtual-width #f) + (set! virtual-height #f)])) + + (define/private (reset-auto-scroll h-pos v-pos) + (let ([xb (box 0)] + [yb (box 0)]) + (get-client-size xb yb) + (let ([cw (unbox xb)] + [ch (unbox yb)]) + (let ([h-len (if virtual-width + (max 0 (- virtual-width cw)) + 0)] + [v-len (if virtual-height + (max 0 (- virtual-height ch)) + 0)] + [h-page (if virtual-width + cw + 0)] + [v-page (if virtual-height + ch + 0)]) + (scroll-range h-scroller h-len) + (scroll-page h-scroller h-page) + (scroll-pos h-scroller h-pos) + (when h-scroller + (tell (scroller-cocoa h-scroller) setEnabled: #:type _BOOL (positive? h-len))) + (scroll-range v-scroller v-len) + (scroll-page v-scroller v-page) + (scroll-pos v-scroller v-pos) + (when v-scroller + (tell (scroller-cocoa v-scroller) setEnabled: #:type _BOOL (positive? v-len))))))) + + (define/private (refresh-for-autoscroll) + (fix-dc) + (refresh)) + + (define (update which scroll- v) + (if (eq? which 'vertical) + (scroll- v-scroller v) + (scroll- h-scroller v))) + + (define/public (set-scroll-page which v) + (update which scroll-page v)) + (define/public (set-scroll-range which v) + (update which scroll-range v)) + (define/public (set-scroll-pos which v) + (update which scroll-pos v)) + + (define/public (get-scroll-page which) + (scroll-page (if (eq? which 'vertical) v-scroller h-scroller))) + (define/public (get-scroll-range which) + (scroll-range (if (eq? which 'vertical) v-scroller h-scroller))) + (define/public (get-scroll-pos which) + (scroll-pos (if (eq? which 'vertical) v-scroller h-scroller))) + + (define v-scroller + (and vscroll-ok? + (make-scroller + (as-objc-allocation + (tell (tell NSScroller alloc) initWithFrame: + #:type _NSRect (make-NSRect + (make-NSPoint (- w scroll-width x-sb-margin) + (+ (if hscroll? + scroll-width + 0) + y-sb-margin)) + (make-NSSize scroll-width + (max (- h (if hscroll? scroll-width 0) + y-sb-margin y-sb-margin) + (+ scroll-width 10)))))) + 1 + 1))) + (define h-scroller + (and hscroll-ok? + (make-scroller + (as-objc-allocation + (tell (tell NSScroller alloc) initWithFrame: + #:type _NSRect (make-NSRect + (make-NSPoint x-sb-margin y-sb-margin) + (make-NSSize (max (- w (if vscroll? scroll-width 0) + x-sb-margin x-sb-margin) + (+ scroll-width 10)) + scroll-width)))) + 1 + 1))) + + (when v-scroller + (tell #:type _void cocoa addSubview: (scroller-cocoa v-scroller)) + (tellv (scroller-cocoa v-scroller) setTarget: content-cocoa) + (tellv (scroller-cocoa v-scroller) setAction: #:type _SEL (selector onVScroll:))) + (when h-scroller + (tell #:type _void cocoa addSubview: (scroller-cocoa h-scroller)) + (tellv (scroller-cocoa h-scroller) setTarget: content-cocoa) + (tellv (scroller-cocoa h-scroller) setAction: #:type _SEL (selector onHScroll:))) + + (define scroll-pos + (case-lambda + [(scroller val) + (when scroller + (tellv (scroller-cocoa scroller) setFloatValue: + #:type _float (max (min 1.0 (/ val (exact->inexact (scroller-range scroller)))) + 0.0)))] + [(scroller) + (if scroller + (->long (round (* (tell #:type _double (scroller-cocoa scroller) floatValue) + (scroller-range scroller)))) + 0)])) + + (define scroll-range + (case-lambda + [(scroller val) + (when scroller + (let ([pos (scroll-pos scroller)] + [page (scroll-page scroller)]) + (set-scroller-range! scroller val) + (tell (scroller-cocoa scroller) setEnabled: #:type _BOOL (positive? val)) + (scroll-pos scroller pos) + (scroll-page scroller page)))] + [(scroller) + (if scroller + (scroller-range scroller) + 1)])) + + (define scroll-page + (case-lambda + [(scroller val) + (when scroller + (set-scroller-page! scroller val) + (tellv (scroller-cocoa scroller) setKnobProportion: + #:type _CGFloat (max (min 1.0 (/ val + (+ val (exact->inexact (scroller-range scroller))))) + 0.0)))] + [(scroller) + (if scroller + (scroller-page scroller) + 1)])) + + (define/public (append-combo-item str) + (tellv content-cocoa addItemWithObjectValue: #:type _NSString str) + #t) + (define/public (on-combo-select i) (void)) + + (define bg-col (make-object color% "white")) + (define/public (get-canvas-background) (if (memq 'transparent canvas-style) + #f + bg-col)) + (define/public (set-canvas-background col) (set! bg-col col)) + (define/public (get-canvas-background-for-clearing) + (and (not (memq 'transparent canvas-style)) + (not (memq 'no-autoclear canvas-style)) + bg-col)) + + (define/public (reject-partial-update r) + ;; Called in the event-pump thread. + ;; A transparent canvas cannot handle a partial update. + (and (or + ;; Multiple clipping rects? + (let ([i (malloc _NSInteger)] + [r (malloc 'atomic _pointer)]) + (tellv content-cocoa getRectsBeingDrawn: #:type _pointer r + count: #:type _pointer i) + ((ptr-ref i _NSInteger) . > . 1)) + ;; Single clipping not whole area? + (let ([s1 (NSRect-size (tell #:type _NSRect content-cocoa frame))] + [s2 (NSRect-size r)]) + (or ((NSSize-width s2) . < . (NSSize-width s1)) + ((NSSize-height s2) . < . (NSSize-height s1))))) + (begin + (queue-window-event this (lambda () (refresh))) + #t))) + + (define/public (do-scroll direction scroller) + ;; Called from the Cocoa handler thread + (let ([part (tell #:type _int scroller hitPart)]) + (queue-window-event + this + (lambda () + (let ([kind + (cond + [(= part NSScrollerDecrementPage) + (set-scroll-pos direction (- (get-scroll-pos direction) + (get-scroll-page direction))) + 'page-up] + [(= part NSScrollerIncrementPage) + (set-scroll-pos direction (+ (get-scroll-pos direction) + (get-scroll-page direction))) + 'page-down] + [(= part NSScrollerDecrementLine) + (set-scroll-pos direction (- (get-scroll-pos direction) 1)) + 'line-up] + [(= part NSScrollerIncrementLine) + (set-scroll-pos direction (+ (get-scroll-pos direction) 1)) + 'line-down] + [(= part NSScrollerKnob) + 'thumb] + [else #f])]) + (when kind + (if auto-scroll? + (refresh-for-autoscroll) + (on-scroll (new scroll-event% + [event-type kind] + [direction direction] + [position (get-scroll-pos direction)])))))))) + (constrained-reply (get-eventspace) + (lambda () + (let loop () (pre-event-sync #t) (when (yield) (loop)))) + (void))) + (define/public (on-scroll e) (void)) + + (define/override (definitely-wants-event? e) + ;; Called in Cocoa event-handling mode + (when (and wants-focus? + (e . is-a? . mouse-event%) + (send e button-down? 'left)) + (set-focus)) + (or (not is-combo?) + (e . is-a? . key-event%) + (not (send e button-down? 'left)) + (not (on-menu-click? e)))) + + (define/override (gets-focus?) + wants-focus?) + (define/override (can-be-responder?) + wants-focus?) + + (define/private (on-menu-click? e) + ;; Called in Cocoa event-handling mode + (let ([xb (box 0)] + [yb (box 0)]) + (get-client-size xb yb) + ((send e get-x) . > . (- (unbox xb) 22)))) + + (define/public (starting-combo) + (set! in-menu-click? #t) + (tellv content-cocoa setStringValue: #:type _NSString current-text)) + + (define/public (ending-combo) + (set! in-menu-click? #f) + (let ([pos (tell #:type _NSInteger content-cocoa indexOfSelectedItem)]) + (when (pos . > . -1) + (queue-window-event this (lambda () (on-combo-select pos))))) + (refresh)) + + (define current-text "") + (define/public (set-combo-text t) + (set! current-text t)) + + (define in-menu-click? #f) + + (define/public (during-menu-click?) + ;; Called in Cocoa event-handling mode + in-menu-click?) + + (def/public-unimplemented set-background-to-gray) + + (define/public (scroll x y) + (when (x . > . 0) (scroll-pos h-scroller (* x (scroll-range h-scroller)))) + (when (y . > . 0) (scroll-pos v-scroller (* y (scroll-range v-scroller)))) + (when auto-scroll? (refresh-for-autoscroll))) + + (def/public-unimplemented warp-pointer) + + (define/public (view-start xb yb) + (if auto-scroll? + (begin + (set-box! xb (if virtual-width + (scroll-pos h-scroller) + 0)) + (set-box! yb (if virtual-height + (scroll-pos v-scroller) + 0))) + (begin + (set-box! xb 0) + (set-box! yb 0)))) + + (define/public (set-resize-corner on?) + (void)) + + (define/public (get-backing-size xb yb) + (get-client-size xb yb) + (when is-combo? + (set-box! xb (- (unbox xb) 22)))) + + (define/override (get-cursor-width-delta) + (if is-combo? 22 0)) + + (define/public (is-flipped?) + (tell #:type _BOOL (get-cocoa-content) isFlipped)) + + (define/public (get-virtual-size xb yb) + (get-client-size xb yb) + (when virtual-width (set-box! xb virtual-width)) + (when virtual-height (set-box! yb virtual-height))) + + (define blits null) + (define reg-blits null) + + (define/private (suspend-all-reg-blits) + (let ([cocoa-win (get-cocoa-window)]) + (for ([r (in-list reg-blits)]) + (tellv cocoa-win removeChildWindow: (car r)) + (release (car r)) + (scheme_remove_gc_callback (cdr r)))) + (set! reg-blits null)) + + (define/public (resume-all-reg-blits) + (unless (pair? reg-blits) + (when (pair? blits) + (set! reg-blits + (for/list ([b (in-list blits)]) + (let-values ([(x y w h img) (apply values b)]) + (register-one-blit x y w h img))))))) + + (define/private (register-one-blit x y w h img) + (let ([xb (box x)] + [yb (box y)]) + (client-to-screen xb yb #f) + (let* ([cocoa-win (get-cocoa-window)]) + (atomically + (let ([win (as-objc-allocation + (tell (tell NSWindow alloc) + initWithContentRect: #:type _NSRect (make-NSRect (make-NSPoint (unbox xb) + (- (unbox yb) + h)) + (make-NSSize w h)) + styleMask: #:type _int NSBorderlessWindowMask + backing: #:type _int NSBackingStoreBuffered + defer: #:type _BOOL NO))] + [iv (tell (tell NSImageView alloc) init)]) + (tellv iv setImage: img) + (tellv iv setFrame: #:type _NSRect (make-NSRect (make-NSPoint 0 0) + (make-NSSize w h))) + (tellv (tell win contentView) addSubview: iv) + (tellv win setAlphaValue: #:type _CGFloat 0.0) + (tellv cocoa-win addChildWindow: win ordered: #:type _int NSWindowAbove) + (tellv iv release) + (let ([r (scheme_add_gc_callback + (make-gc-action-desc win (selector setAlphaValue:) 1.0) + (make-gc-action-desc win (selector setAlphaValue:) 0.0))]) + (cons win r))))))) + + (define/public (register-collecting-blit x y w h on off on-x on-y off-x off-y) + (let ([on (if (and (zero? on-x) + (zero? on-y) + (= (send on get-width) w) + (= (send on get-height) h)) + on + (let ([bm (make-object bitmap% w h)]) + (let ([dc (make-object bitmap-dc% on)]) + (send dc draw-bitmap-section on 0 0 on-x on-y w h) + (send dc set-bitmap #f) + bm)))]) + (let ([img (bitmap->image on)]) + (atomically + (set! blits (cons (list x y w h img) blits)) + (when (is-shown-to-root?) + (set! reg-blits (cons (register-one-blit x y w h img) reg-blits))))))) + + (define/public (unregister-collecting-blits) + (atomically + (suspend-all-reg-blits) + (set! blits null)))))) diff --git a/collects/mred/private/wx/cocoa/dc.rkt b/collects/mred/private/wx/cocoa/dc.rkt index 7621a63995..278d2cbbb5 100644 --- a/collects/mred/private/wx/cocoa/dc.rkt +++ b/collects/mred/private/wx/cocoa/dc.rkt @@ -35,8 +35,9 @@ (define/override (release-bitmap-storage) (atomically - (cairo_surface_destroy s) - (set! s #f))))) + (when s + (cairo_surface_destroy s) + (set! s #f)))))) (define dc% (class backing-dc% diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt index 460251d900..78acf5f65c 100644 --- a/collects/mred/private/wx/cocoa/frame.rkt +++ b/collects/mred/private/wx/cocoa/frame.rkt @@ -475,8 +475,10 @@ (and on? #t)) (tellv cocoa zoom: cocoa))) - (def/public-unimplemented iconized?) - (def/public-unimplemented iconize) + (define/public (iconized?) + (tell #:type _BOOL cocoa isMiniaturized)) + (define/public (iconize on?) + (tellv cocoa miniaturize: cocoa)) (define/public (set-title s) (tellv cocoa setTitle: #:type _NSString s)))) diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index d89757db51..530d263a72 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -663,7 +663,8 @@ (do-request-flush-delay cocoa-win (lambda (cocoa-win) - (tellv cocoa-win disableFlushWindow)) + (tellv cocoa-win disableFlushWindow) + #t) (lambda (cocoa-win) (tellv cocoa-win enableFlushWindow)))) diff --git a/collects/mred/private/wx/common/canvas-mixin.rkt b/collects/mred/private/wx/common/canvas-mixin.rkt new file mode 100644 index 0000000000..2316c72775 --- /dev/null +++ b/collects/mred/private/wx/common/canvas-mixin.rkt @@ -0,0 +1,58 @@ +#lang racket/base +(require racket/class + "backing-dc.rkt") + +(provide canvas-mixin) + +(define (canvas-mixin %) + (class % + (super-new) + (inherit request-canvas-flush-delay + cancel-canvas-flush-delay + queue-canvas-refresh-event + is-shown-to-root? + on-paint + queue-backing-flush + get-dc + get-canvas-background) + + ;; Avoid multiple queued paints, and also allow cancel + ;; of queued paint: + (define paint-queued #f) ; #f or (box #t) + + (define/override (queue-paint) + ;; can be called from any thread, including the event-pump thread + (unless paint-queued + (let ([b (box #t)]) + (set! paint-queued b) + (let ([req (request-canvas-flush-delay)]) + (queue-canvas-refresh-event + (lambda () (do-on-paint req b))))))) + + (define/private (do-on-paint req b) + ;; only called in the handler thread + (when (or (not b) (unbox b)) + (let ([pq paint-queued]) + (when pq (set-box! pq #f))) + (set! paint-queued #f) + (when (or (not b) (is-shown-to-root?)) + (let ([dc (get-dc)]) + (send dc suspend-flush) + (send dc ensure-ready) + (send dc erase) ; start with a clean slate + (let ([bg (get-canvas-background)]) + (when bg + (let ([old-bg (send dc get-background)]) + (send dc set-background bg) + (send dc clear) + (send dc set-background old-bg)))) + (on-paint) + (send dc resume-flush) + (queue-backing-flush)))) + (when req + (cancel-canvas-flush-delay req))) + + (define/override (paint-children) + (when (or paint-queued + (not (send (get-dc) can-backing-flush?))) + (do-on-paint #f #f))))) diff --git a/collects/mred/private/wx/common/delay.rkt b/collects/mred/private/wx/common/delay.rkt index ef2aba0aae..0a348b0859 100644 --- a/collects/mred/private/wx/common/delay.rkt +++ b/collects/mred/private/wx/common/delay.rkt @@ -8,15 +8,17 @@ (define (do-request-flush-delay win disable enable) (atomically (let ([req (box win)]) - (disable win) - (add-event-boundary-sometimes-callback! - req - (lambda (v) - ;; in atomic mode - (when (unbox req) - (set-box! req #f) - (enable win)))) - req))) + (and + (disable win) + (begin + (add-event-boundary-sometimes-callback! + req + (lambda (v) + ;; in atomic mode + (when (unbox req) + (set-box! req #f) + (enable win)))) + req))))) (define (do-cancel-flush-delay req enable) (atomically diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index 96a13b69a9..a3ec1227c5 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -6,6 +6,7 @@ racket/draw/color racket/draw/local "../common/backing-dc.rkt" + "../common/canvas-mixin.rkt" "../../syntax.rkt" "../../lock.rkt" "../common/event.rkt" @@ -176,461 +177,434 @@ #t) (define canvas% - (class (client-size-mixin window%) - (init parent - x y w h - style - [ignored-name #f] - [gl-config #f]) + (canvas-mixin + (class (client-size-mixin window%) + (init parent + x y w h + style + [ignored-name #f] + [gl-config #f]) - (inherit get-gtk set-size get-size get-client-size - on-size get-top-win - set-auto-size - adjust-client-delta infer-client-delta) + (inherit get-gtk set-size get-size get-client-size + on-size get-top-win + set-auto-size + adjust-client-delta infer-client-delta) - (define is-combo? (memq 'combo style)) - (define has-border? (or (memq 'border style) - (memq 'control-border style))) + (define is-combo? (memq 'combo style)) + (define has-border? (or (memq 'border style) + (memq 'control-border style))) - (define margin (if has-border? 1 0)) + (define margin (if has-border? 1 0)) - (define auto-scroll? #f) - (define virtual-height #f) - (define virtual-width #f) + (define auto-scroll? #f) + (define virtual-height #f) + (define virtual-width #f) - (define-values (client-gtk gtk - hscroll-adj vscroll-adj hscroll-gtk vscroll-gtk resize-box - combo-button-gtk - scroll-width) - (atomically ;; need to connect all children to gtk to avoid leaks - (cond - [(or (memq 'hscroll style) - (memq 'vscroll style)) - (let* ([client-gtk (gtk_drawing_area_new)] - [hadj (gtk_adjustment_new 0.0 0.0 1.0 1.0 1.0 1.0)] - [vadj (gtk_adjustment_new 0.0 0.0 1.0 1.0 1.0 1.0)]) - (let ([h (as-gtk-allocation (gtk_hbox_new #f 0))] - [v (gtk_vbox_new #f 0)] - [v2 (gtk_vbox_new #f 0)] - [h2 (gtk_vbox_new #f 0)] - [hscroll (gtk_hscrollbar_new hadj)] - [vscroll (gtk_vscrollbar_new vadj)] - [resize-box (gtk_drawing_area_new)]) - ;; |------------------------------------| - ;; | h |-----------------| |-----------|| - ;; | | v | | v2 || - ;; | | | | [vscroll] || - ;; | | [h2 [hscroll]] | | [resize] || - ;; | |-----------------| |-----------|| - ;; |------------------------------------| - (when has-border? - (gtk_container_set_border_width h margin)) - (gtk_box_pack_start h v #t #t 0) - (gtk_box_pack_start v client-gtk #t #t 0) - (gtk_box_pack_start h v2 #f #f 0) - (gtk_box_pack_start v2 vscroll #t #t 0) - (gtk_box_pack_start v h2 #f #f 0) - (gtk_box_pack_start h2 hscroll #t #t 0) - (gtk_box_pack_start v2 resize-box #f #f 0) - (when (memq 'hscroll style) - (gtk_widget_show hscroll)) - (gtk_widget_show vscroll) - (gtk_widget_show h) - (gtk_widget_show v) - (when (memq 'vscroll style) - (gtk_widget_show v2)) - (gtk_widget_show h2) - (when (memq 'hscroll style) - (gtk_widget_show resize-box)) - (gtk_widget_show client-gtk) - (let ([req (make-GtkRequisition 0 0)]) - (gtk_widget_size_request vscroll req) - (values client-gtk h hadj vadj - (and (memq 'hscroll style) h2) - (and (memq 'vscroll style) v2) - (and (memq 'hscroll style) (memq 'vscroll style) resize-box) - #f - (GtkRequisition-width req)))))] - [is-combo? - (let* ([gtk (as-gtk-allocation (gtk_combo_box_entry_new_text))] - [orig-entry (gtk_bin_get_child gtk)]) - (values orig-entry gtk #f #f #f #f #f (extract-combo-button gtk) 0))] - [has-border? - (let ([client-gtk (gtk_drawing_area_new)] - [h (as-gtk-allocation (gtk_hbox_new #f 0))]) - (gtk_box_pack_start h client-gtk #t #t 0) - (gtk_container_set_border_width h margin) - (connect-expose-border h) - (gtk_widget_show client-gtk) - (values client-gtk h #f #f #f #f #f #f 0))] - [else - (let ([client-gtk (as-gtk-allocation (gtk_drawing_area_new))]) - (values client-gtk client-gtk #f #f #f #f #f #f 0))]))) - - (super-new [parent parent] - [gtk gtk] - [client-gtk client-gtk] - [no-show? (memq 'deleted style)] - [extra-gtks (if (eq? client-gtk gtk) - null - (if hscroll-adj - (list client-gtk hscroll-adj vscroll-adj) - (if combo-button-gtk - (list client-gtk combo-button-gtk) - (list client-gtk))))]) - - (set-size x y w h) - - (define dc (new dc% [canvas this])) - - (gtk_widget_realize gtk) - (gtk_widget_realize client-gtk) - - (when resize-box - (let ([r (make-GtkRequisition 0 0)]) - (gtk_widget_size_request hscroll-gtk r) - (gtk_widget_set_size_request resize-box - (GtkRequisition-height r) - (GtkRequisition-height r)))) - - (connect-expose client-gtk) - #;(gtk_widget_set_double_buffered client-gtk #f) - (connect-key-and-mouse client-gtk) - (connect-focus client-gtk) - (gtk_widget_add_events client-gtk (bitwise-ior GDK_KEY_PRESS_MASK - GDK_KEY_RELEASE_MASK - GDK_BUTTON_PRESS_MASK - GDK_BUTTON_RELEASE_MASK - GDK_POINTER_MOTION_MASK - GDK_FOCUS_CHANGE_MASK - GDK_ENTER_NOTIFY_MASK - GDK_LEAVE_NOTIFY_MASK)) - (unless (memq 'no-focus style) - (set-gtk-object-flags! client-gtk (bitwise-ior (get-gtk-object-flags client-gtk) - GTK_CAN_FOCUS))) - (when combo-button-gtk - (connect-combo-key-and-mouse combo-button-gtk)) - - (when hscroll-adj (connect-value-changed-h hscroll-adj)) - (when vscroll-adj (connect-value-changed-v vscroll-adj)) - - (set-auto-size) - (adjust-client-delta (+ (* 2 margin) - (if (memq 'vscroll style) - scroll-width - 0)) - (+ (* 2 margin) - (if (memq 'hscroll style) - scroll-width - 0))) - - (define/override (direct-update?) #f) - - (define/public (get-dc) dc) - - (define/public (make-compatible-bitmap w h) - (send dc make-backing-bitmap w h)) - - (define/override (get-client-gtk) client-gtk) - (define/override (handles-events? gtk) (not (ptr-equal? gtk combo-button-gtk))) - - (define/override (get-client-delta) - (values margin margin)) - - ;; Avoid multiple queued paints: - (define paint-queued? #f) - ;; To handle paint requests that happen while on-paint - ;; is being called already. kProbably doesn't happen, - ;; because expose callabcks should be in the right - ;; eventspace. - (define now-drawing? #f) - (define refresh-after-drawing? #f) - - (define/public (queue-paint) - ;; can be called from any thread, including the event-pump thread - (unless paint-queued? - (set! paint-queued? #t) - (queue-window-refresh-event - this - (lambda () - (set! paint-queued? #f) - (set! now-drawing? #t) - (send dc suspend-flush) - (send dc ensure-ready) - (send dc erase) ; clean slate - (let ([bg (get-canvas-background)]) - (when bg - (let ([old-bg (send dc get-background)]) - (send dc set-background bg) - (send dc clear) - (send dc set-background old-bg)))) - (on-paint) - (send dc resume-flush) - (set! now-drawing? #f) - (when refresh-after-drawing? - (set! refresh-after-drawing? #f) - (refresh)))))) - - (define/public (paint-or-queue-paint) - (or (do-backing-flush this dc (if is-combo? - (get-subwindow client-gtk) - (widget-window client-gtk))) - (begin - (queue-paint) - #f))) - - (define/public (on-paint) (void)) - - (define/public (get-flush-window) client-gtk) - - (define/public (begin-refresh-sequence) - (send dc suspend-flush)) - (define/public (end-refresh-sequence) - (send dc resume-flush)) - - (define/override (refresh) - (queue-paint)) - - (define/public (queue-backing-flush) - ;; called atomically (not expecting exceptions) - (gtk_widget_queue_draw client-gtk)) - - (define/override (reset-child-dcs) - (when (dc . is-a? . dc%) - (reset-dc))) - - (send dc start-backing-retained) - - (define/private (reset-dc) - (send dc reset-backing-retained) - (refresh) - (send dc set-auto-scroll - (if virtual-width - (gtk_adjustment_get_value hscroll-adj) - 0) - (if virtual-height - (gtk_adjustment_get_value vscroll-adj) - 0))) - - (define/override (internal-on-client-size w h) - (reset-dc)) - (define/override (on-client-size w h) - (let ([xb (box 0)] - [yb (box 0)]) - (get-size xb yb) - (on-size (unbox xb) (unbox yb)))) - - (define/public (show-scrollbars h? v?) - (when hscroll-gtk - (if h? - (gtk_widget_show hscroll-gtk) - (gtk_widget_hide hscroll-gtk))) - (when vscroll-gtk - (if v? - (gtk_widget_show vscroll-gtk) - (gtk_widget_hide vscroll-gtk))) - (when (and hscroll-gtk vscroll-gtk) + (define-values (client-gtk gtk + hscroll-adj vscroll-adj hscroll-gtk vscroll-gtk resize-box + combo-button-gtk + scroll-width) + (atomically ;; need to connect all children to gtk to avoid leaks (cond - [(and v? h?) - (gtk_widget_show resize-box)] - [(and v? (not h?)) - ;; remove corner - (gtk_widget_hide resize-box)])) - (adjust-client-delta (+ (* 2 margin) (if v? scroll-width 0)) - (+ (* 2 margin) (if h? scroll-width 0)))) - - (define/private (configure-adj adj scroll-gtk len page pos) - (when (and scroll-gtk adj) - (if (zero? len) - (gtk_adjustment_configure adj 0 0 1 1 1 1) - (gtk_adjustment_configure adj pos 0 (+ len page) 1 page page)))) - - (define/public (set-scrollbars h-step v-step - h-len v-len - h-page v-page - h-pos v-pos - auto?) - (let ([h-page (if (zero? h-len) 0 h-page)] - [v-page (if (zero? v-len) 0 v-page)]) - (cond - [auto? - (set! auto-scroll? #t) - (set! virtual-width (and (positive? h-len) hscroll-gtk h-len)) - (set! virtual-height (and (positive? v-len) vscroll-gtk v-len)) - (reset-auto-scroll h-pos v-pos) - (refresh-for-autoscroll)] + [(or (memq 'hscroll style) + (memq 'vscroll style)) + (let* ([client-gtk (gtk_drawing_area_new)] + [hadj (gtk_adjustment_new 0.0 0.0 1.0 1.0 1.0 1.0)] + [vadj (gtk_adjustment_new 0.0 0.0 1.0 1.0 1.0 1.0)]) + (let ([h (as-gtk-allocation (gtk_hbox_new #f 0))] + [v (gtk_vbox_new #f 0)] + [v2 (gtk_vbox_new #f 0)] + [h2 (gtk_vbox_new #f 0)] + [hscroll (gtk_hscrollbar_new hadj)] + [vscroll (gtk_vscrollbar_new vadj)] + [resize-box (gtk_drawing_area_new)]) + ;; |------------------------------------| + ;; | h |-----------------| |-----------|| + ;; | | v | | v2 || + ;; | | | | [vscroll] || + ;; | | [h2 [hscroll]] | | [resize] || + ;; | |-----------------| |-----------|| + ;; |------------------------------------| + (when has-border? + (gtk_container_set_border_width h margin)) + (gtk_box_pack_start h v #t #t 0) + (gtk_box_pack_start v client-gtk #t #t 0) + (gtk_box_pack_start h v2 #f #f 0) + (gtk_box_pack_start v2 vscroll #t #t 0) + (gtk_box_pack_start v h2 #f #f 0) + (gtk_box_pack_start h2 hscroll #t #t 0) + (gtk_box_pack_start v2 resize-box #f #f 0) + (when (memq 'hscroll style) + (gtk_widget_show hscroll)) + (gtk_widget_show vscroll) + (gtk_widget_show h) + (gtk_widget_show v) + (when (memq 'vscroll style) + (gtk_widget_show v2)) + (gtk_widget_show h2) + (when (memq 'hscroll style) + (gtk_widget_show resize-box)) + (gtk_widget_show client-gtk) + (let ([req (make-GtkRequisition 0 0)]) + (gtk_widget_size_request vscroll req) + (values client-gtk h hadj vadj + (and (memq 'hscroll style) h2) + (and (memq 'vscroll style) v2) + (and (memq 'hscroll style) (memq 'vscroll style) resize-box) + #f + (GtkRequisition-width req)))))] + [is-combo? + (let* ([gtk (as-gtk-allocation (gtk_combo_box_entry_new_text))] + [orig-entry (gtk_bin_get_child gtk)]) + (values orig-entry gtk #f #f #f #f #f (extract-combo-button gtk) 0))] + [has-border? + (let ([client-gtk (gtk_drawing_area_new)] + [h (as-gtk-allocation (gtk_hbox_new #f 0))]) + (gtk_box_pack_start h client-gtk #t #t 0) + (gtk_container_set_border_width h margin) + (connect-expose-border h) + (gtk_widget_show client-gtk) + (values client-gtk h #f #f #f #f #f #f 0))] [else - (configure-adj hscroll-adj hscroll-gtk h-len h-page h-pos) - (configure-adj vscroll-adj vscroll-gtk v-len v-page v-pos)]))) + (let ([client-gtk (as-gtk-allocation (gtk_drawing_area_new))]) + (values client-gtk client-gtk #f #f #f #f #f #f 0))]))) - (define/private (reset-auto-scroll h-pos v-pos) - (let ([xb (box 0)] - [yb (box 0)]) - (get-client-size xb yb) - (let ([cw (unbox xb)] - [ch (unbox yb)]) - (let ([h-len (if virtual-width - (max 0 (- virtual-width cw)) - 0)] - [v-len (if virtual-height - (max 0 (- virtual-height ch)) - 0)] - [h-page (if virtual-width - cw + (super-new [parent parent] + [gtk gtk] + [client-gtk client-gtk] + [no-show? (memq 'deleted style)] + [extra-gtks (if (eq? client-gtk gtk) + null + (if hscroll-adj + (list client-gtk hscroll-adj vscroll-adj) + (if combo-button-gtk + (list client-gtk combo-button-gtk) + (list client-gtk))))]) + + (set-size x y w h) + + (define dc (new dc% [canvas this])) + + (gtk_widget_realize gtk) + (gtk_widget_realize client-gtk) + + (when resize-box + (let ([r (make-GtkRequisition 0 0)]) + (gtk_widget_size_request hscroll-gtk r) + (gtk_widget_set_size_request resize-box + (GtkRequisition-height r) + (GtkRequisition-height r)))) + + (connect-expose client-gtk) + #;(gtk_widget_set_double_buffered client-gtk #f) + (connect-key-and-mouse client-gtk) + (connect-focus client-gtk) + (gtk_widget_add_events client-gtk (bitwise-ior GDK_KEY_PRESS_MASK + GDK_KEY_RELEASE_MASK + GDK_BUTTON_PRESS_MASK + GDK_BUTTON_RELEASE_MASK + GDK_POINTER_MOTION_MASK + GDK_FOCUS_CHANGE_MASK + GDK_ENTER_NOTIFY_MASK + GDK_LEAVE_NOTIFY_MASK)) + (unless (memq 'no-focus style) + (set-gtk-object-flags! client-gtk (bitwise-ior (get-gtk-object-flags client-gtk) + GTK_CAN_FOCUS))) + (when combo-button-gtk + (connect-combo-key-and-mouse combo-button-gtk)) + + (when hscroll-adj (connect-value-changed-h hscroll-adj)) + (when vscroll-adj (connect-value-changed-v vscroll-adj)) + + (set-auto-size) + (adjust-client-delta (+ (* 2 margin) + (if (memq 'vscroll style) + scroll-width + 0)) + (+ (* 2 margin) + (if (memq 'hscroll style) + scroll-width + 0))) + + (define/override (direct-update?) #f) + + (define/public (get-dc) dc) + + (define/public (make-compatible-bitmap w h) + (send dc make-backing-bitmap w h)) + + (define/override (get-client-gtk) client-gtk) + (define/override (handles-events? gtk) (not (ptr-equal? gtk combo-button-gtk))) + + (define/override (get-client-delta) + (values margin margin)) + + ;; The `queue-paint' and `paint-children' methods + ;; are defined by `canvas-mixin' from ../common/canvas-mixin + (define/public (queue-paint) (void)) + (define/public (request-canvas-flush-delay) + (request-flush-delay client-gtk)) + (define/public (cancel-canvas-flush-delay req) + (cancel-flush-delay req)) + (define/public (queue-canvas-refresh-event thunk) + (queue-window-refresh-event this thunk)) + + (define/public (paint-or-queue-paint) + (or (do-backing-flush this dc (if is-combo? + (get-subwindow client-gtk) + (widget-window client-gtk))) + (begin + (queue-paint) + #f))) + + (define/public (on-paint) (void)) + + (define/public (get-flush-window) client-gtk) + + (define/public (begin-refresh-sequence) + (send dc suspend-flush)) + (define/public (end-refresh-sequence) + (send dc resume-flush)) + + (define/override (refresh) + (queue-paint)) + + (define/public (queue-backing-flush) + ;; called atomically (not expecting exceptions) + (gtk_widget_queue_draw client-gtk)) + + (define/override (reset-child-dcs) + (when (dc . is-a? . dc%) + (reset-dc))) + + (send dc start-backing-retained) + + (define/private (reset-dc) + (send dc reset-backing-retained) + (refresh) + (send dc set-auto-scroll + (if virtual-width + (gtk_adjustment_get_value hscroll-adj) + 0) + (if virtual-height + (gtk_adjustment_get_value vscroll-adj) + 0))) + + (define/override (internal-on-client-size w h) + (reset-dc)) + (define/override (on-client-size w h) + (let ([xb (box 0)] + [yb (box 0)]) + (get-size xb yb) + (on-size (unbox xb) (unbox yb)))) + + (define/public (show-scrollbars h? v?) + (when hscroll-gtk + (if h? + (gtk_widget_show hscroll-gtk) + (gtk_widget_hide hscroll-gtk))) + (when vscroll-gtk + (if v? + (gtk_widget_show vscroll-gtk) + (gtk_widget_hide vscroll-gtk))) + (when (and hscroll-gtk vscroll-gtk) + (cond + [(and v? h?) + (gtk_widget_show resize-box)] + [(and v? (not h?)) + ;; remove corner + (gtk_widget_hide resize-box)])) + (adjust-client-delta (+ (* 2 margin) (if v? scroll-width 0)) + (+ (* 2 margin) (if h? scroll-width 0)))) + + (define/private (configure-adj adj scroll-gtk len page pos) + (when (and scroll-gtk adj) + (if (zero? len) + (gtk_adjustment_configure adj 0 0 1 1 1 1) + (gtk_adjustment_configure adj pos 0 (+ len page) 1 page page)))) + + (define/public (set-scrollbars h-step v-step + h-len v-len + h-page v-page + h-pos v-pos + auto?) + (let ([h-page (if (zero? h-len) 0 h-page)] + [v-page (if (zero? v-len) 0 v-page)]) + (cond + [auto? + (set! auto-scroll? #t) + (set! virtual-width (and (positive? h-len) hscroll-gtk h-len)) + (set! virtual-height (and (positive? v-len) vscroll-gtk v-len)) + (reset-auto-scroll h-pos v-pos) + (refresh-for-autoscroll)] + [else + (configure-adj hscroll-adj hscroll-gtk h-len h-page h-pos) + (configure-adj vscroll-adj vscroll-gtk v-len v-page v-pos)]))) + + (define/private (reset-auto-scroll h-pos v-pos) + (let ([xb (box 0)] + [yb (box 0)]) + (get-client-size xb yb) + (let ([cw (unbox xb)] + [ch (unbox yb)]) + (let ([h-len (if virtual-width + (max 0 (- virtual-width cw)) 0)] - [v-page (if virtual-height - ch - 0)]) - (configure-adj hscroll-adj hscroll-gtk h-len h-page h-pos) - (configure-adj vscroll-adj vscroll-gtk v-len v-page v-pos))))) + [v-len (if virtual-height + (max 0 (- virtual-height ch)) + 0)] + [h-page (if virtual-width + cw + 0)] + [v-page (if virtual-height + ch + 0)]) + (configure-adj hscroll-adj hscroll-gtk h-len h-page h-pos) + (configure-adj vscroll-adj vscroll-gtk v-len v-page v-pos))))) - (define/private (refresh-for-autoscroll) - (reset-dc) - (refresh)) + (define/private (refresh-for-autoscroll) + (reset-dc) + (refresh)) - (define/private (dispatch which proc [default (void)]) - (if (eq? which 'vertical) - (if vscroll-adj (proc vscroll-adj) default) - (if hscroll-adj (proc hscroll-adj) default))) + (define/private (dispatch which proc [default (void)]) + (if (eq? which 'vertical) + (if vscroll-adj (proc vscroll-adj) default) + (if hscroll-adj (proc hscroll-adj) default))) - (define/public (set-scroll-page which v) - (dispatch which (lambda (adj) - (let ([old (gtk_adjustment_get_page_size adj)]) - (unless (= old v) - (gtk_adjustment_set_page_size adj v) - (gtk_adjustment_set_page_increment adj v) - (gtk_adjustment_set_upper adj (+ (- v old) - (gtk_adjustment_get_upper adj)))))))) - (define/public (set-scroll-range which v) - (dispatch which (lambda (adj) - (gtk_adjustment_set_upper adj (+ v (gtk_adjustment_get_page_size adj)))))) - (define/public (set-scroll-pos which v) - (dispatch which (lambda (adj) (gtk_adjustment_set_value adj v)))) + (define/public (set-scroll-page which v) + (dispatch which (lambda (adj) + (let ([old (gtk_adjustment_get_page_size adj)]) + (unless (= old v) + (gtk_adjustment_set_page_size adj v) + (gtk_adjustment_set_page_increment adj v) + (gtk_adjustment_set_upper adj (+ (- v old) + (gtk_adjustment_get_upper adj)))))))) + (define/public (set-scroll-range which v) + (dispatch which (lambda (adj) + (gtk_adjustment_set_upper adj (+ v (gtk_adjustment_get_page_size adj)))))) + (define/public (set-scroll-pos which v) + (dispatch which (lambda (adj) (gtk_adjustment_set_value adj v)))) - (define/public (get-scroll-page which) - (->long (dispatch which gtk_adjustment_get_page_size 0))) - (define/public (get-scroll-range which) - (->long (dispatch which (lambda (adj) - (- (gtk_adjustment_get_upper adj) - (gtk_adjustment_get_page_size adj))) - 0))) - (define/public (get-scroll-pos which) - (->long (dispatch which gtk_adjustment_get_value 0))) - - (define clear-bg? - (and (not (memq 'transparent style)) - (not (memq 'no-autoclear style)))) - (define transparent? - (memq 'transparent style)) - (define gc #f) - (define bg-col (make-object color% "white")) - (define/public (get-canvas-background) (if transparent? - #f - bg-col)) - (define/public (set-canvas-background col) (set! bg-col col)) - (define/public (get-canvas-background-for-clearing) - ;; called in event-dispatch mode - (if now-drawing? - (begin - (set! refresh-after-drawing? #t) - #f) - (if clear-bg? - (let* ([conv (lambda (x) (bitwise-ior x (arithmetic-shift x 8)))] - [w (widget-window gtk)] - [gc (gdk_gc_new w)]) - (gdk_gc_set_rgb_fg_color gc (make-GdkColor 0 - (conv (color-red bg-col)) - (conv (color-green bg-col)) - (conv (color-blue bg-col)))) - gc) - #f))) + (define/public (get-scroll-page which) + (->long (dispatch which gtk_adjustment_get_page_size 0))) + (define/public (get-scroll-range which) + (->long (dispatch which (lambda (adj) + (- (gtk_adjustment_get_upper adj) + (gtk_adjustment_get_page_size adj))) + 0))) + (define/public (get-scroll-pos which) + (->long (dispatch which gtk_adjustment_get_value 0))) + + (define clear-bg? + (and (not (memq 'transparent style)) + (not (memq 'no-autoclear style)))) + (define transparent? + (memq 'transparent style)) + (define gc #f) + (define bg-col (make-object color% "white")) + (define/public (get-canvas-background) (if transparent? + #f + bg-col)) + (define/public (set-canvas-background col) (set! bg-col col)) + (define/public (get-canvas-background-for-clearing) + ;; called in event-dispatch mode + (if clear-bg? + (let* ([conv (lambda (x) (bitwise-ior x (arithmetic-shift x 8)))] + [w (widget-window gtk)] + [gc (gdk_gc_new w)]) + (gdk_gc_set_rgb_fg_color gc (make-GdkColor 0 + (conv (color-red bg-col)) + (conv (color-green bg-col)) + (conv (color-blue bg-col)))) + gc) + #f)) - (when is-combo? - (connect-changed client-gtk)) + (when is-combo? + (connect-changed client-gtk)) - (define/public (append-combo-item str) - (gtk_combo_box_append_text gtk str)) + (define/public (append-combo-item str) + (gtk_combo_box_append_text gtk str)) - (define/public (combo-maybe-clicked) - (let ([i (gtk_combo_box_get_active gtk)]) - (when (i . > . -1) - (gtk_combo_box_set_active gtk -1) - (queue-window-event this (lambda () (on-combo-select i)))))) - (define/public (on-combo-select i) (void)) + (define/public (combo-maybe-clicked) + (let ([i (gtk_combo_box_get_active gtk)]) + (when (i . > . -1) + (gtk_combo_box_set_active gtk -1) + (queue-window-event this (lambda () (on-combo-select i)))))) + (define/public (on-combo-select i) (void)) - (define/public (set-combo-text t) (void)) + (define/public (set-combo-text t) (void)) - (def/public-unimplemented set-background-to-gray) + (def/public-unimplemented set-background-to-gray) - (define/public (do-scroll direction) - (if auto-scroll? - (refresh-for-autoscroll) - (on-scroll (new scroll-event% - [event-type 'thumb] - [direction direction] - [position (get-scroll-pos direction)])))) - (define/public (on-scroll e) (void)) + (define/public (do-scroll direction) + (if auto-scroll? + (refresh-for-autoscroll) + (on-scroll (new scroll-event% + [event-type 'thumb] + [direction direction] + [position (get-scroll-pos direction)])))) + (define/public (on-scroll e) (void)) - (define/public (scroll x y) - (when hscroll-adj (gtk_adjustment_set_value hscroll-adj x)) - (when vscroll-adj (gtk_adjustment_set_value vscroll-adj y)) - (when auto-scroll? (refresh-for-autoscroll))) + (define/public (scroll x y) + (when hscroll-adj (gtk_adjustment_set_value hscroll-adj x)) + (when vscroll-adj (gtk_adjustment_set_value vscroll-adj y)) + (when auto-scroll? (refresh-for-autoscroll))) - (def/public-unimplemented warp-pointer) + (def/public-unimplemented warp-pointer) - (define/public (view-start xb yb) - (if auto-scroll? - (begin - (set-box! xb (if virtual-width - (gtk_adjustment_get_value hscroll-adj) - 0)) - (set-box! yb (if virtual-height - (gtk_adjustment_get_value vscroll-adj) - 0))) - (begin - (set-box! xb 0) - (set-box! yb 0)))) + (define/public (view-start xb yb) + (if auto-scroll? + (begin + (set-box! xb (if virtual-width + (gtk_adjustment_get_value hscroll-adj) + 0)) + (set-box! yb (if virtual-height + (gtk_adjustment_get_value vscroll-adj) + 0))) + (begin + (set-box! xb 0) + (set-box! yb 0)))) - (define/public (set-resize-corner on?) (void)) - - (define/public (get-virtual-size xb yb) - (get-client-size xb yb) - (when virtual-width (set-box! xb virtual-width)) - (when virtual-height (set-box! yb virtual-height))) + (define/public (set-resize-corner on?) (void)) + + (define/public (get-virtual-size xb yb) + (get-client-size xb yb) + (when virtual-width (set-box! xb virtual-width)) + (when virtual-height (set-box! yb virtual-height))) - (define reg-blits null) - - (define/private (register-one-blit x y w h on-pixbuf off-pixbuf) - (let* ([cwin (widget-window client-gtk)]) - (atomically - (let ([win (create-gc-window cwin x y w h)]) - (let ([r (scheme_add_gc_callback - (make-gc-show-desc win on-pixbuf w h) - (make-gc-hide-desc win off-pixbuf w h))]) - (cons win r)))))) - - (define/public (register-collecting-blit x y w h on off on-x on-y off-x off-y) - (let ([fix-size (lambda (on on-x on-y) - (if (and (zero? on-x) - (zero? on-y) - (= (send on get-width) w) - (= (send on get-height) h)) - on - (let ([bm (make-object bitmap% w h)]) - (let ([dc (make-object bitmap-dc% on)]) - (send dc draw-bitmap-section on 0 0 on-x on-y w h) - (send dc set-bitmap #f) - bm))))]) - (let ([on (fix-size on on-x on-y)] - [off (fix-size off off-x off-y)]) - (let ([on-pixbuf (bitmap->pixbuf on)] - [off-pixbuf (bitmap->pixbuf off)]) - (atomically - (set! reg-blits (cons (register-one-blit x y w h on-pixbuf off-pixbuf) reg-blits))))))) - - (define/public (unregister-collecting-blits) - (atomically - (for ([r (in-list reg-blits)]) - (g_object_unref (car r)) - (scheme_remove_gc_callback (cdr r))) - (set! reg-blits null))))) + (define reg-blits null) + + (define/private (register-one-blit x y w h on-pixbuf off-pixbuf) + (let* ([cwin (widget-window client-gtk)]) + (atomically + (let ([win (create-gc-window cwin x y w h)]) + (let ([r (scheme_add_gc_callback + (make-gc-show-desc win on-pixbuf w h) + (make-gc-hide-desc win off-pixbuf w h))]) + (cons win r)))))) + + (define/public (register-collecting-blit x y w h on off on-x on-y off-x off-y) + (let ([fix-size (lambda (on on-x on-y) + (if (and (zero? on-x) + (zero? on-y) + (= (send on get-width) w) + (= (send on get-height) h)) + on + (let ([bm (make-object bitmap% w h)]) + (let ([dc (make-object bitmap-dc% on)]) + (send dc draw-bitmap-section on 0 0 on-x on-y w h) + (send dc set-bitmap #f) + bm))))]) + (let ([on (fix-size on on-x on-y)] + [off (fix-size off off-x off-y)]) + (let ([on-pixbuf (bitmap->pixbuf on)] + [off-pixbuf (bitmap->pixbuf off)]) + (atomically + (set! reg-blits (cons (register-one-blit x y w h on-pixbuf off-pixbuf) reg-blits))))))) + + (define/public (unregister-collecting-blits) + (atomically + (for ([r (in-list reg-blits)]) + (g_object_unref (car r)) + (scheme_remove_gc_callback (cdr r))) + (set! reg-blits null)))))) diff --git a/collects/mred/private/wx/gtk/frame.rkt b/collects/mred/private/wx/gtk/frame.rkt index c872fcb92e..2a0bc0ba9f 100644 --- a/collects/mred/private/wx/gtk/frame.rkt +++ b/collects/mred/private/wx/gtk/frame.rkt @@ -237,14 +237,24 @@ (gtk_window_resize gtk (max 1 w) (max 1 h))) (define/override (show on?) - (when (and on? - (eventspace-shutdown? (get-eventspace))) - (error (string->symbol - (format "show method in ~a" - (if (frame-relative-dialog-status this) - 'dialog% - 'frame%))) - "eventspace has been shutdown")) + (let ([es (get-eventspace)]) + (when (and on? + (eventspace-shutdown? es)) + (error (string->symbol + (format "show method in ~a" + (if (frame-relative-dialog-status this) + 'dialog% + 'frame%))) + "eventspace has been shutdown") + (when saved-child + (if (eq? (current-thread) (eventspace-handler-thread es)) + (send saved-child paint-children) + (let ([s (make-semaphore)]) + (queue-callback (lambda () + (when saved-child + (send saved-child paint-children)) + (semaphore-post s))) + (sync/timeout 1 s)))))) (super show on?)) (define saved-child #f) diff --git a/collects/mred/private/wx/gtk/panel.rkt b/collects/mred/private/wx/gtk/panel.rkt index 767db96217..4947b465f6 100644 --- a/collects/mred/private/wx/gtk/panel.rkt +++ b/collects/mred/private/wx/gtk/panel.rkt @@ -32,6 +32,11 @@ (for ([child (in-list children)]) (send child reset-child-dcs)))) + (define/override (paint-children) + (when (pair? children) + (for ([child (in-list children)]) + (send child paint-children)))) + (define/override (set-size x y w h) (super set-size x y w h) (reset-child-dcs)) diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt index ef295165c5..7a36b67b65 100644 --- a/collects/mred/private/wx/gtk/window.rkt +++ b/collects/mred/private/wx/gtk/window.rkt @@ -568,6 +568,9 @@ (when parent (send parent register-child this on?))) + (define/public (paint-children) + (void)) + (def/public-unimplemented on-drop-file) (def/public-unimplemented get-handle) (def/public-unimplemented set-phantom-size) @@ -625,12 +628,16 @@ (do-request-flush-delay gtk (lambda (gtk) - (gdk_window_freeze_updates (widget-window gtk))) + (let ([win (widget-window gtk)]) + (and win + (gdk_window_freeze_updates win) + #t))) (lambda (gtk) (gdk_window_thaw_updates (widget-window gtk))))) (define (cancel-flush-delay req) - (do-cancel-flush-delay - req - (lambda (gtk) - (gdk_window_thaw_updates (widget-window gtk))))) + (when req + (do-cancel-flush-delay + req + (lambda (gtk) + (gdk_window_thaw_updates (widget-window gtk))))))