From 10762db8c3a892f054dfb54a636afbcb6c569a15 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 12 Sep 2010 19:57:42 -0600 Subject: [PATCH] collecting blit for gtk original commit: a2f02f6f39ae7cb5158d8e6ba88083dc23225665 --- collects/mred/private/wx/gtk/canvas.rkt | 38 ++++++++++- collects/mred/private/wx/gtk/gcwin.rkt | 83 +++++++++++++++++++++++++ collects/mred/private/wx/gtk/procs.rkt | 6 +- 3 files changed, 123 insertions(+), 4 deletions(-) create mode 100644 collects/mred/private/wx/gtk/gcwin.rkt diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index f0d39bb0..52af2441 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/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))))) diff --git a/collects/mred/private/wx/gtk/gcwin.rkt b/collects/mred/private/wx/gtk/gcwin.rkt new file mode 100644 index 00000000..94ee1b26 --- /dev/null +++ b/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))) diff --git a/collects/mred/private/wx/gtk/procs.rkt b/collects/mred/private/wx/gtk/procs.rkt index 67e44296..96162e9d 100644 --- a/collects/mred/private/wx/gtk/procs.rkt +++ b/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))