diff --git a/collects/picturing-programs/picturing-programs.scrbl b/collects/picturing-programs/picturing-programs.scrbl index eb68b9022b..9140875950 100644 --- a/collects/picturing-programs/picturing-programs.scrbl +++ b/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)))] -In other words, it passes the @racket[extra] argument in as a third argument in each call +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?]) - image?]{ +@defproc*[([(map-image [f (-> color? color?)] [img 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 -size and shape. For example, +An example with a 1-parameter function: @codeblock|{ -; lose-red : num(x) num(y) color -> color -(define (lose-red x y old-color) +; lose-red : color -> 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 - (min (* 3 y) 255))) + (color-green old-color) + (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 -right and blue increasing from top to bottom.} +replacing the red component with a smooth color gradient increasing +from left to right, but with the green and blue components unchanged.} -@defproc[(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)] -In other words, it passes the @racket[extra] argument in as a fourth argument in each call +@defproc*[([(map-image/extra [f (-> 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?])]{ +Passes the @racket[extra] argument in as an additional 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)) diff --git a/collects/picturing-programs/private/map-image.rkt b/collects/picturing-programs/private/map-image.rkt index d9ac2bc1d7..1c75f41e28 100644 --- a/collects/picturing-programs/private/map-image.rkt +++ b/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")])) diff --git a/collects/picturing-programs/tests/map-image-bsl-tests.rkt b/collects/picturing-programs/tests/map-image-bsl-tests.rkt index 56fde09b55..faa4685ab1 100644 --- a/collects/picturing-programs/tests/map-image-bsl-tests.rkt +++ b/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) - "map-image: Expected a function with contract num(x) num(y) color -> color as first argument") +(check-error (map-image make-posn pic:bloch) + "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) - (if (color=? old-color "white") +(define (white-pixel->trans old-color) + (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 92 4 (make-color 50 100 150)) (make-color 100 100 100)) -(define (pixel->gray x y c) +(check-expect (pixel->gray (make-color 0 0 0)) (make-color 0 0 0)) +(check-expect (pixel->gray (make-color 50 100 150)) (make-color 100 100 100)) +(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 92 4 (make-color 50 100 150)) (make-color 205 155 105)) -(define (invert-pixel x y color) +(check-expect (invert-pixel (make-color 0 0 0)) (make-color 255 255 255)) +(check-expect (invert-pixel (make-color 50 100 150)) (make-color 205 155 105)) +(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) \ No newline at end of file diff --git a/collects/picturing-programs/tests/map-image-isl-tests.rkt b/collects/picturing-programs/tests/map-image-isl-tests.rkt index 62b62166c6..47ec0e82d3 100644 --- a/collects/picturing-programs/tests/map-image-isl-tests.rkt +++ b/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))]