From 44a8d8ce2bfb47602cda2c9e8574517cfec7e981 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 2 Aug 2010 18:52:16 -0600 Subject: [PATCH] canvas scrollbars and borders original commit: 6cb07301c1747c12232f6563f13cd4ae0541ebda --- collects/mred/private/wx/cocoa/canvas.rkt | 162 +++++++++++++++------ collects/mred/private/wx/cocoa/window.rkt | 18 ++- collects/mred/private/wx/common/cursor.rkt | 3 +- collects/mred/private/wx/common/freeze.rkt | 12 +- collects/mred/private/wx/gtk/canvas.rkt | 78 ++++++++-- collects/mred/private/wx/gtk/types.rkt | 19 ++- collects/mred/private/wx/gtk/utils.rkt | 4 +- 7 files changed, 219 insertions(+), 77 deletions(-) diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index 072401c9..8bc23e58 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -30,23 +30,24 @@ #:mixins (FocusResponder KeyMouseResponder) [wx] (-a _void (drawRect: [_NSRect r]) - (let ([bg (send wx get-canvas-background-for-clearing)]) - (when bg - (let ([ctx (tell NSGraphicsContext currentContext)]) - (tellv ctx saveGraphicsState) - (let ([cg (tell #:type _CGContextRef ctx graphicsPort)] - [adj (lambda (v) (/ v 255.0))]) - (CGContextSetRGBFillColor cg - (adj (color-red bg)) - (adj (color-blue bg)) - (adj (color-green bg)) - 1.0) - (CGContextFillRect cg (make-NSRect (make-NSPoint 0 0) - (make-NSSize 32000 32000)))) - (tellv ctx restoreGraphicsState)))) - (send wx queue-paint) - ;; ensure that `nextEventMatchingMask:' returns - (post-dummy-event)) + (unless (send wx reject-partial-update r) + (let ([bg (send wx get-canvas-background-for-clearing)]) + (when bg + (let ([ctx (tell NSGraphicsContext currentContext)]) + (tellv ctx saveGraphicsState) + (let ([cg (tell #:type _CGContextRef ctx graphicsPort)] + [adj (lambda (v) (/ v 255.0))]) + (CGContextSetRGBFillColor cg + (adj (color-red bg)) + (adj (color-blue bg)) + (adj (color-green bg)) + 1.0) + (CGContextFillRect cg (make-NSRect (make-NSPoint 0 0) + (make-NSSize 32000 32000)))) + (tellv ctx restoreGraphicsState)))) + (send wx queue-paint) + ;; ensure that `nextEventMatchingMask:' returns + (post-dummy-event))) (-a _void (viewWillMoveToWindow: [_id w]) (when wx (queue-window-event wx (lambda () (send wx fix-dc))))) @@ -55,6 +56,37 @@ (-a _void (onVScroll: [_id scroller]) (when wx (send wx do-scroll 'vertical scroller)))) +(define-objc-class FrameView NSView + [] + (-a _void (drawRect: [_NSRect r]) + (let ([ctx (tell NSGraphicsContext currentContext)]) + (tellv ctx saveGraphicsState) + (let ([cg (tell #:type _CGContextRef ctx graphicsPort)]) + (CGContextSetRGBFillColor cg 0 0 0 1.0) + (CGContextFillRect cg r)) + (tellv ctx restoreGraphicsState)))) + +(define-cocoa NSSetFocusRingStyle (_fun _int -> _void)) +(define-cocoa NSRectFill (_fun _NSRect -> _void)) + +(define-objc-class FocusView NSView + [on?] + (-a _void (setFocusState: [_BOOL is-on?]) + (set! on? is-on?)) + (-a _void (drawRect: [_NSRect r]) + (when on? + (let ([ctx (tell NSGraphicsContext currentContext)]) + (tellv ctx saveGraphicsState) + (NSSetFocusRingStyle 0) + (let ([r (tell #:type _NSRect self bounds)]) + (NSRectFill (make-NSRect (make-NSPoint + (+ (NSPoint-x (NSRect-origin r)) 2) + (+ (NSPoint-y (NSRect-origin r)) 2)) + (make-NSSize + (- (NSSize-width (NSRect-size r)) 4) + (- (NSSize-height (NSRect-size r)) 4))))) + (tellv ctx restoreGraphicsState))))) + (define-objc-class MyComboBox NSComboBox #:mixins (FocusResponder KeyMouseResponder) #:protocols (NSComboBoxDelegate) @@ -104,15 +136,27 @@ is-shown-to-root? move get-x get-y on-size - register-as-child) + register-as-child + get-size get-position) (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-values (x-margin y-margin) + (cond + [(memq 'control-border style) (values 3 3)] + [(memq 'border style) (values 1 1)] + [else (values 0 0)])) + (define canvas-style style) + (define/override (focus-is-on on?) + (when (memq 'control-border canvas-style) + (tellv cocoa setFocusState: #:type _BOOL on?) + (tellv cocoa setNeedsDisplay: #:type _BOOL #t))) + (define is-visible? #f) ;; Avoid multiple queued paints: @@ -148,16 +192,22 @@ [parent parent] [cocoa (as-objc-allocation - (tell (tell NSView alloc) + (tell (tell (cond + [(memq 'control-border style) FocusView] + [(memq 'border style) FrameView] + [else NSView]) + alloc) initWithFrame: #:type _NSRect (make-NSRect (make-NSPoint x y) - (make-NSSize w h))))] + (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 w h))]) + (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)))) @@ -213,30 +263,33 @@ (when tr (tellv content-cocoa removeTrackingRect: #:type _NSInteger tr) (set! tr #f)) - (let ([sz (make-NSSize (- w (if vscroll? scroll-width 0)) - (- h (if hscroll? scroll-width 0)))] - [pos (make-NSPoint 0 (if hscroll? scroll-width 0))]) + (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 0 0) sz) + 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) - (if hscroll? - scroll-width - 0)) + (make-NSPoint (- w scroll-width x-margin) + (+ (if hscroll? + scroll-width + 0) + y-margin)) (make-NSSize scroll-width - (- h (if hscroll? scroll-width 0)))))) + (max 0 (- h (if hscroll? scroll-width 0) + x-margin x-margin)))))) (when h-scroller (tellv (scroller-cocoa h-scroller) setFrame: #:type _NSRect (make-NSRect - (make-NSPoint 0 0) - (make-NSSize (- w (if vscroll? scroll-width 0)) + (make-NSPoint x-margin y-margin) + (make-NSSize (max 0 (- w (if vscroll? scroll-width 0) + x-margin x-margin)) scroll-width)))) (fix-dc) (on-size 0 0)) @@ -262,11 +315,10 @@ [(and vscroll? (not v?)) (tell #:type _void (scroller-cocoa v-scroller) removeFromSuperview)]) (set! vscroll? v?) - (let ([r (tell #:type _NSRect cocoa frame)]) - (do-set-size (NSPoint-x (NSRect-origin r)) - (NSPoint-y (NSRect-origin r)) - (NSSize-width (NSRect-size r)) - (NSSize-height (NSRect-size r))))))) + (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 @@ -309,12 +361,14 @@ (as-objc-allocation (tell (tell NSScroller alloc) initWithFrame: #:type _NSRect (make-NSRect - (make-NSPoint (- w scroll-width) - (if hscroll? - scroll-width - 0)) + (make-NSPoint (- w scroll-width x-margin) + (+ (if hscroll? + scroll-width + 0) + y-margin)) (make-NSSize scroll-width - (max (- h (if hscroll? scroll-width 0)) + (max (- h (if hscroll? scroll-width 0) + y-margin y-margin) (+ scroll-width 10)))))) 1 1))) @@ -324,8 +378,9 @@ (as-objc-allocation (tell (tell NSScroller alloc) initWithFrame: #:type _NSRect (make-NSRect - (make-NSPoint 0 0) - (make-NSSize (max (- w (if vscroll? scroll-width 0)) + (make-NSPoint x-margin y-margin) + (make-NSSize (max (- w (if vscroll? scroll-width 0) + x-margin x-margin) (+ scroll-width 10)) scroll-width)))) 1 @@ -401,6 +456,25 @@ (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)]) diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index aa967de4..7cd2f75a 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -28,14 +28,18 @@ #t] [-a _BOOL (becomeFirstResponder) (and (super-tell becomeFirstResponder) - (queue-window-event wx (lambda () - (send wx on-set-focus))) - #t)] + (begin + (send wx focus-is-on #t) + (queue-window-event wx (lambda () + (send wx on-set-focus))) + #t))] [-a _BOOL (resignFirstResponder) (and (super-tell resignFirstResponder) - (queue-window-event wx (lambda () - (send wx on-kill-focus))) - #t)]) + (begin + (send wx focus-is-on #f) + (queue-window-event wx (lambda () + (send wx on-kill-focus))) + #t))]) (define-objc-mixin (KeyMouseResponder Superclass) [wx] @@ -169,6 +173,8 @@ (unless no-show? (show #t)) + (define/public (focus-is-on on?) (void)) + (define/public (get-cocoa) cocoa) (define/public (get-cocoa-content) cocoa) (define/public (get-cocoa-window) (send parent get-cocoa-window)) diff --git a/collects/mred/private/wx/common/cursor.rkt b/collects/mred/private/wx/common/cursor.rkt index a56df307..f2767586 100644 --- a/collects/mred/private/wx/common/cursor.rkt +++ b/collects/mred/private/wx/common/cursor.rkt @@ -15,7 +15,8 @@ (case-args args [([(symbol-in arrow bullseye cross hand ibeam watch blank - size-n/s size-e/w size-ne/sw size-nw/se) + size-n/s size-e/w size-ne/sw size-nw/se + arrow+watch) sym]) (or (hash-ref standards sym #f) (let ([c (new cursor-driver%)]) diff --git a/collects/mred/private/wx/common/freeze.rkt b/collects/mred/private/wx/common/freeze.rkt index 30505b2b..d84cd487 100644 --- a/collects/mred/private/wx/common/freeze.rkt +++ b/collects/mred/private/wx/common/freeze.rkt @@ -63,10 +63,12 @@ '("\n"))))) ;; FIXME: waiting 200msec is not a good enough rule. -(define (constrained-reply es thunk default [should-give-up? - (let ([now (current-inexact-milliseconds)]) - (lambda () - ((current-inexact-milliseconds) . > . (+ now 200))))]) +(define (constrained-reply es thunk default + [should-give-up? + (let ([now (current-inexact-milliseconds)]) + (lambda () + ((current-inexact-milliseconds) . > . (+ now 200))))] + #:fail-result [fail-result default]) (let ([b (freezer-box)]) (cond [(not b) @@ -76,7 +78,7 @@ #; (internal-error (format "constrained-reply not within an unfreeze point for ~s" thunk)) - default] + fail-result] [(not (eq? (current-thread) (eventspace-handler-thread es))) (internal-error "wrong eventspace for constrained event handling\n") default] diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index d8057d83..abe343ea 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -43,6 +43,8 @@ (define-gtk gtk_container_remove (_fun _GtkWidget _GtkWidget -> _void)) (define-gtk gtk_bin_get_child (_fun _GtkWidget -> _GtkWidget)) +(define-gtk gtk_container_set_border_width (_fun _GtkWidget _int -> _void)) + (define-gobj g_object_set_bool (_fun _GtkWidget _string _gboolean [_pointer = #f] -> _void) #:c-id g_object_set) @@ -79,16 +81,32 @@ (define-gtk gtk_combo_box_set_active (_fun _GtkWidget _int -> _void)) (define-gtk gtk_combo_box_get_active (_fun _GtkWidget -> _int)) -(define (handle-expose gtk event) - (let ([wx (gtk->wx gtk)]) - (let ([gc (send wx get-canvas-background-for-clearing)]) +(define-signal-handler connect-expose "expose-event" + (_fun _GtkWidget _GdkEventExpose-pointer -> _gboolean) + (lambda (gtk event) + (let ([wx (gtk->wx gtk)]) + (let ([gc (send wx get-canvas-background-for-clearing)]) + (when gc + (gdk_draw_rectangle (g_object_get_window gtk) gc #t + 0 0 32000 32000))) + (send wx queue-paint)) + #t)) + +(define-signal-handler connect-expose-border "expose-event" + (_fun _GtkWidget _GdkEventExpose-pointer -> _gboolean) + (lambda (gtk event) + (let* ([win (g_object_get_window gtk)] + [gc (gdk_gc_new win)] + [gray #x8000]) (when gc - (gdk_draw_rectangle (g_object_get_window gtk) gc #t - 0 0 32000 32000))) - (send wx queue-paint)) - #t) -(define handle_expose - (function-ptr handle-expose (_fun #:atomic? #t _GtkWidget _GdkEventExpose -> _gboolean))) + (gdk_gc_set_rgb_fg_color gc (make-GdkColor 0 gray gray gray)) + (let ([r (GdkEventExpose-area event)]) + (gdk_draw_rectangle win gc #t + (GdkRectangle-x r) + (GdkRectangle-y r) + (GdkRectangle-width r) + (GdkRectangle-height r))) + (gdk_gc_unref gc))))) (define (handle-value-changed-h gtk ignored) (let ([wx (gtk->wx gtk)]) @@ -118,6 +136,10 @@ on-size register-as-child get-top-win) (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-values (client-gtk gtk hscroll-adj vscroll-adj hscroll-gtk vscroll-gtk resize-box) (cond @@ -133,6 +155,8 @@ [hscroll (gtk_hscrollbar_new hadj)] [vscroll (gtk_vscrollbar_new vadj)] [resize-box (gtk_drawing_area_new)]) + (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) @@ -148,11 +172,27 @@ (gtk_widget_show h2) (gtk_widget_show resize-box) (gtk_widget_show client-gtk) - (values client-gtk h hadj vadj h2 v2 resize-box)))] + (unless (memq 'hscroll style) + (gtk_widget_hide hscroll) + (gtk_widget_hide resize-box)) + (unless (memq 'vscroll style) + (gtk_widget_hide v2)) + (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))))] [is-combo? (let* ([gtk (gtk_combo_box_entry_new_text)] [orig-entry (gtk_bin_get_child gtk)]) (values orig-entry gtk #f #f #f #f #f))] + [has-border? + (let ([client-gtk (gtk_drawing_area_new)] + [h (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))] [else (let ([client-gtk (gtk_drawing_area_new)]) (values client-gtk client-gtk #f #f #f #f #f))])) @@ -192,7 +232,7 @@ (GtkRequisition-height r) (GtkRequisition-height r)))) - (g_signal_connect client-gtk "expose-event" handle_expose) + (connect-expose client-gtk) (connect-key-and-mouse client-gtk) (connect-focus client-gtk) (gtk_widget_add_events client-gtk (bitwise-ior GDK_KEY_PRESS_MASK @@ -217,10 +257,8 @@ (define/override (get-client-gtk) client-gtk) (define/override (handles-events?) #t) - ;; For the moment, the client area always starts at the - ;; control area's top left (define/override (get-client-delta) - (values 0 0)) + (values margin margin)) ;; Avoid multiple queued paints: (define paint-queued? #f) @@ -272,7 +310,14 @@ (when vscroll-gtk (if v? (gtk_widget_show vscroll-gtk) - (gtk_widget_hide 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)]))) (define/public (set-scrollbars h-step v-step h-len v-len @@ -369,4 +414,5 @@ (def/public-unimplemented view-start) (define/public (set-resize-corner on?) (void)) - (def/public-unimplemented get-virtual-size))) + (define/public (get-virtual-size xb yb) (set-box! xb 10) (set-box! yb 10)))) + diff --git a/collects/mred/private/wx/gtk/types.rkt b/collects/mred/private/wx/gtk/types.rkt index 783f3a04..6d2aa48c 100644 --- a/collects/mred/private/wx/gtk/types.rkt +++ b/collects/mred/private/wx/gtk/types.rkt @@ -5,7 +5,6 @@ (provide _GdkWindow _GtkWidget _GtkWindow _gpointer - _GdkEventExpose _GType _fnpointer @@ -21,7 +20,10 @@ _GdkEventCrossing _GdkEventCrossing-pointer (struct-out GdkEventCrossing) _GdkEventConfigure _GdkEventConfigure-pointer - (struct-out GdkEventConfigure)) + (struct-out GdkEventConfigure) + _GdkEventExpose _GdkEventExpose-pointer + (struct-out GdkEventExpose) + (struct-out GdkRectangle)) (define _GType _long) @@ -31,7 +33,6 @@ (define _GtkWindow _GtkWidget) (define _gpointer _GtkWidget) -(define _GdkEventExpose (_cpointer 'GdkEventExpose)) (define _GdkDevice (_cpointer 'GdkDevice)) @@ -99,3 +100,15 @@ [y _int] [width _int] [height _int])) + +(define-cstruct _GdkRectangle ([x _int] + [y _int] + [width _int] + [height _int])) + +(define-cstruct _GdkEventExpose ([type _GdkEventType] + [window _GdkWindow] + [send_event _byte] + [area _GdkRectangle] + [region _pointer] + [count _int])) \ No newline at end of file diff --git a/collects/mred/private/wx/gtk/utils.rkt b/collects/mred/private/wx/gtk/utils.rkt index a8e27d4a..9175c90f 100644 --- a/collects/mred/private/wx/gtk/utils.rkt +++ b/collects/mred/private/wx/gtk/utils.rkt @@ -75,8 +75,8 @@ (define-ffi-definer define-gdk gdk-lib) (define-ffi-definer define-gdk_pixbuf gdk_pixbuf-lib) -(define-gobj g_object_ref (_fun _GtkWidget -> _void)) -(define-gobj g_object_unref (_fun _GtkWidget -> _void)) +(define-gobj g_object_ref (_fun _pointer -> _void)) +(define-gobj g_object_unref (_fun _pointer -> _void)) (define-gobj g_object_set_data (_fun _GtkWidget _string _pointer -> _void)) (define-gobj g_object_get_data (_fun _GtkWidget _string -> _pointer))