Added fold-image and fold-image/extra functions, as well as tests for

them.

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")]
+        ))
+

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))