repairs that make dragable panels work

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))
 

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 %)

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)]

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]

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))

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))))