map-image and map-image/extra now give their function argument x and y

coordinates, or not, depending on the arity of that function.  This
enables one to write a simple function from color -> color and
immediately map it on an image.  For the situation in which the
function is location-dependent, one can still write a function from
x,y,color -> color and map this on the image.

collects/picturing-programs/picturing-programs.scrbl

@@ -220,8 +220,7 @@ randomly chosen pixel near it.}
          [width natural-number/c]
          [height natural-number/c]
          [f (-> natural-number/c natural-number/c any/c color?)] [extra any/c]) image?]{
-Equivalent to @racketblock[(build-image width height (lambda (x y) (f x y extra)))]
+Passes the @racket[extra] argument in as a third argument in each call
-In other words, it passes the @racket[extra] argument in as a third argument in each call
 to @racket[f].  This allows students who haven't learned closures yet to do pixel-by-pixel image
 manipulations inside a function depending on a parameter of that function.
 
@@ -260,50 +259,74 @@ should return an integer from 0 through 255 to determine that color component.}
 Just like @racket[build4-image], but without specifying the alpha component
 (which defaults to 255, fully opaque).}
 
-@defproc[(map-image [f (-> natural-number/c natural-number/c color? color?)] [img image?])
+@defproc*[([(map-image [f (-> color? color?)] [img image?]) image?]
-         image?]{
+           [(map-image [f (-> natural-number/c natural-number/c color?  color?)] [img image?]) image?])]{
+Applies the given function to each pixel in a given image, producing a
+new image the same size and shape.  The color of each pixel in the
+result is the result of calling f on the corresponding
+pixel in the input.  If f accepts 3 parameters, it will be given the x
+and y coordinates and the color of the old pixel; if it accepts 1, it
+will be given only the color of the old pixel.
 
-Applies the given function to each pixel in a given image, producing a new image the same
+An example with a 1-parameter function:
-size and shape.  For example,
 @codeblock|{
-; lose-red : num(x) num(y) color -> color
+; lose-red : color -> color
-(define (lose-red x y old-color)
+(define (lose-red old-color)
   (make-color 0 (color-green old-color) (color-blue old-color)))
 
 (map-image lose-red my-picture)}|
 produces a copy of @racket[my-picture] with all the red leached out,
 leaving only the blue and green components.
 
-Since @racket[make-color] with three arguments defaults alpha to 255,
+Since @racket[make-color] defaults alpha to 255,
 this definition of @racket[lose-red] discards any alpha information (including edge-dithering)
 that was in the original image.  To preserve this information, one could write
 @racketblock[
-(define (lose-red-but-not-alpha x y old-color)
+(define (lose-red-but-not-alpha old-color)
   (make-color 0 (color-green old-color) (color-blue old-color) (color-alpha
 old-color)))]
 
-Another example:
+An example with a 3-parameter (location-sensitive) function:
 @codeblock|{
 ; apply-gradient : num(x) num(y) color -> color
 (define (apply-gradient x y old-color)
   (make-color (min (* 3 x) 255)
-              0
+              (color-green old-color)
-              (min (* 3 y) 255)))
+              (color-blue old-color)))
 
 (map-image apply-gradient my-picture)}|
 produces a picture the size of @racket[my-picture]'s bounding rectangle,
-with a smooth color gradient with red increasing from left to
+replacing the red component with a smooth color gradient increasing
-right and blue increasing from top to bottom.}
+from left to right, but with the green and blue components unchanged.}
 
-@defproc[(map-image/extra
+@defproc*[([(map-image/extra [f (-> color? any/c color?)] [img image?] [extra any/c]) image?]
-         [f (-> natural-number/c natural-number/c color? any/c color?)] [img image?] [extra any/c]) image?]{
+	  [(map-image/extra [f (-> natural-number/c natural-number/c color? any/c color?)] [img image?] [extra any/c]) image?])]{
-Equivalent to @racketblock[(map-image (lambda (x y c) (f x y c extra)) img)]
+Passes the @racket[extra] argument in as an additional argument in each call
-In other words, it passes the @racket[extra] argument in as a fourth argument in each call
 to @racket[f].  This allows students who haven't learned closures yet to do pixel-by-pixel image
 manipulations inside a function depending on a parameter of that function.
 
 For example,
 @codeblock|{
+; clip-color : color number -> color
+(check-expect (clip-color (make-color 30 60 90) 100)
+	      (make-color 30 60 90))
+(check-expect (clip-color (make-color 30 60 90) 50)
+	      (make-color 30 50 50))
+(define (clip-color c limit)
+    (make-color (min limit (color-red c))
+		(min limit (color-green c))
+		(min limit (color-blue c))))
+
+; clip-picture-colors : number(limit) image -> image
+(define (clip-picture-colors limit pic)
+    (map-image/extra clip-color pic limit))
+}|
+
+This @racket[clip-picture-colors] function clips each of the
+color components at most to the specified limit.
+
+Another example, using x and y coordinates as well:
+@codeblock|{
 ; new-pixel : number(x) number(y) color height -> color
 (check-expect (new-pixel 36 100 (make-color 30 60 90) 100)
               (make-color 30 60 255))

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

@@ -10,6 +10,10 @@
 ; Dec. 28, 2010: Robby added alphas into the "color" type, and provided an implementation
 ; of map-image.  He recommends using racket/draw bitmaps rather than 2htdp/image bitmaps.
 ; May 10, 2011: added build-image/extra and map-image/extra.
+; Dec 1, 2011: allowed map-image and map-image/extra to give their
+; 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.
 
 (require racket/draw
         racket/snip
@@ -288,21 +292,27 @@
 
 ; map-image : (int int color -> broad-color) image -> image
 (define (map-image f img)
-  (check-procedure-arity f 3 'map-image "Expected a function with contract num(x) num(y) color -> color as first argument")
   (unless (image? img)
     (error 'map-image
 	(format "Expected an image as second argument, but received ~v" img)))
-  (map-image-internal (colorize-func f) img))
+  (cond [(procedure-arity-includes? f 3)
+         (map-image-internal (colorize-func f) img)]
+        [(procedure-arity-includes? f 1)            ; allow f : color->color as a simple case
+         (map-image-internal (colorize-func (lambda (x y c) (f c))) img)]
+        [else (error 'map-image "Expected a function of one or three parameters as first argument")]))
 
 ; map-image/extra : (nat nat color X -> broad-color) image X -> image
 ; Like map-image, but passes a fixed extra argument to every call of the function.
 ; For students who don't yet know function closures.
 (define (map-image/extra f img extra)
-  (check-procedure-arity f 4 'map-image/extra "Expected a function with contract num(x) num(y) color other -> color as first argument")
   (unless (image? img)
     (error 'map-image/extra
 	(format "Expected an image as second argument, but received ~v" img)))
-  (map-image-internal (colorize-func (lambda (x y c) (f x y c extra))) img))
+  (cond [(procedure-arity-includes? f 4)
+         (map-image-internal (colorize-func (lambda (x y c) (f x y c extra))) img)]
+        [(procedure-arity-includes? f 2)
+         (map-image-internal (colorize-func (lambda (x y c) (f c extra))) img)]
+        [else (error 'map-image/extra "Expected a function taking two or four parameters as first argument")]))
 
 
 

collects/picturing-programs/tests/map-image-bsl-tests.rkt

@@ -151,8 +151,8 @@
 ; Test cases for map-image:
 ;(check-error (map-image 5 pic:bloch)
 ;             "map-image: Expected a function with contract num(x) num(y) color -> color as first argument")
-(check-error (map-image sqrt pic:bloch)
+(check-error (map-image make-posn pic:bloch)
-             "map-image: Expected a function with contract num(x) num(y) color -> color as first argument")
+             "map-image: Expected a function of one or three parameters as first argument")
 (check-error (map-image + 5)
              "map-image: Expected an image as second argument, but received 5")
 
@@ -165,6 +165,8 @@
   (make-color 0 (color-green c) (color-blue c)))
 (define (kill-red-preserving-alpha x y c)
   (make-color 0 (color-green c) (color-blue c) (color-alpha c)))
+(define (kill-red-without-xy c)
+  (make-color 0 (color-green c) (color-blue c) (color-alpha c)))
 
 ; make-gradient : x y color -> color
 (define (make-gradient x y c)
@@ -177,6 +179,8 @@
 (define ex2 (map-image kill-red tri)) ex2
 "(map-image kill-red-preserving-alpha tri):"
 (define ex2prime (map-image kill-red-preserving-alpha tri)) ex2prime
+"(map-image kill-red-ignoring-xy tri):"
+(define ex2again (map-image kill-red-without-xy tri)) ex2again
 "(map-image make-gradient tri):"
 (define ex3 (map-image make-gradient tri)) ex3
 "(map-image kill-red hieroglyphics): should be on an opaque background with no red"
@@ -185,6 +189,9 @@
 (define ex5 (map-image kill-red scheme-logo)) ex5
 "(map-image kill-red bloch):"
 (define ex6 (map-image kill-red bloch)) ex6
+"(map-image kill-red-without-xy bloch) (should look the same):"
+(define ex7 (map-image kill-red-without-xy bloch)) ex7
+
 (define (return-5 x y c) 5)
 
 (check-error (map-image return-5 bloch) "colorize: Expected a color, but received 5")
@@ -236,6 +243,13 @@
 "(build-image (image-width bloch) (image-height bloch) other-bloch-pixel): should be flipped vertically"
 (build-image (image-width bloch) (image-height bloch) other-bloch-pixel)
 
+(define (other-pixel x y pic)
+  (get-pixel-color x (- (image-height pic) y 1) pic))
+(define (my-flip pic)
+  (build-image/extra (image-width pic) (image-height pic) other-pixel pic))
+
+"(my-flip pic:hieroglyphics):"
+(my-flip pic:hieroglyphics)
 
 
 (define RADIUS 3)
@@ -273,8 +287,9 @@ fuzzy-bloch
 fuzzy-tri
 
 ; Convert all white pixels to transparent
-(define (white-pixel->trans x y old-color)
+(define (white-pixel->trans old-color)
-  (if (color=? old-color "white")
+  (if (> (+ (color-red old-color) (color-green old-color) (color-blue old-color))
+         750)
       false
       old-color))
 (define (white->trans pic)
@@ -287,9 +302,9 @@ fuzzy-tri
 (overlay hier (rectangle 100 100 "solid" "blue"))
 
 ; pixel->gray : x y color -> color
-(check-expect (pixel->gray 3 17 (make-color 0 0 0)) (make-color 0 0 0))
+(check-expect (pixel->gray (make-color 0 0 0)) (make-color 0 0 0))
-(check-expect (pixel->gray 92 4 (make-color 50 100 150)) (make-color 100 100 100))
+(check-expect (pixel->gray (make-color 50 100 150)) (make-color 100 100 100))
-(define (pixel->gray x y c)
+(define (pixel->gray c)
   (make-gray (quotient (+ (color-red c)
                           (color-green c) 
                           (color-blue c))
@@ -312,9 +327,9 @@ fuzzy-tri
 (overlay (color->gray (white->trans hieroglyphics)) bluebox)
 
 ; invert-pixel : x y color -> color
-(check-expect (invert-pixel 3 17 (make-color 0 0 0)) (make-color 255 255 255))
+(check-expect (invert-pixel (make-color 0 0 0)) (make-color 255 255 255))
-(check-expect (invert-pixel 92 4 (make-color 50 100 150)) (make-color 205 155 105))
+(check-expect (invert-pixel (make-color 50 100 150)) (make-color 205 155 105))
-(define (invert-pixel x y color)
+(define (invert-pixel color)
   (make-color (- 255 (color-red color))
               (- 255 (color-green color))
               (- 255 (color-blue color))))
@@ -329,6 +344,31 @@ fuzzy-tri
 
 ; Test cases for map-image/extra and build-image/extra:
 ; Exercise 27.4.1:
+
+; apply-threshold : number threshold -> number
+(check-expect (apply-threshold 100 200) 0)
+(check-expect (apply-threshold 100 100) 255)
+(check-expect (apply-threshold 100 75) 255)
+(define (apply-threshold component threshold)
+  (if (< component threshold)
+      0
+      255))
+; simple-new-pixel : color number(threshold) -> color
+; Converts color components below threshold to 0, and those >= threshold to 255.
+(check-expect (simple-new-pixel  (make-color 50 100 200) 150)
+              (make-color 0 0 255))
+(check-expect (simple-new-pixel (make-color 50 100 200) 90)
+              (make-color 0 255 255))
+(define (simple-new-pixel c threshold)
+  (make-color (apply-threshold (color-red c) threshold)
+              (apply-threshold (color-green c) threshold)
+              (apply-threshold (color-blue c) threshold)))
+"map-image/extra simple-new-pixel..."
+(map-image/extra simple-new-pixel pic:bloch 200)
+(map-image/extra simple-new-pixel pic:bloch 150)
+(map-image/extra simple-new-pixel pic:bloch 100)
+
+
 ; new-pixel : number(x) number(y) color height -> color
 (check-expect (new-pixel 36 100 (make-color 30 60 90) 100)
               (make-color 30 60 255))
@@ -402,3 +442,24 @@ fuzzy-tri
               (make-color 133 56 35))
 (check-expect (get-pixel-color 30 50 red-bloch)
               (make-color 255 173 149))
+
+; clip-color : color number -> color
+(check-expect (clip-color (make-color 30 60 90) 100)
+              (make-color 30 60 90))
+(check-expect (clip-color (make-color 30 60 90) 50)
+              (make-color 30 50 50))
+(define (clip-color c limit)
+    (make-color (min limit (color-red c))
+                (min limit (color-green c))
+                (min limit (color-blue c))))
+ 
+; clip-picture-colors : number(limit) image -> image
+(define (clip-picture-colors limit pic)
+    (map-image/extra clip-color pic limit))
+
+pic:bloch
+"clip-picture-colors..."
+(clip-picture-colors 240 pic:bloch)
+(clip-picture-colors 200 pic:bloch)
+(clip-picture-colors 150 pic:bloch)
+(clip-picture-colors 100 pic:bloch)

collects/picturing-programs/tests/map-image-isl-tests.rkt

@@ -68,7 +68,7 @@
 ; Convert all white pixels to transparent
 (define (white->trans pic)
   (local [(define white (name->color "white"))
-          (define (new-color x y old-color)
+          (define (new-color #; x #; y old-color) ; leave out x & y (dec2011)
             (if (equal? old-color white)
                 false
                 old-color))]