collecting blit for gtk

original commit: a2f02f6f39ae7cb5158d8e6ba88083dc23225665

collects/mred/private/wx/gtk/canvas.rkt

@@ -16,7 +16,9 @@
          "client-window.rkt"
          "widget.rkt"
          "dc.rkt"
-         "combo.rkt")
+         "combo.rkt"
+         "pixbuf.rkt"
+         "gcwin.rkt")
 
 (provide canvas%)
 
@@ -588,5 +590,37 @@
     (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)))))
+      (when virtual-height (set-box! yb virtual-height)))
 
+    (define reg-blits null)
+    
+    (define/private (register-one-blit x y w h pixbuf)
+      (let* ([cwin (widget-window client-gtk)])
+        (atomically
+         (let ([win (create-gc-window cwin x y w h pixbuf)])
+           (let ([r (scheme_add_gc_callback
+                     (make-gc-show-desc win pixbuf w h)
+                     (make-gc-hide-desc win))])
+             (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 ([pixbuf (bitmap->pixbuf on)])
+          (atomically
+           (set! reg-blits (cons (register-one-blit x y w h 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)))))

collects/mred/private/wx/gtk/gcwin.rkt

@@ -0,0 +1,83 @@
+#lang racket/base
+(require ffi/unsafe
+         "utils.rkt"
+         "types.rkt"
+         "window.rkt")
+
+(provide scheme_add_gc_callback
+         scheme_remove_gc_callback
+         create-gc-window
+         make-gc-show-desc
+         make-gc-hide-desc)
+
+(define-cstruct _GdkWindowAttr
+  ([title _string]
+   [event_mask _int]
+   [x _int]
+   [y _int]
+   [width _int]
+   [height _int]
+   [wclass _int] ; GDK_INPUT_OUTPUT
+   [visual _pointer]
+   [colormap _pointer]
+   [window_type _int] ; GDK_WINDOW_CHILD
+   [cursor _pointer]
+   [wmclass_name _string]
+   [wmclass_class _string]
+   [override_redirect _gboolean]
+   [type_hint _int]))
+
+(define << arithmetic-shift)
+
+(define GDK_WA_TITLE (1 . << . 1))
+(define GDK_WA_X (1 . << . 2))
+(define GDK_WA_Y (1 . << . 3))
+(define GDK_WA_CURSOR (1 . << . 4))
+(define GDK_WA_COLORMAP (1 . << . 5))
+(define GDK_WA_VISUAL (1 . << . 6))
+(define GDK_WA_WMCLASS (1 . << . 7))
+(define GDK_WA_NOREDIR (1 . << . 8))
+(define GDK_WA_TYPE_HINT (1 . << . 9))
+
+(define GDK_INPUT_OUTPUT 0)
+
+(define GDK_WINDOW_CHILD 2)
+
+(define-gdk gdk_window_new (_fun _GdkWindow _GdkWindowAttr-pointer _uint
+                                 -> _GdkWindow))
+
+(define-gdk gdk_window_show _fpointer)
+(define-gdk gdk_window_hide _fpointer)
+(define-gdk gdk_display_flush _fpointer)
+(define-gdk gdk_draw_pixbuf _fpointer)
+
+(define-mz scheme_add_gc_callback (_fun _racket _racket -> _racket))
+(define-mz scheme_remove_gc_callback (_fun _racket -> _void))
+
+(define (create-gc-window cwin x y w h pixbuf)
+  (let ([win (gdk_window_new cwin (make-GdkWindowAttr
+                                   ""
+                                   0
+                                   x y w h
+                                   GDK_INPUT_OUTPUT
+                                   #f #f 
+                                   GDK_WINDOW_CHILD
+                                   #f
+                                   "" "" #f 0)
+                             (bitwise-ior GDK_WA_X
+                                          GDK_WA_Y))])
+    win))
+
+(define (make-gc-show-desc win pixbuf w h)
+  (vector
+   (vector 'ptr_ptr_ptr->void gdk_window_show win #f #f)
+   (vector 'ptr_ptr_ptr_int_int_int_int_int_int_int_int_int->void
+           gdk_draw_pixbuf
+           win #f pixbuf
+           0 0 0 0 w h
+           0 0 0)
+   (vector 'ptr_ptr_ptr->void gdk_display_flush (gdk_display_get_default) #f #f)))
+
+(define (make-gc-hide-desc win)
+  (vector
+   (vector 'ptr_ptr_ptr->void gdk_window_hide win #f #f)))

collects/mred/private/wx/gtk/procs.rkt

@@ -70,8 +70,10 @@
 (define-unimplemented play-sound)
 (define-unimplemented check-for-break)
 (define-unimplemented find-graphical-system-path)
-(define (register-collecting-blit . args) (void))
-(define (unregister-collecting-blit . args) (void))
+(define (register-collecting-blit canvas x y w h on off on-x on-y off-x off-y)
+  (send canvas register-collecting-blit x y w h on off on-x on-y off-x off-y))
+(define (unregister-collecting-blit canvas)
+  (send canvas unregister-collecting-blits))
 (define (shortcut-visible-in-label? [mbar? #f]) #t)
 (define-unimplemented in-atomic-region)
 (define (set-menu-tester proc) (void))