From 656713cbcf70dddf1b76d0b886341aabcfce53cf Mon Sep 17 00:00:00 2001 From: Stephen Bloch Date: Sat, 28 Apr 2012 10:56:12 -0400 Subject: [PATCH] Enlarged cache for get-pixel-color from one image to 3, so you can alternate among three images without thrashing and re-rendering. --- .../picturing-programs/private/map-image.rkt | 103 +++++++++++------- 1 file changed, 65 insertions(+), 38 deletions(-) diff --git a/collects/picturing-programs/private/map-image.rkt b/collects/picturing-programs/private/map-image.rkt index 1c75f41e28..ad7ccebd75 100644 --- a/collects/picturing-programs/private/map-image.rkt +++ b/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)) +