From 5c533a1695a0830f927f0877361a53b324df4253 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Wed, 15 Sep 2010 14:19:35 -0600
Subject: [PATCH] add make-screen-bitmap and canvas% make-bitmap; specialize
 for X11

original commit: 51aacfe949cfd30dea4c37dc5d3c376edcb29ff7
---
 collects/mred/mred-sig.rkt                    |  1 +
 collects/mred/mred.rkt                        |  3 +-
 collects/mred/private/mrcanvas.rkt            | 15 ++++++++
 collects/mred/private/wx/cocoa/canvas.rkt     |  3 ++
 collects/mred/private/wx/cocoa/dc.rkt         | 25 ++++++------
 collects/mred/private/wx/cocoa/platform.rkt   |  3 +-
 collects/mred/private/wx/cocoa/procs.rkt      |  8 +++-
 .../mred/private/wx/common/backing-dc.rkt     | 20 +++++-----
 collects/mred/private/wx/gtk/canvas.rkt       |  9 ++++-
 collects/mred/private/wx/gtk/dc.rkt           | 38 ++++++++++++++++++-
 collects/mred/private/wx/gtk/platform.rkt     |  3 +-
 collects/mred/private/wx/gtk/procs.rkt        | 10 ++++-
 collects/mred/private/wx/gtk/x11.rkt          | 35 +++++++++++++++++
 collects/mred/private/wx/platform.rkt         |  3 +-
 collects/mred/private/wx/win32/platform.rkt   |  3 +-
 collects/mred/private/wx/win32/procs.rkt      |  5 ++-
 collects/mred/private/wxme/editor-canvas.rkt  |  2 +-
 collects/scribblings/gui/canvas-class.scrbl   | 28 ++++++++++++++
 collects/scribblings/gui/miscwin-funcs.scrbl  | 12 ++++++
 doc/release-notes/racket/Draw_and_GUI_5_5.txt | 12 ++++++
 20 files changed, 203 insertions(+), 35 deletions(-)
 create mode 100644 collects/mred/private/wx/gtk/x11.rkt

diff --git a/collects/mred/mred-sig.rkt b/collects/mred/mred-sig.rkt
index 7f41132b..72d97f8b 100644
--- a/collects/mred/mred-sig.rkt
+++ b/collects/mred/mred-sig.rkt
@@ -122,6 +122,7 @@ list-control<%>
 make-eventspace
 make-gui-empty-namespace
 make-gui-namespace
+make-screen-bitmap
 map-command-as-meta-key
 menu%
 menu-bar%
diff --git a/collects/mred/mred.rkt b/collects/mred/mred.rkt
index 2fc3ba91..65be0c5a 100644
--- a/collects/mred/mred.rkt
+++ b/collects/mred/mred.rkt
@@ -194,7 +194,8 @@
              the-pen-list
              the-brush-list
              the-style-list
-             the-editor-wordbreak-map)
+             the-editor-wordbreak-map
+             make-screen-bitmap)
    
   (define the-clipboard (wx:get-the-clipboard))
   (define the-x-selection-clipboard (wx:get-the-x-selection))
diff --git a/collects/mred/private/mrcanvas.rkt b/collects/mred/private/mrcanvas.rkt
index b99d8496..2da1e177 100644
--- a/collects/mred/private/mrcanvas.rkt
+++ b/collects/mred/private/mrcanvas.rkt
@@ -51,6 +51,21 @@
 	[warp-pointer (entry-point (lambda (x y) (send wx warp-pointer x y)))]
 
 	[get-dc (entry-point (lambda () (send wx get-dc)))]
+	[make-bitmap (lambda (w h)
+                       (unless (exact-positive-integer? w)
+                         (raise-type-error (who->name '(method canvas% make-bitmap))
+                                           "exact positive integer"
+                                           w))
+                       (unless (exact-positive-integer? h)
+                         (raise-type-error (who->name '(method canvas% make-bitmap))
+                                           "exact positive integer"
+                                           h))
+                       (send wx make-compatible-bitmap w h))]
+
+        [suspend-flush (lambda ()
+                         (send wx begin-refresh-sequence))]
+        [resume-flush (lambda ()
+                        (send wx end-refresh-sequence))]
 
 	[set-canvas-background
 	 (entry-point
diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt
index a29c47d6..1c0b2fba 100644
--- a/collects/mred/private/wx/cocoa/canvas.rkt
+++ b/collects/mred/private/wx/cocoa/canvas.rkt
@@ -319,6 +319,9 @@
     
     (define/public (get-dc) dc)
 
+    (define/public (make-compatible-bitmap w h)
+      (make-object quartz-bitmap% w h))
+
     (define/override (fix-dc [refresh? #t])
       (when (dc . is-a? . dc%)
         (send dc reset-backing-retained)
diff --git a/collects/mred/private/wx/cocoa/dc.rkt b/collects/mred/private/wx/cocoa/dc.rkt
index 00aa41d2..7621a639 100644
--- a/collects/mred/private/wx/cocoa/dc.rkt
+++ b/collects/mred/private/wx/cocoa/dc.rkt
@@ -3,6 +3,7 @@
          ffi/unsafe
          ffi/unsafe/objc
          racket/draw/cairo
+         racket/draw/bitmap
          racket/draw/local
          "types.rkt"
          "utils.rkt"
@@ -13,28 +14,26 @@
          "cg.rkt")
 
 (provide dc%
+         quartz-bitmap%
          do-backing-flush)
 
 (define quartz-bitmap%
-  (class object%
-    (init w h b&w? alpha?)
-    (super-new)
+  (class bitmap%
+    (init w h)
+    (super-make-object (make-alternate-bitmap-kind w h))
+
     (define s
       (cairo_quartz_surface_create CAIRO_FORMAT_ARGB32
                                    w
                                    h))
 
-    (define/public (ok?) #t)
-    (define/public (is-color?) #t)
+    (define/override (ok?) #t)
+    (define/override (is-color?) #t)
 
-    (define width w)
-    (define height h)
-    (define/public (get-width) width)
-    (define/public (get-height) height)
-    
-    (define/public (get-cairo-surface) s)
+    (define/override (get-cairo-surface) s)
+    (define/override (get-cairo-alpha-surface) s)
 
-    (define/public (release-bitmap-storage)
+    (define/override (release-bitmap-storage)
       (atomically
        (cairo_surface_destroy s)
        (set! s #f)))))
@@ -47,7 +46,7 @@
     (super-new)
 
     ;; Use a quartz bitmap so that text looks good:
-    (define/override (get-bitmap%) quartz-bitmap%)
+    (define/override (make-backing-bitmap w h) (make-object quartz-bitmap% w h))
     (define/override (can-combine-text? sz) #t)
 
     (define/override (get-backing-size xb yb)
diff --git a/collects/mred/private/wx/cocoa/platform.rkt b/collects/mred/private/wx/cocoa/platform.rkt
index 79f16367..1160f908 100644
--- a/collects/mred/private/wx/cocoa/platform.rkt
+++ b/collects/mred/private/wx/cocoa/platform.rkt
@@ -101,4 +101,5 @@
    special-option-key
    special-control-key
    get-highlight-background-color
-   get-highlight-text-color))
+   get-highlight-text-color
+   make-screen-bitmap))
diff --git a/collects/mred/private/wx/cocoa/procs.rkt b/collects/mred/private/wx/cocoa/procs.rkt
index 91f3f9d1..a4f6e049 100644
--- a/collects/mred/private/wx/cocoa/procs.rkt
+++ b/collects/mred/private/wx/cocoa/procs.rkt
@@ -10,6 +10,7 @@
          "window.rkt"
          "finfo.rkt" ; file-creator-and-type
          "filedialog.rkt"
+         "dc.rkt"
          "../../lock.rkt"
          "../common/handlers.rkt")
 
@@ -58,7 +59,8 @@
  show-print-setup
  can-show-print-setup?
  get-highlight-background-color
- get-highlight-text-color)
+ get-highlight-text-color
+ make-screen-bitmap)
 
 (import-class NSScreen NSCursor)
 
@@ -119,6 +121,10 @@
 (define-unimplemented show-print-setup)
 (define (can-show-print-setup?) #t)
 
+(define/top (make-screen-bitmap [exact-positive-integer? w]
+                                [exact-positive-integer? h])
+  (make-object quartz-bitmap% w h))
+
 ;; ------------------------------------------------------------
 ;; Text & highlight color
 
diff --git a/collects/mred/private/wx/common/backing-dc.rkt b/collects/mred/private/wx/common/backing-dc.rkt
index 4d5e71b2..c77f6173 100644
--- a/collects/mred/private/wx/common/backing-dc.rkt
+++ b/collects/mred/private/wx/common/backing-dc.rkt
@@ -16,7 +16,7 @@
          start-backing-retained
          end-backing-retained
          reset-backing-retained
-         get-bitmap%
+         make-backing-bitmap
          request-delay
          cancel-delay
          end-delay)
@@ -28,7 +28,7 @@
   start-backing-retained
   end-backing-retained
   reset-backing-retained
-  get-bitmap%
+  make-backing-bitmap
   request-delay
   cancel-delay
   end-delay)
@@ -95,7 +95,8 @@
              (log-error "unbalanced end-on-paint")
              (set! retained-counter (sub1 retained-counter))))))
 
-    (define/public (get-bitmap%) bitmap%)
+    (define/public (make-backing-bitmap w h)
+      (make-object bitmap% w h #f #t))
 
     (define/public (ensure-ready) (get-cr))
 
@@ -104,7 +105,7 @@
           (let ([w (box 0)]
                 [h (box 0)])
             (get-backing-size w h)
-            (let ([bm (get-backing-bitmap (get-bitmap%) (unbox w) (unbox h))])
+            (let ([bm (get-backing-bitmap (lambda (w h) (make-backing-bitmap w h)) (unbox w) (unbox h))])
               (internal-set-bitmap bm #t))
             (let ([cr (super get-cr)])
               (set! retained-cr cr)
@@ -130,9 +131,10 @@
 
     (define/override (resume-flush)  
       (atomically 
-       (set! flush-suspends (sub1 flush-suspends))
-       (when (zero? flush-suspends)
-         (queue-backing-flush))))
+       (unless (zero? flush-suspends)
+         (set! flush-suspends (sub1 flush-suspends))
+         (when (zero? flush-suspends)
+           (queue-backing-flush)))))
 
     (define/public (end-delay)
       ;; call in atomic mode
@@ -140,8 +142,8 @@
         (cancel-delay req)
         (set! req #f)))))
 
-(define (get-backing-bitmap bitmap% w h)
-  (make-object bitmap% w h #f #t))
+(define (get-backing-bitmap make-bitmap w h)
+  (make-bitmap w h))
 
 (define (release-backing-bitmap bm)
   (send bm release-bitmap-storage))
diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt
index 044f6f14..9730682d 100644
--- a/collects/mred/private/wx/gtk/canvas.rkt
+++ b/collects/mred/private/wx/gtk/canvas.rkt
@@ -328,6 +328,9 @@
 
     (define/public (get-dc) dc)
 
+    (define/public (make-compatible-bitmap w h)
+      (send dc make-backing-bitmap w h #t))
+
     (define/override (get-client-gtk) client-gtk)
     (define/override (handles-events? gtk) (not (ptr-equal? gtk combo-button-gtk)))
 
@@ -380,8 +383,10 @@
 
     (define/public (get-flush-window) client-gtk)
 
-    (define/public (begin-refresh-sequence) (void))
-    (define/public (end-refresh-sequence) (void))
+    (define/public (begin-refresh-sequence)
+      (send dc suspend-flush))
+    (define/public (end-refresh-sequence)
+      (send dc resume-flush))
 
     (define/override (refresh)
       (queue-paint))
diff --git a/collects/mred/private/wx/gtk/dc.rkt b/collects/mred/private/wx/gtk/dc.rkt
index 6907353d..98009bbf 100644
--- a/collects/mred/private/wx/gtk/dc.rkt
+++ b/collects/mred/private/wx/gtk/dc.rkt
@@ -4,19 +4,48 @@
          "utils.rkt"
          "types.rkt"
          "window.rkt"
+         "x11.rkt"
 	 "../../lock.rkt"
          "../common/backing-dc.rkt"
          racket/draw/cairo
          racket/draw/dc
+         racket/draw/bitmap
          racket/draw/local
          ffi/unsafe/alloc)
 
 (provide dc%
-         do-backing-flush)
+         do-backing-flush
+         x11-bitmap%)
 
 (define-gdk gdk_cairo_create (_fun _pointer -> _cairo_t)
   #:wrap (allocator cairo_destroy))
 
+(define x11-bitmap%
+  (class bitmap%
+    (init w h gdk-win)
+    (super-make-object (make-alternate-bitmap-kind w h))
+
+    (define pixmap (gdk_pixmap_new gdk-win w h (if gdk-win -1 24)))
+    (define s
+      (cairo_xlib_surface_create (gdk_x11_display_get_xdisplay
+                                  (gdk_drawable_get_display pixmap))
+                                 (gdk_x11_drawable_get_xid pixmap)
+                                 (gdk_x11_visual_get_xvisual
+                                  (gdk_drawable_get_visual pixmap))
+                                 w
+                                 h))
+
+    (define/override (ok?) #t)
+    (define/override (is-color?) #t)
+    
+    (define/override (get-cairo-surface) s)
+
+    (define/override (release-bitmap-storage)
+      (atomically
+       (cairo_surface_destroy s)
+       (gobject-unref pixmap)
+       (set! s #f)))))
+
 (define dc%
   (class backing-dc%
     (init [(cnvs canvas)])
@@ -24,6 +53,13 @@
 
     (super-new)
 
+    (define/override (make-backing-bitmap w h [any-bg? #f])
+      (if (and (or any-bg?
+                   (send canvas get-canvas-background))
+               (eq? 'unix (system-type)))
+          (make-object x11-bitmap% w h (widget-window (send canvas get-client-gtk)))
+          (super make-backing-bitmap w h)))
+
     (define/override (get-backing-size xb yb)
       (send canvas get-client-size xb yb))
 
diff --git a/collects/mred/private/wx/gtk/platform.rkt b/collects/mred/private/wx/gtk/platform.rkt
index 2bc65319..f20c1811 100644
--- a/collects/mred/private/wx/gtk/platform.rkt
+++ b/collects/mred/private/wx/gtk/platform.rkt
@@ -101,4 +101,5 @@
    special-option-key
    special-control-key
    get-highlight-background-color
-   get-highlight-text-color))
+   get-highlight-text-color
+   make-screen-bitmap))
diff --git a/collects/mred/private/wx/gtk/procs.rkt b/collects/mred/private/wx/gtk/procs.rkt
index 96162e9d..99cfbf55 100644
--- a/collects/mred/private/wx/gtk/procs.rkt
+++ b/collects/mred/private/wx/gtk/procs.rkt
@@ -10,6 +10,7 @@
          "style.rkt"
          "widget.rkt"
          "window.rkt"
+         "dc.rkt"
          "../common/handlers.rkt")
 
 (provide
@@ -60,7 +61,8 @@
  show-print-setup
  can-show-print-setup?
  get-highlight-background-color
- get-highlight-text-color)
+ get-highlight-text-color
+ make-screen-bitmap)
 
 (define-unimplemented special-control-key)
 (define (special-option-key on?) (void))
@@ -132,3 +134,9 @@
     (if (and (zero? r) (zero? g) (zero? b))
 	#f
 	(make-object color% r g b))))
+
+(define/top (make-screen-bitmap [exact-positive-integer? w]
+                                [exact-positive-integer? h])
+  (if (eq? 'unix (system-type))
+      (make-object x11-bitmap% w h #f)
+      (make-object bitmap% w h #f #t)))
diff --git a/collects/mred/private/wx/gtk/x11.rkt b/collects/mred/private/wx/gtk/x11.rkt
new file mode 100644
index 00000000..dce8ea4c
--- /dev/null
+++ b/collects/mred/private/wx/gtk/x11.rkt
@@ -0,0 +1,35 @@
+#lang racket/base
+(require ffi/unsafe
+         ffi/unsafe/define
+         ffi/unsafe/alloc
+         "utils.rkt")
+
+(provide gdk_pixmap_new
+         gdk_drawable_get_display
+         gdk_drawable_get_visual
+         gdk_x11_drawable_get_xid
+         gdk_x11_display_get_xdisplay
+         gdk_x11_visual_get_xvisual)
+
+(define _GdkDrawable _pointer)
+(define _GdkDisplay (_cpointer 'GdkDisplay))
+(define _GdkVisual (_cpointer 'GdkVisual))
+(define _GdkPixmap (_cpointer 'GdkPixmap))
+(define _Visual (_cpointer 'Visual))
+(define _Display (_cpointer 'Display))
+(define _Drawable _ulong)
+
+(define-gdk gdk_pixmap_new (_fun _GdkDrawable _int _int _int -> _GdkPixmap)
+  #:wrap (allocator gobject-unref))
+
+(define-gdk gdk_drawable_get_display (_fun _GdkDrawable -> _GdkDisplay))
+(define-gdk gdk_drawable_get_visual (_fun _GdkDrawable -> _GdkVisual))
+
+(define-gdk gdk_x11_drawable_get_xid (_fun _GdkDrawable -> _Drawable)
+  #:make-fail make-not-available)
+
+(define-gdk gdk_x11_display_get_xdisplay (_fun _GdkDisplay -> _Display)
+  #:make-fail make-not-available)
+
+(define-gdk gdk_x11_visual_get_xvisual (_fun _GdkVisual -> _Visual)
+  #:make-fail make-not-available)
diff --git a/collects/mred/private/wx/platform.rkt b/collects/mred/private/wx/platform.rkt
index 3f5842a5..53f1e0f0 100644
--- a/collects/mred/private/wx/platform.rkt
+++ b/collects/mred/private/wx/platform.rkt
@@ -79,5 +79,6 @@
                 special-option-key
                 special-control-key
                 get-highlight-background-color
-                get-highlight-text-color)
+                get-highlight-text-color
+                make-screen-bitmap)
   ((dynamic-require platform-lib 'platform-values)))
diff --git a/collects/mred/private/wx/win32/platform.rkt b/collects/mred/private/wx/win32/platform.rkt
index 61d922b7..94abbf66 100644
--- a/collects/mred/private/wx/win32/platform.rkt
+++ b/collects/mred/private/wx/win32/platform.rkt
@@ -100,4 +100,5 @@
    special-option-key
    special-control-key
    get-highlight-background-color
-   get-highlight-text-color))
+   get-highlight-text-color
+   make-screen-bitmap))
diff --git a/collects/mred/private/wx/win32/procs.rkt b/collects/mred/private/wx/win32/procs.rkt
index 844fbca4..ecb0535c 100644
--- a/collects/mred/private/wx/win32/procs.rkt
+++ b/collects/mred/private/wx/win32/procs.rkt
@@ -49,8 +49,8 @@
  show-print-setup
  can-show-print-setup?
  get-highlight-background-color
- get-highlight-text-color)
-
+ get-highlight-text-color
+ make-screen-bitmap)
 
 (define-unimplemented special-control-key)
 (define-unimplemented special-option-key)
@@ -103,3 +103,4 @@
 (define-unimplemented can-show-print-setup?)
 (define-unimplemented get-highlight-background-color)
 (define-unimplemented get-highlight-text-color)
+(define-unimplemented make-screen-bitmap)
diff --git a/collects/mred/private/wxme/editor-canvas.rkt b/collects/mred/private/wxme/editor-canvas.rkt
index a9dca0e7..521d9cfb 100644
--- a/collects/mred/private/wxme/editor-canvas.rkt
+++ b/collects/mred/private/wxme/editor-canvas.rkt
@@ -895,7 +895,7 @@
       (set! noloop? savenoloop?)
 
       (when refresh?
-        (if (and #f ;; special scrolling disabled: not faster with Cocoa, broken for Gtk
+        (if (and #f ;; special scrolling disabled: not faster with Cocoa, broken for Windows
                  (not need-refresh?)
                  (not lazy-refresh?)
                  (get-canvas-background)
diff --git a/collects/scribblings/gui/canvas-class.scrbl b/collects/scribblings/gui/canvas-class.scrbl
index 5f3ef186..07b710d3 100644
--- a/collects/scribblings/gui/canvas-class.scrbl
+++ b/collects/scribblings/gui/canvas-class.scrbl
@@ -248,6 +248,13 @@ See also
 
 }
 
+@defmethod[(make-bitmap [width exact-positive-integer?]
+                        [height exact-positive-integer?]) 
+           (is-a/c? bitmap%)]{
+
+Creates a bitmap that draws in a way that is the same as drawing to the
+canvas. See also @racket[make-screen-bitmap].}
+
 
 @defmethod[#:mode override 
            (on-paint)
@@ -273,6 +280,11 @@ This method is called only when manual
 }
 
 
+@defmethod[(resume-flush) void?]{
+
+See @method[canvas% suspend-flush].}
+
+
 @defmethod[(scroll [h-value (or/c (real-in 0.0 1.0) false/c)]
                    [v-value (or/c (real-in 0.0 1.0) false/c)])
            void?]{
@@ -373,6 +385,22 @@ init-manual-scrollbars].
 }
 
 
+@defmethod[(suspend-flush) void?]{
+
+Drawing to a canvas's drawing context actually renders into an
+offscreen buffer. The buffer is automatically flushed to the screen by
+a background thread, unless flushing has been disabled for the canvas.
+The @method[canvas% suspend-flush] method suspends flushing for a
+canvas until a matching @method[canvas% resume-flush] calls; calls to
+@method[canvas% suspend-flush] and @method[canvas% resume-flush] can
+be nested, in which case flushing is suspended until the outermost
+@method[canvas% suspend-flush] is balanced by a @method[canvas%
+resume-flush].
+
+On some platforms, beware that suspending flushing for a canvas can
+discourage refreshes for other windows in the same frame.}
+
+
 @defmethod[(swap-gl-buffers)
            void?]{
 Calls
diff --git a/collects/scribblings/gui/miscwin-funcs.scrbl b/collects/scribblings/gui/miscwin-funcs.scrbl
index 56a436e9..2419d8d6 100644
--- a/collects/scribblings/gui/miscwin-funcs.scrbl
+++ b/collects/scribblings/gui/miscwin-funcs.scrbl
@@ -289,6 +289,18 @@ Like @racket[make-base-namespace], but with @racketmodname[racket/class] and
 environment of the result namespace.}
 
 
+@defproc[(make-screen-bitmap [width exact-positive-integer?]
+                             [height exact-positive-integer?]) 
+         (is-a/c? bitmap%)]{
+
+Creates a bitmap that draws in a way that is the same as drawing to a
+canvas in its default configuration. The bitmap is always in color
+with an alpha channel.
+
+A normal @racket[bitmap%] draws in a more platform-independent way and
+may use fewer constrained resources, particularly under Windows.}
+
+
 @defproc[(play-sound [filename path-string?]
                      [async? any/c])
          boolean?]{
diff --git a/doc/release-notes/racket/Draw_and_GUI_5_5.txt b/doc/release-notes/racket/Draw_and_GUI_5_5.txt
index 5ac70809..b56ac8d6 100644
--- a/doc/release-notes/racket/Draw_and_GUI_5_5.txt
+++ b/doc/release-notes/racket/Draw_and_GUI_5_5.txt
@@ -8,6 +8,18 @@ Changes to the drawing toolbox:
    The `racket/draw' library is built on top of the widely used Cairo
    drawing library and Pango text-rendering library.
 
+ * Drawing to a bitmap may not produce the same results as drawing to
+   a canvas. Use the `make-screen-bitmap' function (from `racket/gui')
+   or the `make-bitmap' method of `canvas%' to obtain a bitmap that
+   uses the same drawing algorithms as a canvas.
+
+   Drawing to a canvas always draws into a bitmap that is kept
+   offscreen and periodically flushed onto the screen. The new
+   `suspend-flush' and `resume-fluah' methods of `canvas%' provide
+   some control over the timing of the flushes, which in many cases
+   avoids the need for (additional) double buffering of canvas
+   content.
+
  * A color bitmap can have an alpha channel, instead of just a mask
    bitmap. When drawing a bitmap, alpha channels are used more
    consistently and automatically than mask bitmaps. More