add make-screen-bitmap and canvas% make-bitmap; specialize for X11

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%

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

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

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)

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/override (get-cairo-surface) s)
+    (define/override (get-cairo-alpha-surface) s)
 
-    (define/public (get-cairo-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)

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

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
 

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

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

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

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

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

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)

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

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

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)

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)

collects/racket/draw/bitmap.rkt

@@ -14,11 +14,14 @@
          "local.ss"
          "color.ss")
 
-(provide bitmap%)
+(provide bitmap%
+         make-alternate-bitmap-kind)
 
 ;; FIXME: there must be some way to abstract over all many of the
 ;; ARGB/RGBA/BGRA iterations.
 
+(define-struct alternate-bitmap-kind (width height))
+
 (define-local-member-name
   get-alphas-as-mask
   set-alphas-as-mask)
@@ -77,15 +80,20 @@
     (init-rest args)
     (super-new)
 
-    (define-values (width height b&w? alpha-channel? s loaded-mask)
+    (define-values (alt? width height b&w? alpha-channel? s loaded-mask)
       (case-args 
        args
-       [() (void)]
+       [([alternate-bitmap-kind? a])
+        (values #t
+                (alternate-bitmap-kind-width a)
+                (alternate-bitmap-kind-height a)
+                #f #t #f #f)]
        [([exact-nonnegative-integer? w]
          [exact-nonnegative-integer? h]
          [any? [b&w? #f]]
          [any? [alpha? #f]])
         (values
+         #f
          w
          h
          (and b&w? #t)
@@ -137,13 +145,14 @@
                            (bytes-set! bstr (+ A (* 4 i) (* j row-width)) 255))
                          (cairo_surface_mark_dirty s))))])
             (if s
-                (values (cairo_image_surface_get_width s)
+                (values #f
+                        (cairo_image_surface_get_width s)
                         (cairo_image_surface_get_height s)
                         b&w?
                         alpha?
                         s
                         mask-bm)
-                (values 0 0 #f #f #f #f))))]
+                (values #f 0 0 #f #f #f #f))))]
        [([bytes? bstr]
          [exact-nonnegative-integer? w]
          [exact-nonnegative-integer? h])
@@ -158,7 +167,7 @@
                            (let ([s (* i bw)])
                              (subbytes bstr s (+ s bw)))))])
               (install-bytes-rows s w h rows #t #f #f #t))
-            (values w h #t #f s #f)))]
+            (values #f w h #t #f s #f)))]
        (init-name 'bitmap%)))
 
     ;; Use for non-alpha color bitmaps when they are used as a mask:
@@ -181,6 +190,12 @@
     (def/public (is-color?) (not b&w?))
     (def/public (has-alpha-channel?) alpha-channel?)
 
+    (define/private (check-alternate who)
+      (when alt?
+        (raise-mismatch-error (method-name 'bitmap% who)
+                              "not available in a canvas-compatible bitmap: "
+                              this)))
+
     (def/public (get-loaded-mask) loaded-mask)
     (def/public (set-loaded-mask [(make-or-false bitmap%) m]) (set! loaded-mask m))
 
@@ -201,6 +216,7 @@
     (def/public (load-bitmap [(make-alts path-string? input-port?) in]
                              [kind-symbol? [kind 'unknown]]
                              [(make-or-false color%) [bg #f]])
+      (check-alternate 'load-bitmap)
       (release-bitmap-storage)
       (set!-values (s b&w?) (do-load-bitmap in kind bg))
       (set! width (if s (cairo_image_surface_get_width s) 0))
@@ -393,6 +409,7 @@
     (def/public (save-file [(make-alts path-string? output-port?) out]
                            [save-kind-symbol? [kind 'unknown]]
                            [quality-integer? [quality 75]])
+      (check-alternate 'save-file)
       (check-ok 'save-file)
       (do-save-file out kind quality))
 
@@ -514,6 +531,7 @@
         (raise-mismatch-error (method-name 'bitmap% 'get-argb-pixels)
                               "byte string is too short: "
                               bstr))
+      (check-alternate 'get-argb-pixels)
       ;; Fill range that is beyond edge of picture:
       (if get-alpha?
           (for* ([i (in-range width (+ x w))]
@@ -573,6 +591,7 @@
         (raise-mismatch-error (method-name 'bitmap% 'set-argb-pixels)
                               "byte string is too short: "
                               bstr))
+      (check-alternate 'set-argb-pixels)
       ;; Set pixels:
       (let-values ([(A R G B) (argb-indices)])
         (when (not set-alpha?)

collects/racket/draw/cairo.rkt

@@ -67,6 +67,15 @@
 (define-cairo cairo_surface_create_similar
   (_fun _cairo_surface_t _int _int _int -> _cairo_surface_t))
 
+(define-cairo cairo_xlib_surface_create (_fun _pointer ; Display*
+                                              _ulong   ; Drawable
+                                              _pointer ; Visual*
+                                              _int     ; width
+                                              _int     ; height
+                                              -> _cairo_surface_t)
+  #:make-fail make-not-available
+  #:wrap (allocator cairo_surface_destroy))
+
 (define-cairo cairo_create (_fun _cairo_surface_t -> _cairo_t)
   #:wrap (allocator cairo_destroy))
 

collects/scribblings/gui/bitmap-class.scrbl

@@ -4,7 +4,8 @@
 @defclass/title[bitmap% object% ()]{
 
 A @scheme[bitmap%] object is a pixel-based image, either
- monochrome, color, or color with an alpha channel.
+ monochrome, color, or color with an alpha channel. See also
+ @racket[make-screen-bitmap] and @xmethod[canvas% make-bitmap].
 
 Sometimes, a bitmap object creation fails in a low-level manner. In
  that case, the @method[bitmap% ok?] method returns @scheme[#f], and

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

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?]{

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