Enlarged cache for get-pixel-color from one image to 3, so you can

alternate among three images without thrashing and re-rendering.

collects/picturing-programs/private/map-image.rkt

@@ -14,6 +14,13 @@
 ; function x and y or not, depending on their arity.  This way one
 ; can write a function from color to color, and immediately map it
 ; onto an image.
+; Apr 27, 2012: get-pixel-color has long had a "cache" of one image so it doesn't need
+; to keep re-rendering.  Experimenting with increasing this cache to two images, so we
+; can call get-pixel-color on two images in alternation without thrashing.  The cache
+; itself seems to work, and having the cache size >= the number of images DOES improve
+; performance for a series of get-pixel-color calls rotating among several images (each
+; render seems to take about a ms).
+; Apr 28, 2012: added fold-image and fold-image/extra.
 
 (require racket/draw
         racket/snip
@@ -37,6 +44,7 @@
                     ;pixel-visible?
                     ; change-to-color
                     color=?
+                    show-cache
                     )
 (provide-higher-order-primitive map-image (f _))
 (provide-higher-order-primitive map3-image (rfunc gfunc bfunc _))
@@ -158,50 +166,68 @@
   (bytes-set! bytes (+ offset 3) (color-blue new-color)))
 
 ; get-pixel-color : x y image -> color
-; This will remember the last image on which it was called.
+; This will remember the last CACHE-SIZE images on which it was called.
 ; Really terrible performance if you call it in alternation
-; on two different images, but should be OK if you call it
+; on CACHE-SIZE+1 different images, but should be OK if you call it
 ; lots of times on the same image.
 ; Returns transparent if you ask about a position outside the picture.
-(define get-pixel-color
-  (let [[last-image #f]
-        [last-bytes #f]]
-    (lambda (x y pic)
-      (define w (image-width pic))
-      (define h (image-height pic))
-      (unless (eqv? pic last-image)
-        ; assuming nobody mutates an image between one get-pixel-color and the next
-        (set! last-image pic)
-        (define bm (make-bitmap w h))
-        (define bmdc (make-object bitmap-dc% bm))
-        (set! last-bytes (make-bytes (* 4 w h)))
-        (render-image pic bmdc 0 0)
-        (send bmdc set-bitmap #f)
-        (send bm get-argb-pixels 0 0 w h last-bytes))
-      (if (and (<= 0 x (sub1 w))
-               (<= 0 y (sub1 h)))
-          (get-px x y w h last-bytes)
-          transparent))))
 
-;; pixel-visible? : nat(x) nat(y) image -> boolean
-;; similar
-;(define pixel-visible?
-;  (let [[last-image #f]
-;        [last-bm #f]
-;        [last-bmdc #f]]
-;    (lambda (x y pic)
+(define CACHE-SIZE 3)
+(define-struct ib (image bytes) #:transparent)
+; A cache is a list of at most CACHE-SIZE ib's.
+; search-cache: image cache -> bytes or #f
+(define (search-cache pic cache)
+  (cond [(null? cache) #f]
+        [(eqv? pic (ib-image (car cache))) (ib-bytes (car cache))]
+        [else (search-cache pic (cdr cache))]))
+
+; We'll do a simple LRU cache-replacement.
+
+; add-and-drop : ib cache -> cache
+; preserves size
+(define (add-and-drop new-ib cache)
+  (cons new-ib (drop-last cache)))
+
+; drop-last : non-empty list -> list
+(define (drop-last L)
+  (cond [(null? L) (error 'drop-last "list is empty")]
+        [(null? (cdr L)) '()]
+        [else (cons (car L) (drop-last (cdr L)))]))
+
+(define cache (build-list CACHE-SIZE (lambda (n) (ib #f #f))))
+
+(define (show-cache) (map ib-image cache)) ; exported temporarily for debugging
+
+(define get-pixel-color
+  (let [;(cache (build-list CACHE-SIZE (lambda (n) (ib #f #f))))
+        ]
+    (lambda (x y pic)
+      (let* [(w (image-width pic))
+             (h (image-height pic))
+             (bytes
+              (or (search-cache pic cache)
+                  (let* [(bm (make-bitmap w h))
+                         (bmdc (make-object bitmap-dc% bm))
+                         (new-bytes (make-bytes (* 4 w h)))]
+                    (render-image pic bmdc 0 0)
+                    (send bmdc set-bitmap #f)
+                    (send bm get-argb-pixels 0 0 w h new-bytes)
+                    (set! cache (add-and-drop (ib pic new-bytes) cache))
+                    new-bytes)))]
 ;      (unless (eqv? pic last-image)
+;        ; assuming nobody mutates an image between one get-pixel-color and the next
 ;        (set! last-image pic)
-;        (set! last-bm (get-mask pic))
-;        (set! last-bmdc (make-object bitmap-dc% last-bm)))
-;      (let [[mask-pix (get-px x y last-bmdc)]] ; assumes this doesn't crash if out of bounds
-;        (and (equal? mask-pix (make-color 0 0 0)) ; treat anything else as transparent
-;             (>= x 0)
-;             (>= y 0)
-;             (< x (image-width pic))
-;             (< y (image-height pic))
-;            )))))
-;
+;        (define bm (make-bitmap w h))
+;        (define bmdc (make-object bitmap-dc% bm))
+;        (set! last-bytes (make-bytes (* 4 w h)))
+;        (render-image pic bmdc 0 0)
+;        (send bmdc set-bitmap #f)
+;        (send bm get-argb-pixels 0 0 w h last-bytes))
+        (if (and (<= 0 x (sub1 w))
+                 (<= 0 y (sub1 h)))
+            (get-px x y w h bytes)
+            transparent))))
+  )
 
 ; build-image-internal : natural(width) natural(height) (nat nat -> color) -> image
 (define (build-image-internal w h f)
@@ -360,3 +386,4 @@
                       (bfunc x y (color-red c) (color-green c) (color-blue c) (color-alpha c))
                       (afunc x y (color-red c) (color-green c) (color-blue c) (color-alpha c))))
       pic))
+