From fd7790118c5c85d52356a70473d1f0d13c60d351 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Fri, 19 Aug 2005 20:31:05 +0000
Subject: [PATCH] ,

svn: r620
---
 collects/lang/htdp-langs.ss      | 76 ++++++++++++++++----------------
 collects/lang/private/imageeq.ss | 48 +++++++++++---------
 2 files changed, 65 insertions(+), 59 deletions(-)

diff --git a/collects/lang/htdp-langs.ss b/collects/lang/htdp-langs.ss
index 60f7e7c840..b844fa93ef 100644
--- a/collects/lang/htdp-langs.ss
+++ b/collects/lang/htdp-langs.ss
@@ -379,44 +379,44 @@ tracing todo:
           (inherit get-reader set-printing-parameters)
           
           (define/override (front-end/complete-program port settings teachpacks)
-             (let ([state 'init]
-                   ;; state : 'init => 'require => 'done
-                   [reader (get-reader)])
-               
-               (lambda ()
-                 (case state
-                   [(init)
-                    (set! state 'require)
-                    (let ([body-exps 
-                           (let loop ()
-                             (let ([result (reader (object-name port) port)])
-                               (if (eof-object? result)
-                                   null
-                                   (cons result (loop)))))]
-                          [language-module (get-module)]
-                          [require-specs 
-                           (drscheme:teachpack:teachpack-cache-require-specs teachpacks)])
-                      (rewrite-module 
-                       (expand
-                        (datum->syntax-object
-                         #f
-                         `(,#'module #%htdp ,language-module 
-                            (,#'require ,@require-specs)
-                            ,@body-exps)))))]
-                   [(require) 
-                    (set! state 'done)
-                    (syntax
-                     (let ([done-already? #f])
-                       (dynamic-wind
-                        void
-                        (lambda () 
-                          ;(dynamic-require '#%htdp #f)
-                          (eval #'(require #%htdp)))  ;; work around a bug in dynamic-require
-                        (lambda () 
-                          (unless done-already?
-                            (set! done-already? #t)
-                            (current-namespace (module->namespace '#%htdp)))))))]
-                   [(done) eof]))))
+            (let ([state 'init]
+                  ;; state : 'init => 'require => 'done
+                  [reader (get-reader)])
+              
+              (lambda ()
+                (case state
+                  [(init)
+                   (set! state 'require)
+                   (let ([body-exps 
+                          (let loop ()
+                            (let ([result (reader (object-name port) port)])
+                              (if (eof-object? result)
+                                  null
+                                  (cons result (loop)))))]
+                         [language-module (get-module)]
+                         [require-specs 
+                          (drscheme:teachpack:teachpack-cache-require-specs teachpacks)])
+                     (rewrite-module 
+                      (expand
+                       (datum->syntax-object
+                        #f
+                        `(,#'module #%htdp ,language-module 
+                           (,#'require ,@require-specs)
+                           ,@body-exps)))))]
+                  [(require) 
+                   (set! state 'done)
+                   (syntax
+                    (let ([done-already? #f])
+                      (dynamic-wind
+                       void
+                       (lambda () 
+                         ;(dynamic-require '#%htdp #f)
+                         (eval #'(require #%htdp)))  ;; work around a bug in dynamic-require
+                       (lambda () 
+                         (unless done-already?
+                           (set! done-already? #t)
+                           (current-namespace (module->namespace '#%htdp)))))))]
+                  [(done) eof]))))
 
           (super-new)))
 
diff --git a/collects/lang/private/imageeq.ss b/collects/lang/private/imageeq.ss
index 200d554cfc..076de83741 100644
--- a/collects/lang/private/imageeq.ss
+++ b/collects/lang/private/imageeq.ss
@@ -48,30 +48,36 @@
                           (= (vector-ref v1 (- i 1)) (vector-ref v2 (- i 1)))))
                  (loop (- i 4)))))))
   
-    ;; coerce-to-cache-image-snip : image -> (is-a?/c cache-image-snip%)
+  
+  (define image-snip-cache (make-hash-table 'weak))
+  ;; coerce-to-cache-image-snip : image -> (is-a?/c cache-image-snip%)
   (define (coerce-to-cache-image-snip snp)
     (cond
+      [(hash-table-get image-snip-cache snp (λ () #f)) => values]
       [(is-a? snp image-snip%)
-       (let ([bmp (send snp get-bitmap)])
-         (if bmp
-             (let ([bmp-mask (or (send bmp get-loaded-mask)
-                                 (send snp get-bitmap-mask)
-                                 (bitmap->mask bmp))])
-               (bitmaps->cache-image-snip (copy-bitmap bmp)
-                                          (copy-bitmap bmp-mask)
-                                          (floor (/ (send bmp get-width) 2))
-                                          (floor (/ (send bmp get-height) 2))))
-             (let-values ([(w h) (snip-size snp)])
-               (let* ([bmp (make-object bitmap% 
-                             (inexact->exact (floor w))
-                             (inexact->exact (floor h)))]
-                      [bdc (make-object bitmap-dc% bmp)])
-                 (send snp draw bdc 0 0 0 0 w h 0 0 'no-caret)
-                 (send bdc set-bitmap #f)
-                 (bitmaps->cache-image-snip bmp 
-                                            (bitmap->mask bmp)
-                                            (floor (/ w 2))
-                                            (floor (/ h 2)))))))]
+       (let* ([bmp (send snp get-bitmap)]
+              [cis
+               (if bmp
+                   (let ([bmp-mask (or (send bmp get-loaded-mask)
+                                       (send snp get-bitmap-mask)
+                                       (bitmap->mask bmp))])
+                     (bitmaps->cache-image-snip (copy-bitmap bmp)
+                                                (copy-bitmap bmp-mask)
+                                                (floor (/ (send bmp get-width) 2))
+                                                (floor (/ (send bmp get-height) 2))))
+                   (let-values ([(w h) (snip-size snp)])
+                     (let* ([bmp (make-object bitmap% 
+                                   (inexact->exact (floor w))
+                                   (inexact->exact (floor h)))]
+                            [bdc (make-object bitmap-dc% bmp)])
+                       (send snp draw bdc 0 0 0 0 w h 0 0 'no-caret)
+                       (send bdc set-bitmap #f)
+                       (bitmaps->cache-image-snip bmp 
+                                                  (bitmap->mask bmp)
+                                                  (floor (/ w 2))
+                                                  (floor (/ h 2))))))])
+         (hash-table-put! image-snip-cache snp cis)
+         cis)]
       [else snp]))
     
   ;; copy-bitmap : bitmap -> bitmap