From 461af202c5cfa17351ff3758ab29f9eda61cf38d Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 13 Aug 2011 06:25:07 -0600 Subject: [PATCH] implement 'border style for `panel%' --- collects/mred/private/wx/cocoa/canvas.rkt | 12 ----- collects/mred/private/wx/cocoa/panel.rkt | 58 +++++++++++++++++++++-- collects/mred/private/wx/gtk/canvas.rkt | 25 ---------- collects/mred/private/wx/gtk/dc.rkt | 14 +++++- collects/mred/private/wx/gtk/panel.rkt | 46 +++++++++++++++--- collects/mred/private/wx/gtk/window.rkt | 4 ++ collects/mred/private/wx/win32/panel.rkt | 11 ++--- 7 files changed, 115 insertions(+), 55 deletions(-) diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index e382b04a4d..7fe6d67ae2 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -94,18 +94,6 @@ #:mixins (MyViewMixin) [wxb]) -(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)] - [r (tell #:type _NSRect self bounds)]) - (CGContextSetRGBFillColor cg 0 0 0 1.0) - (CGContextAddRect cg r) - (CGContextStrokePath cg)) - (tellv ctx restoreGraphicsState)))) - (define-objc-class CornerlessFrameView NSView [] (-a _void (drawRect: [_NSRect r]) diff --git a/collects/mred/private/wx/cocoa/panel.rkt b/collects/mred/private/wx/cocoa/panel.rkt index a53c952d46..53d84322c6 100644 --- a/collects/mred/private/wx/cocoa/panel.rkt +++ b/collects/mred/private/wx/cocoa/panel.rkt @@ -5,18 +5,33 @@ "../../syntax.rkt" "types.rkt" "utils.rkt" + "cg.rkt" "window.rkt") (provide (protect-out panel% - panel-mixin)) + panel-mixin -(import-class NSView) + FrameView)) + +(import-class NSView NSGraphicsContext) (define-objc-class MyPanelView NSView #:mixins (KeyMouseTextResponder CursorDisplayer) [wxb]) +(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)] + [r (tell #:type _NSRect self bounds)]) + (CGContextSetRGBFillColor cg 0 0 0 1.0) + (CGContextAddRect cg r) + (CGContextStrokePath cg)) + (tellv ctx restoreGraphicsState)))) + (define (panel-mixin %) (class % (inherit register-as-child on-new-child @@ -92,14 +107,47 @@ (define/public (set-item-cursor x y) (void)))) (defclass panel% (panel-mixin window%) + (inherit get-cocoa) (init parent x y w h style label) + + (define has-border? (memq 'border style)) + (super-new [parent parent] [cocoa (as-objc-allocation - (tell (tell MyPanelView alloc) + (tell (tell (if has-border? FrameView MyPanelView) alloc) initWithFrame: #:type _NSRect (make-NSRect (make-init-point x y) - (make-NSSize (max 1 w) (max 1 h)))))] - [no-show? (memq 'deleted style)])) + (make-NSSize (max (if has-border? 3 1) w) + (max (if has-border? 3 1) h)))))] + [no-show? (memq 'deleted style)]) + + (define content-cocoa + (and has-border? + (let* ([c (get-cocoa)] + [f (tell #:type _NSRect c frame)]) + (as-objc-allocation + (tell (tell MyPanelView alloc) + initWithFrame: #:type _NSRect (make-NSRect (make-init-point 1 1) + (let ([s (NSRect-size f)]) + (make-NSSize (max 1 (- (NSSize-width s) 2)) + (max 1 (- (NSSize-height s) 2)))))))))) + (when has-border? + (let ([cocoa (get-cocoa)]) + (tell #:type _void cocoa addSubview: content-cocoa) + (set-ivar! content-cocoa wxb (->wxb this)))) + + (define/override (get-cocoa-content) + (if has-border? + content-cocoa + (super get-cocoa-content))) + + (define/override (set-size x y w h) + (super set-size x y w h) + (when has-border? + (tellv content-cocoa setFrame: #:type _NSRect (make-NSRect (make-NSPoint 1 1) + (make-NSSize (max 1 (- w 2)) (max 1 (- h 2)))))))) + + diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index 1e761486fb..0091e46230 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -100,18 +100,9 @@ (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) -(define-gdk gdk_gc_unref (_fun _pointer -> _void) - #:wrap (deallocator)) -(define-gdk gdk_gc_new (_fun _GdkWindow -> _pointer) - #:wrap (allocator gdk_gc_unref)) -(define-gdk gdk_gc_set_rgb_fg_color (_fun _pointer _GdkColor-pointer -> _void)) -(define-gdk gdk_draw_rectangle (_fun _GdkWindow _pointer _gboolean _int _int _int _int -> _void)) - (define _GtkIMContext (_cpointer 'GtkIMContext)) (define-gtk gtk_im_multicontext_new (_fun -> _GtkIMContext)) (define-gtk gtk_im_context_set_use_preedit (_fun _GtkIMContext _gboolean -> _void)) @@ -201,22 +192,6 @@ (not (send wx is-panel?))) #f)))) -(define-signal-handler connect-expose-border "expose-event" - (_fun _GtkWidget _GdkEventExpose-pointer -> _gboolean) - (lambda (gtk event) - (let* ([win (widget-window gtk)] - [gc (gdk_gc_new win)] - [gray #x8000]) - (when gc - (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-signal-handler connect-value-changed-h "value-changed" (_fun _GtkWidget -> _void) (lambda (gtk) diff --git a/collects/mred/private/wx/gtk/dc.rkt b/collects/mred/private/wx/gtk/dc.rkt index a732fa6bf9..ed42827c19 100644 --- a/collects/mred/private/wx/gtk/dc.rkt +++ b/collects/mred/private/wx/gtk/dc.rkt @@ -18,11 +18,23 @@ (provide (protect-out dc% do-backing-flush - x11-bitmap%)) + x11-bitmap% + + gdk_gc_new + gdk_gc_unref + gdk_gc_set_rgb_fg_color + gdk_draw_rectangle)) (define-gdk gdk_cairo_create (_fun _pointer -> _cairo_t) #:wrap (allocator cairo_destroy)) +(define-gdk gdk_gc_unref (_fun _pointer -> _void) + #:wrap (deallocator)) +(define-gdk gdk_gc_new (_fun _GdkWindow -> _pointer) + #:wrap (allocator gdk_gc_unref)) +(define-gdk gdk_gc_set_rgb_fg_color (_fun _pointer _GdkColor-pointer -> _void)) +(define-gdk gdk_draw_rectangle (_fun _GdkWindow _pointer _gboolean _int _int _int _int -> _void)) + (define-cstruct _GdkVisual-rec ([type-instance _pointer] [ref_count _uint] [qdata _pointer] diff --git a/collects/mred/private/wx/gtk/panel.rkt b/collects/mred/private/wx/gtk/panel.rkt index c62c2ba60b..f1aa712812 100644 --- a/collects/mred/private/wx/gtk/panel.rkt +++ b/collects/mred/private/wx/gtk/panel.rkt @@ -6,7 +6,8 @@ "window.rkt" "utils.rkt" "types.rkt" - "const.rkt") + "const.rkt" + "dc.rkt") (provide (protect-out panel% @@ -14,13 +15,35 @@ panel-container-mixin gtk_fixed_new - gtk_fixed_move)) + gtk_fixed_move + + gtk_container_set_border_width + connect-expose-border)) (define-gtk gtk_fixed_new (_fun -> _GtkWidget)) (define-gtk gtk_event_box_new (_fun -> _GtkWidget)) (define-gtk gtk_fixed_move (_fun _GtkWidget _GtkWidget _int _int -> _void)) +(define-gtk gtk_container_set_border_width (_fun _GtkWidget _int -> _void)) + +(define-signal-handler connect-expose-border "expose-event" + (_fun _GtkWidget _GdkEventExpose-pointer -> _gboolean) + (lambda (gtk event) + (let* ([win (widget-window gtk)] + [gc (gdk_gc_new win)] + [gray #x8000]) + (when gc + (gdk_gc_set_rgb_fg_color gc (make-GdkColor 0 gray gray gray)) + (let ([a (widget-allocation gtk)]) + (gdk_draw_rectangle win gc #f + 0 + 0 + (sub1 (GtkAllocation-width a)) + (sub1 (GtkAllocation-height a)))) + (gdk_gc_unref gc))) + #f)) + (define (panel-mixin %) (class % @@ -81,15 +104,24 @@ style label) - (inherit get-gtk set-auto-size set-size) + (inherit get-gtk set-auto-size set-size + adjust-client-delta) (define gtk (as-gtk-allocation (gtk_event_box_new))) + (define border-gtk (atomically + (and (memq 'border style) + (let ([border-gtk (gtk_fixed_new)]) + (gtk_container_add gtk border-gtk) + (gtk_container_set_border_width border-gtk 1) + (connect-expose-border border-gtk) + (gtk_widget_show border-gtk) + border-gtk)))) (define client-gtk (atomically (let ([client (gtk_fixed_new)]) - (gtk_container_add gtk client) + (gtk_container_add (or border-gtk gtk) client) (gtk_widget_show client) client))) - + (define/override (get-client-gtk) client-gtk) (super-new [parent parent] @@ -98,7 +130,9 @@ [no-show? (memq 'deleted style)]) ;; Start with a minimum size: - (set-size 0 0 1 1) + (set-size 0 0 (if border-gtk 3 1) (if border-gtk 3 1)) + (when border-gtk + (adjust-client-delta 2 2)) (connect-key-and-mouse gtk) (gtk_widget_add_events gtk (bitwise-ior GDK_BUTTON_PRESS_MASK diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt index babc98f286..9bbca2874f 100644 --- a/collects/mred/private/wx/gtk/window.rkt +++ b/collects/mred/private/wx/gtk/window.rkt @@ -41,6 +41,7 @@ (struct-out GtkAllocation) _GtkAllocation-pointer widget-window + widget-allocation the-accelerator-group gtk_window_add_accel_group @@ -104,6 +105,9 @@ (define (widget-window gtk) (GtkWidgetT-window (cast gtk _GtkWidget _GtkWidgetT-pointer))) +(define (widget-allocation gtk) + (GtkWidgetT-alloc (cast gtk _GtkWidget _GtkWidgetT-pointer))) + (define-gtk gtk_drag_dest_add_uri_targets (_fun _GtkWidget -> _void)) (define-gtk gtk_drag_dest_set (_fun _GtkWidget _int (_pointer = #f) (_int = 0) _int -> _void)) (define-gtk gtk_drag_dest_unset (_fun _GtkWidget -> _void)) diff --git a/collects/mred/private/wx/win32/panel.rkt b/collects/mred/private/wx/win32/panel.rkt index bda8be80aa..6d10c5cc71 100644 --- a/collects/mred/private/wx/win32/panel.rkt +++ b/collects/mred/private/wx/win32/panel.rkt @@ -94,8 +94,6 @@ (define/public (set-item-cursor x y) (void)))) -(define WS_EX_STATICEDGE #x00020000) - (define panel% (class (panel-mixin window%) (init parent @@ -105,14 +103,15 @@ (super-new [parent parent] [hwnd - (CreateWindowExW (if (memq 'border style) - WS_EX_STATICEDGE - 0) + (CreateWindowExW 0 (if (send parent is-frame?) "PLTPanel" "PLTTabPanel") #f - (bitwise-ior WS_CHILD WS_CLIPSIBLINGS) + (bitwise-ior WS_CHILD WS_CLIPSIBLINGS + (if (memq 'border style) + WS_BORDER + 0)) 0 0 w h (send parent get-content-hwnd) #f