From 670d58d134eaf2dc5ed6ef4ea60f53d66321acda Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Thu, 6 Jan 2011 12:32:09 -0600
Subject: [PATCH] added un/cache-image, a function that enables/disables the
 drawing cache in 2htdp/image images

---
 collects/mrlib/image-core.rkt               | 39 +++++++++++++++------
 collects/mrlib/scribblings/image-core.scrbl |  5 +++
 2 files changed, 34 insertions(+), 10 deletions(-)

diff --git a/collects/mrlib/image-core.rkt b/collects/mrlib/image-core.rkt
index e10ca5c099..3cbd78905d 100644
--- a/collects/mrlib/image-core.rkt
+++ b/collects/mrlib/image-core.rkt
@@ -78,7 +78,13 @@ has been moved out).
       (is-a? p image-snip%)
       (is-a? p bitmap%)))
 
-
+(define (un/cache-image img bitmap-cache?)
+  (unless (image? img)
+    (error 'un/cache-image "expected an image as the first argument, got ~e" img))
+  (define res (send img copy))
+  (send res set-use-bitmap-cache?! (and bitmap-cache? #t))
+  res)
+  
 ;; a shape is either:
 ;;
 ;;  - (make-overlay shape shape)
@@ -226,7 +232,9 @@ has been moved out).
     (begin0
         (send bdc get-bitmap)
       (send bdc set-bitmap #f))))
-	     
+
+(define-local-member-name set-use-bitmap-cache?!)
+
 (define image%
   (class* snip% (png-convertible<%> image<%>)
     (init-field shape bb normalized? pinhole)
@@ -315,20 +323,29 @@ has been moved out).
     (define/override (copy) (make-image shape bb normalized? pinhole))
     
     (define cached-bitmap #f)
+    (define use-cached-bitmap? #t)
+    
+    (define/public (set-use-bitmap-cache?! u-b-c?) 
+      (set! use-cached-bitmap? u-b-c?)
+      (unless use-cached-bitmap?
+        (set! cached-bitmap #f)))
     
     (define/override (draw dc x y left top right bottom dx dy draw-caret)
-      (unless cached-bitmap
-        (set! cached-bitmap (make-bitmap (+ (inexact->exact (round (bb-right bb))) 1) 
-                                         (+ (inexact->exact (round (bb-bottom bb))) 1)))
-        (define bdc (make-object bitmap-dc% cached-bitmap))
-        (send bdc erase)
-        (render-image this bdc 0 0)
-        (send bdc set-bitmap #f))
+      (when use-cached-bitmap?
+        (unless cached-bitmap
+          (set! cached-bitmap (make-bitmap (+ (inexact->exact (round (bb-right bb))) 1) 
+                                           (+ (inexact->exact (round (bb-bottom bb))) 1)))
+          (define bdc (make-object bitmap-dc% cached-bitmap))
+          (send bdc erase)
+          (render-image this bdc 0 0)
+          (send bdc set-bitmap #f)))
       
       (let ([alpha (send dc get-alpha)])
         (when (pair? draw-caret)
           (send dc set-alpha (* alpha .5)))
-        (send dc draw-bitmap cached-bitmap x y)
+        (if use-cached-bitmap?
+            (send dc draw-bitmap cached-bitmap x y)
+            (render-image this dc x y))
         (send dc set-alpha alpha)))
     
     (define/override (get-extent dc x y [w #f] [h #f] [descent #f] [space #f] [lspace #f] [rspace #f])
@@ -1164,6 +1181,8 @@ the mask bitmap and the original bitmap are all together in a single bytes!
 
 
 (provide make-image image-shape image-bb image-normalized? image%
+        
+         un/cache-image
          
          (struct-out bb)
          (struct-out point)
diff --git a/collects/mrlib/scribblings/image-core.scrbl b/collects/mrlib/scribblings/image-core.scrbl
index e798e08ba5..b97cb0339e 100644
--- a/collects/mrlib/scribblings/image-core.scrbl
+++ b/collects/mrlib/scribblings/image-core.scrbl
@@ -21,4 +21,9 @@ up an image.
                
 @defproc[(image? [v any/c]) boolean?]{
  Recognizes the images that library handles.
+}
+
+@defproc[(un/cache-image [image image?] [b any/c]) image?]{
+  Returns an image that either caches its drawing in the 
+  snip @method[snip% draw] method or doesn't, depending on @racket[b].
 }
\ No newline at end of file