From 2df9ca87890c9db49e8fcc5125b0e82ddf9a2cac Mon Sep 17 00:00:00 2001 From: Stephen Bloch Date: Sat, 28 Apr 2012 14:37:56 -0400 Subject: [PATCH] Added fold-image and fold-image/extra functions, as well as tests for them. --- .../picturing-programs/private/map-image.rkt | 41 ++++++++++++++++ .../tests/map-image-bsl-tests.rkt | 48 +++++++++++++++++++ 2 files changed, 89 insertions(+) diff --git a/collects/picturing-programs/private/map-image.rkt b/collects/picturing-programs/private/map-image.rkt index ad7ccebd75..f6ddfde93a 100644 --- a/collects/picturing-programs/private/map-image.rkt +++ b/collects/picturing-programs/private/map-image.rkt @@ -56,6 +56,8 @@ ;(provide-higher-order-primitive build-masked-image (_ _ f)) (provide-higher-order-primitive build-image/extra (_ _ f _)) (provide-higher-order-primitive map-image/extra (f _ _)) +(provide-higher-order-primitive fold-image (f _ _)) +(provide-higher-order-primitive fold-image/extra (f _ _ _)) ; check-procedure-arity : alleged-function nat-num symbol string ; Note: if you invoke these things from a BSL or BSLL program, the syntax checker will @@ -387,3 +389,42 @@ (afunc x y (color-red c) (color-green c) (color-blue c) (color-alpha c)))) pic)) +; fold-image : ([x y] c X -> X) X image -> X +; fold-image-internal : (nat nat color X -> X) X image -> image +(define (fold-image-internal f init img) + (define w (image-width img)) + (define h (image-height img)) + (define bm (make-bitmap w h)) + (define bdc (make-object bitmap-dc% bm)) + (render-image img bdc 0 0) + (send bdc set-bitmap #f) + (define bytes (make-bytes (* w h 4))) + (send bm get-argb-pixels 0 0 w h bytes) + (define answer init) + (for* ((y (in-range 0 h)) + (x (in-range 0 w))) + (set! answer (f x y (get-px x y w h bytes) answer))) + answer) + +(define (fold-image f init img) + (unless (image? img) + (error 'fold-image + (format "Expected an image as third argument, but received ~v" img))) + (cond [(procedure-arity-includes? f 4) + (fold-image-internal f init img)] + [(procedure-arity-includes? f 2) ; allow f : color X->X as a simple case + (fold-image-internal (lambda (x y c old-value) (f c old-value)) init img)] + [else (error 'fold-image "Expected a function of two or four parameters as first argument")])) + +; fold-image/extra : ([x y] c X Y -> X) X image Y -> X +(define (fold-image/extra f init img extra) + (unless (image? img) + (error 'fold-image/extra + (format "Expected an image as third argument, but received ~v" img))) + (cond [(procedure-arity-includes? f 5) + (fold-image-internal (lambda (x y c old-value) (f x y c old-value extra)) init img)] + [(procedure-arity-includes? f 3) + (fold-image-internal (lambda (x y c old-value) (f c old-value extra)) init img)] + [else (error 'fold-image/extra "Expected a function taking three or five parameters as first argument")] + )) + diff --git a/collects/picturing-programs/tests/map-image-bsl-tests.rkt b/collects/picturing-programs/tests/map-image-bsl-tests.rkt index 67fa1f9793..13d8ab89a0 100644 --- a/collects/picturing-programs/tests/map-image-bsl-tests.rkt +++ b/collects/picturing-programs/tests/map-image-bsl-tests.rkt @@ -463,3 +463,51 @@ pic:bloch (clip-picture-colors 200 pic:bloch) (clip-picture-colors 150 pic:bloch) (clip-picture-colors 100 pic:bloch) +; another-white : color number -> number +(define (another-white c old) + (+ old (if (color=? c "white") 1 0))) +; count-white-pixels : image -> number +(define (count-white-pixels pic) + (fold-image another-white 0 pic)) +(check-expect (count-white-pixels (rectangle 15 10 "solid" "blue")) 0) +(check-expect (count-white-pixels (rectangle 15 10 "solid" "white")) 150) + +; another-color : color number color -> number +(define (another-color c old color-to-count) + (+ old (if (color=? c color-to-count) 1 0))) +; count-colored-pixels : image color -> number +(define (count-colored-pixels pic color-to-count) + (fold-image/extra another-color 0 pic color-to-count)) +(check-expect (count-colored-pixels (rectangle 15 10 "solid" "blue") "blue") 150) +(check-expect (count-colored-pixels (overlay (rectangle 5 10 "solid" "blue") (ellipse 15 30 "solid" "green")) + "blue") + 50) +(check-expect (count-colored-pixels (overlay (rectangle 5 10 "solid" "blue") (ellipse 20 30 "solid" "green")) + "blue") + 40) ; because the overlaid rectangle is offset by half a pixel, so the top and bottom rows aren't "blue" + +(define-struct rgba (red green blue alpha)) +; like "color" but without bounds-checking +; accumulate-color : color rgba -> rgba +(define (accumulate-color c old) + (make-rgba (+ (color-red c) (rgba-red old)) + (+ (color-green c) (rgba-green old)) + (+ (color-blue c) (rgba-blue old)) + (+ (color-alpha c) (rgba-alpha old)))) + +; scale-rgba : number rgba -> rgba +(define (scale-rgba factor old) + (make-rgba (* factor (rgba-red old)) + (* factor (rgba-green old)) + (* factor (rgba-blue old)) + (* factor (rgba-alpha old)))) + +; average-color : image -> rgba +(define (average-color pic) + (scale-rgba (/ 1 (* (image-width pic) (image-height pic))) + (fold-image accumulate-color (make-rgba 0 0 0 0) pic))) +(check-expect (average-color (rectangle 5 10 "solid" "blue")) + (make-rgba 0 0 255 255)) +(check-expect (average-color (overlay (rectangle 5 10 "solid" "blue") + (rectangle 25 10 "solid" "black"))) + (make-rgba 0 0 51 255)) \ No newline at end of file