From e153b71ba0759383b26a1f128ca42e40959cf794 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 4 Sep 2010 08:12:25 -0600 Subject: [PATCH] repairs that make dragable panels work --- collects/mred/private/wx/cocoa/cursor.rkt | 14 ++++++++++ collects/mred/private/wx/cocoa/panel.rkt | 2 +- collects/mred/private/wx/common/cursor.rkt | 9 +++++++ collects/mred/private/wx/common/event.rkt | 3 +-- collects/mred/private/wx/gtk/cursor.rkt | 14 ++++++++++ collects/mred/private/wx/gtk/panel.rkt | 31 ++++++++++++++++------ 6 files changed, 62 insertions(+), 11 deletions(-) diff --git a/collects/mred/private/wx/cocoa/cursor.rkt b/collects/mred/private/wx/cocoa/cursor.rkt index 7466b99554..28fc4e5d24 100644 --- a/collects/mred/private/wx/cocoa/cursor.rkt +++ b/collects/mred/private/wx/cocoa/cursor.rkt @@ -2,8 +2,10 @@ (require ffi/unsafe ffi/unsafe/objc racket/class + racket/draw "image.rkt" "types.rkt" + "utils.rkt" "../common/cursor-draw.rkt" "../common/local.rkt") @@ -64,6 +66,18 @@ (set! handle (image-cursor bullseye draw-bullseye))] [(blank) (set! handle (image-cursor blank void))])) + + (define/public (set-image image mask hot-spot-x hot-spot-y) + (let ([bm (make-object bitmap% 16 16 #f #t)]) + (let ([dc (make-object bitmap-dc% bm)]) + (send dc draw-bitmap image 0 0 'solid (send the-color-database find-color "black") mask) + (send dc set-bitmap #f)) + (let ([image (bitmap->image bm)]) + (set! handle + (as-objc-allocation + (tell (tell NSCursor alloc) + initWithImage: image + hotSpot: #:type _NSPoint (make-NSPoint hot-spot-x hot-spot-y))))))) (define/public (ok?) (and handle #t)) diff --git a/collects/mred/private/wx/cocoa/panel.rkt b/collects/mred/private/wx/cocoa/panel.rkt index ec461c46e9..1ef4c77eae 100644 --- a/collects/mred/private/wx/cocoa/panel.rkt +++ b/collects/mred/private/wx/cocoa/panel.rkt @@ -15,7 +15,7 @@ (import-class NSView) (define-objc-class MyPanelView NSView - #:mixins (CursorDisplayer) + #:mixins (KeyMouseTextResponder CursorDisplayer) [wxb]) (define (panel-mixin %) diff --git a/collects/mred/private/wx/common/cursor.rkt b/collects/mred/private/wx/common/cursor.rkt index fb879edfb3..f8aa09acdc 100644 --- a/collects/mred/private/wx/common/cursor.rkt +++ b/collects/mred/private/wx/common/cursor.rkt @@ -9,6 +9,11 @@ (define standards (make-hash)) +(define (is-16x16? image) + (and (not (send image is-color?)) + (= 16 (send image get-width)) + (= 16 (send image get-height)))) + (defclass cursor% object% (init-rest args) @@ -28,6 +33,10 @@ [bitmap% mask] [(integer-in 0 15) [hot-spot-x 0]] [(integer-in 0 15) [hot-spot-y 0]]) + (unless (is-16x16? image) + (raise-type-error (init-name 'cursor%) '|bitmap (16x16 monochrome)| image)) + (unless (is-16x16? mask) + (raise-type-error (init-name 'cursor%) '|bitmap (16x16 monochrome)| mask)) (let ([c (new cursor-driver%)]) (send c set-image image mask hot-spot-x hot-spot-y) c)] diff --git a/collects/mred/private/wx/common/event.rkt b/collects/mred/private/wx/common/event.rkt index acfcf08544..1c757d796b 100644 --- a/collects/mred/private/wx/common/event.rkt +++ b/collects/mred/private/wx/common/event.rkt @@ -67,8 +67,7 @@ (eq? et 'leave)) (def/public (moving?) - (and (eq? et 'motion) - (not (or left-down middle-down right-down))))) + (eq? et 'motion))) (defclass key-event% event% (init-properties [[(make-alts symbol? char?) key-code] #\nul] diff --git a/collects/mred/private/wx/gtk/cursor.rkt b/collects/mred/private/wx/gtk/cursor.rkt index c17c8170e1..fb6d742077 100644 --- a/collects/mred/private/wx/gtk/cursor.rkt +++ b/collects/mred/private/wx/gtk/cursor.rkt @@ -1,6 +1,7 @@ #lang racket/base (require ffi/unsafe racket/class + racket/draw "utils.rkt" "types.rkt" "pixbuf.rkt" @@ -76,6 +77,19 @@ (set! handle c)))] [else (set! handle v)]))) + (define/public (set-image image mask hot-spot-x hot-spot-y) + (let ([bm (make-object bitmap% 16 16 #f #t)]) + (let ([dc (make-object bitmap-dc% bm)]) + (send dc draw-bitmap image 0 0 'solid (send the-color-database find-color "black") mask) + (send dc set-bitmap #f)) + (let ([pixbuf (bitmap->pixbuf bm)]) + (set! handle + (gdk_cursor_new_from_pixbuf + (gdk_display_get_default) + pixbuf + hot-spot-x + hot-spot-y))))) + (define/public (get-handle) handle) (super-new)) diff --git a/collects/mred/private/wx/gtk/panel.rkt b/collects/mred/private/wx/gtk/panel.rkt index 52f75d8912..767db96217 100644 --- a/collects/mred/private/wx/gtk/panel.rkt +++ b/collects/mred/private/wx/gtk/panel.rkt @@ -1,17 +1,18 @@ #lang scheme/base (require scheme/class - scheme/foreign + ffi/unsafe "../../syntax.rkt" + "../../lock.rkt" "window.rkt" "utils.rkt" - "types.rkt") -(unsafe!) + "types.rkt" + "const.rkt") (provide panel% panel-mixin) -; (define-gtk gtk_alignment_new (_fun _gfloat _gfloat _gfloat _gfloat -> _GtkWidget)) (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)) @@ -56,14 +57,28 @@ (inherit set-size get-gtk) + (define gtk (as-gtk-allocation (gtk_event_box_new))) + (define client-gtk (atomically + (let ([client (gtk_fixed_new)]) + (gtk_container_add gtk client) + (gtk_widget_show client) + client))) + + (define/override (get-client-gtk) client-gtk) + (super-new [parent parent] - [gtk (as-gtk-allocation (gtk_fixed_new))] + [gtk gtk] + [extra-gtks (list client-gtk)] [no-show? (memq 'deleted style)]) - (define gtk (get-gtk)) - (connect-key-and-mouse gtk) + (gtk_widget_add_events gtk (bitwise-ior GDK_BUTTON_PRESS_MASK + GDK_BUTTON_RELEASE_MASK + GDK_POINTER_MOTION_MASK + GDK_FOCUS_CHANGE_MASK + GDK_ENTER_NOTIFY_MASK + GDK_LEAVE_NOTIFY_MASK)) (define/override (set-child-size child-gtk x y w h) - (gtk_fixed_move gtk child-gtk x y) + (gtk_fixed_move client-gtk child-gtk x y) (gtk_widget_set_size_request child-gtk w h))))