From bb68137829fc896a34838466f7a7f810cac98703 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Fri, 6 Aug 2010 05:35:12 -0600
Subject: [PATCH] set up backing-dc%

---
 .../mred/private/wx/common/backing-dc.rkt     |  78 +++++++++++++
 collects/racket/draw/bitmap-dc.rkt            | 103 ++++++++++--------
 collects/racket/draw/bitmap.rkt               |   4 +-
 collects/racket/draw/dc.rkt                   |  17 ++-
 collects/racket/draw/local.rkt                |   6 +
 5 files changed, 157 insertions(+), 51 deletions(-)
 create mode 100644 collects/mred/private/wx/common/backing-dc.rkt

diff --git a/collects/mred/private/wx/common/backing-dc.rkt b/collects/mred/private/wx/common/backing-dc.rkt
new file mode 100644
index 0000000000..c8cef0ed50
--- /dev/null
+++ b/collects/mred/private/wx/common/backing-dc.rkt
@@ -0,0 +1,78 @@
+#lang racket/base
+(require racket/class
+         racket/draw/dc
+         racket/draw/bitmap-dc
+         racket/draw/bitmap
+         racket/draw/local)
+
+(provide backing-dc%
+         
+         ;; scoped method names:
+         get-backing-size
+         flush-backing
+         start-on-paint
+         end-on-paint)
+
+(define-local-member-name
+  get-backing-size
+  flush-backing
+  start-on-paint
+  end-on-paint)
+
+(define backing-dc%
+  (class (dc-mixin bitmap-dc-backend%)
+    (inherit call-with-cr-lock
+             internal-get-bitmap
+             internal-set-bitmap)
+
+    (super-new)
+
+    ;; Override this method to get the right size
+    (define/public (get-backing-size xb yb)
+      (set-box! xb 1)
+      (set-box! yb 1))
+
+    ;; override this method to push the bitmap to
+    ;;  the device that it backs
+    (define/public (flush-backing bm)
+      (void))
+
+    (define on-paint-cr #f)
+
+    (define/public (start-on-paint)
+      (call-with-cr-lock
+       (lambda () 
+         (if on-paint-cr 
+             (log-error "nested start-on-paint")
+             (set! on-paint-cr (get-cr))))))
+
+    (define/public (end-on-paint)
+      (call-with-cr-lock
+       (lambda () 
+         (if (not on-paint-cr)
+             (log-error "unbalanced end-on-paint")
+             (let ([cr on-paint-cr])
+               (set! on-paint-cr #f)
+               (release-cr cr))))))
+
+    (define/override (get-cr)
+      (or on-paint-cr
+          (let ([w (box 0)]
+                [h (box 0)])
+            (get-backing-size)
+            (let ([bm (get-backing-bitmap (unbox w) (unbox h))])
+              (internal-set-bitmap bm))
+            (super get-cr))))
+
+    (define/override (release-cr cr)
+      (unless (eq? cr on-paint-cr)
+        (let ([bm (internal-get-bitmap)])
+          (internal-set-bitmap #f)
+          (flush-backing bm)
+          (release-backing-bitmap bm))))))
+
+(define (get-backing-bitmap w h)
+  (make-object bitmap% w h #f #t))
+
+(define (release-backing-bitmap bm)
+  (send bm release-bitma-storage))
diff --git a/collects/racket/draw/bitmap-dc.rkt b/collects/racket/draw/bitmap-dc.rkt
index 54619c8b93..41493acdde 100644
--- a/collects/racket/draw/bitmap-dc.rkt
+++ b/collects/racket/draw/bitmap-dc.rkt
@@ -7,21 +7,23 @@
 	 "dc.ss"
          "local.ss")
 
-(provide bitmap-dc%)
+(provide bitmap-dc%
+         bitmap-dc-backend%)
 
-(define dc-backend%
+(define bitmap-dc-backend%
   (class default-dc-backend%
     (init [_bm #f])
-    (inherit reset-cr)
+    (inherit reset-cr
+             call-with-cr-lock)
 
     (define c #f)
     (define bm #f)
     (define b&w? #f)
     
     (when _bm
-      (do-set-bitmap _bm))
+      (do-set-bitmap _bm #f))
 
-    (define/private (do-set-bitmap v)
+    (define/private (do-set-bitmap v reset?)
       (when c
         (cairo_destroy c)
         (set! c #f))
@@ -30,43 +32,18 @@
         (set! c (cairo_create (send bm get-cairo-surface)))
         (set! b&w? (not (send bm is-color?)))))
 
-    (def/public (set-bitmap [(make-or-false bitmap%) v])
-      (do-set-bitmap v)
-      (when c (reset-cr c)))
+    (define/public (internal-set-bitmap v)
+      (call-with-cr-lock
+       (lambda ()
+         (do-set-bitmap v #t)
+         (when c (reset-cr c)))))
 
-    (def/public (get-bitmap) bm)
+    (define/public (internal-get-bitmap) bm)
 
     (def/override (get-size)
-      (values (exact->inexact (send bm get-width))
-              (exact->inexact (send bm get-height))))
-
-    (def/public (set-pixel [real? x][real? y][color% c])
-      (let ([s (bytes 255 (color-red c) (color-green c) (color-blue c))])
-        (set-argb-pixels x y 1 1 s)))
-
-    (def/public (get-pixel [real? x][real? y][color% c])
-      (let ([b (make-bytes 4)])
-        (get-argb-pixels x y 1 1 b)
-        (send c set (bytes-ref b 1) (bytes-ref b 2) (bytes-ref b 3))
-        #t))
-
-    (def/public (set-argb-pixels [exact-nonnegative-integer? x]
-                                 [exact-nonnegative-integer? y]
-                                 [exact-nonnegative-integer? w]
-                                 [exact-nonnegative-integer? h]
-                                 [bytes? bstr]
-                                 [any? [set-alpha? #f]])
-      (when bm
-        (send bm set-argb-pixels x y w h bstr set-alpha?)))
-
-    (def/public (get-argb-pixels [exact-nonnegative-integer? x]
-                                 [exact-nonnegative-integer? y]
-                                 [exact-nonnegative-integer? w]
-                                 [exact-nonnegative-integer? h]
-                                 [bytes? bstr]
-                                 [any? [get-alpha? #f]])
-      (when bm
-        (send bm get-argb-pixels x y w h bstr get-alpha?)))
+      (let ([bm bm])
+        (values (exact->inexact (send bm get-width))
+                (exact->inexact (send bm get-height)))))
 
     (define/override (get-cr) c)
 
@@ -97,9 +74,49 @@
 (define black (send the-color-database find-color "black"))
 
 (define bitmap-dc%
-  (class (dc-mixin dc-backend%)
-    (inherit draw-bitmap-section)
+  (class (dc-mixin bitmap-dc-backend%)
+    (inherit draw-bitmap-section
+             internal-set-bitmap
+             internal-get-bitmap)
     
+    (super-new)
+
+    (def/public (set-bitmap [(make-or-false bitmap%) v])
+      (internal-set-bitmap v))
+
+    (def/public (get-bitmap)
+      (internal-get-bitmap))
+    
+    (def/public (set-pixel [real? x][real? y][color% c])
+      (let ([s (bytes 255 (color-red c) (color-green c) (color-blue c))])
+        (set-argb-pixels x y 1 1 s)))
+
+    (def/public (get-pixel [real? x][real? y][color% c])
+      (let ([b (make-bytes 4)])
+        (get-argb-pixels x y 1 1 b)
+        (send c set (bytes-ref b 1) (bytes-ref b 2) (bytes-ref b 3))
+        #t))
+
+    (def/public (set-argb-pixels [exact-nonnegative-integer? x]
+                                 [exact-nonnegative-integer? y]
+                                 [exact-nonnegative-integer? w]
+                                 [exact-nonnegative-integer? h]
+                                 [bytes? bstr]
+                                 [any? [set-alpha? #f]])
+      (let ([bm (internal-get-bitmap)])
+        (when bm
+          (send bm set-argb-pixels x y w h bstr set-alpha?))))
+
+    (def/public (get-argb-pixels [exact-nonnegative-integer? x]
+                                 [exact-nonnegative-integer? y]
+                                 [exact-nonnegative-integer? w]
+                                 [exact-nonnegative-integer? h]
+                                 [bytes? bstr]
+                                 [any? [get-alpha? #f]])
+      (let ([bm (internal-get-bitmap)])
+        (when bm
+          (send bm get-argb-pixels x y w h bstr get-alpha?))))
+
     (def/public (draw-bitmap-section-smooth [bitmap% src]
                                             [real? dest-x]
                                             [real? dest-y]
@@ -110,8 +127,6 @@
                                             [(symbol-in solid opaque xor) [style 'solid]]
                                             [(make-or-false color%) [color black]]
                                             [(make-or-false bitmap%) [mask #f]])
-      (draw-bitmap-section src dest-x dest-y src-x src-y src-w src-h style color mask))
-    
-    (super-new)))
+      (draw-bitmap-section src dest-x dest-y src-x src-y src-w src-h style color mask))))
 
 (install-bitmap-dc-class! bitmap-dc%)
diff --git a/collects/racket/draw/bitmap.rkt b/collects/racket/draw/bitmap.rkt
index 9810d4b0cd..f96d7aaa9e 100644
--- a/collects/racket/draw/bitmap.rkt
+++ b/collects/racket/draw/bitmap.rkt
@@ -184,7 +184,7 @@
     (def/public (get-loaded-mask) loaded-mask)
     (def/public (set-loaded-mask [(make-or-false bitmap%) m]) (set! loaded-mask m))
 
-    (define/private (release-s)
+    (define/public (release-bitmap-storage)
       (drop-alpha-s)
       (when s
         (let ([s2 s])
@@ -201,7 +201,7 @@
     (def/public (load-bitmap [(make-alts path-string? input-port?) in]
                              [kind-symbol? [kind 'unknown]]
                              [(make-or-false color%) [bg #f]])
-      (release-s)
+      (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))
       (set! height (if s (cairo_image_surface_get_height s) 0)))
diff --git a/collects/racket/draw/dc.rkt b/collects/racket/draw/dc.rkt
index 5dece09820..4ae179b593 100644
--- a/collects/racket/draw/dc.rkt
+++ b/collects/racket/draw/dc.rkt
@@ -55,6 +55,10 @@
 ;; This is the interface that the backend specific code must implement
 (define dc-backend<%>
   (interface ()
+    ;; call-with-cr-lock : (-> any) -> any
+    ;;
+    ;; Calls a thunk while holding the lock on the cairo context.
+
     ;; get-cr : -> cairo_t or #f
     ;;
     ;; Gets a cairo_t created in a backend specific manner.
@@ -125,6 +129,12 @@
 (define default-dc-backend%
   (class* object% (dc-backend<%>)
 
+    (define lock (make-semaphore 1))
+    (define/public (call-with-cr-lock thunk)
+      (call-with-semaphore
+       lock
+       thunk))
+
     (define/public (get-cr) #f)
     (define/public (release-cr cr) (void))
     (define/public (end-cr) (void))
@@ -177,13 +187,10 @@
 
     (inherit flush-cr get-cr release-cr end-cr init-cr-matrix get-pango
              install-color dc-adjust-smoothing reset-clip
-             collapse-bitmap-b&w?)
-
-    (define lock (make-semaphore 1))
+             collapse-bitmap-b&w? call-with-cr-lock)
 
     (define-syntax-rule (with-cr default cr . body)
-      (call-with-semaphore
-       lock
+      (call-with-cr-lock
        (lambda ()
          (let ([cr (get-cr)])
            (if cr 
diff --git a/collects/racket/draw/local.rkt b/collects/racket/draw/local.rkt
index cc3b05868a..ff012de577 100644
--- a/collects/racket/draw/local.rkt
+++ b/collects/racket/draw/local.rkt
@@ -10,6 +10,11 @@
   ;; bitmap%
   get-cairo-surface
   get-cairo-alpha-surface
+  release-bitmap-storage
+
+  ;; bitmap-dc%
+  internal-get-bitmap
+  internal-set-bitmap
 
   ;; dc%
   in-cairo-context
@@ -26,6 +31,7 @@
   get-ps-pango
 
   ;; dc-backend<%>
+  call-with-cr-lock
   get-cr
   end-cr
   reset-cr