diff --git a/collects/picturing-programs/picturing-programs.scrbl b/collects/picturing-programs/picturing-programs.scrbl index 288e1e5122..ee16b122a9 100644 --- a/collects/picturing-programs/picturing-programs.scrbl +++ b/collects/picturing-programs/picturing-programs.scrbl @@ -201,19 +201,46 @@ the bounds of the image, returns a transparent color.} Builds an image of the specified size and shape by calling the specified function on the coordinates of each pixel. For example, -@racketblock[ - (define (fuzz pic) - (local [(define (near-pixel x y) - (get-pixel-color (+ x -3 (random 7)) - (+ y -3 (random 7)) - pic))] - (build-image (image-width pic) - (image-height pic) - near-pixel))) - ] +@codeblock|{ +; fuzz : image -> image +(define (fuzz pic) + (local [; near-pixel : num(x) num(y) -> color + (define (near-pixel x y) + (get-pixel-color (+ x -3 (random 7)) + (+ y -3 (random 7)) + pic))] + (build-image (image-width pic) + (image-height pic) + near-pixel))) +}| produces a fuzzy version of the given picture by replacing each pixel with a randomly chosen pixel near it.} +@defproc[(build-image/extra + [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 +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, the above @racket[fuzz] example could also be written as +@codeblock|{ +; near-pixel : number(x) number(y) image -> color +(define (near-pixel x y pic) + (get-pixel-color (+ x -3 (random 7)) + (+ y -3 (random 7)) + pic)) +; fuzz : image -> image +(define (fuzz pic) + (build-image/extra (image-width pic) + (image-height pic) + near-pixel + pic)) +}| +} + @defproc[(build4-image [width natural-number/c] [height natural-number/c] [red-function (-> natural-number/c natural-number/c natural-number/c)] [green-function (-> natural-number/c natural-number/c natural-number/c)] @@ -238,11 +265,12 @@ Just like @racket[build4-image], but without specifying the alpha component Applies the given function to each pixel in a given image, producing a new image the same size and shape. For example, -@racketblock[ - (define (lose-red x y old-color) - (make-color 0 (color-green old-color) (color-blue old-color))) +@codeblock|{ +; lose-red : num(x) num(y) color -> color +(define (lose-red x y old-color) + (make-color 0 (color-green old-color) (color-blue old-color))) - (map-image lose-red my-picture)] +(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. @@ -255,17 +283,45 @@ that was in the original image. To preserve this information, one could write old-color)))] Another example: -@racketblock[ - (define (apply-gradient x y old-color) - (make-color (min (* 3 x) 255) - 0 - (min (* 3 y) 255))) +@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))) - (map-image apply-gradient my-picture)] +(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.} +@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 +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|{ +; 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)) +(check-expect (new-pixel 58 40 (make-color 30 60 90) 100) + (make-color 30 60 102)) +(define (new-pixel x y c h) + (make-color (color-red c) + (color-green c) + (real->int (* 255 (/ y h))))) + +; apply-blue-gradient : image -> image +(define (apply-blue-gradient pic) + (map-image/extra new-pixel pic (image-height pic))) +}| +This @racket[apply-blue-gradient] function changes the blue component of an image to increase gradually +from the top to the bottom of the image, (almost) reaching 255 at the bottom of the image. +} + @defproc[(map4-image [red-func (-> natural-number/c natural-number/c natural-number/c natural-number/c natural-number/c natural-number/c natural-number/c)] [green-func (-> natural-number/c natural-number/c natural-number/c natural-number/c natural-number/c natural-number/c natural-number/c)] @@ -284,20 +340,22 @@ The results of the four functions are used as the red, green, blue, and alpha components in the corresponding pixel of the resulting picture. For example, -@racketblock[ +@codeblock{| +; each function : num(x) num(y) num(r) num(g) num(b) num(a) -> num (define (zero x y r g b a) 0) (define (same-g x y r g b a) g) (define (same-b x y r g b a) b) (define (same-alpha x y r g b a) a) -(map4-image zero same-g same-b same-alpha my-picture)] +(map4-image zero same-g same-b same-alpha my-picture)}| produces a copy of @racket[my-picture] with all the red leached out, leaving only the blue, green, and alpha components. -@racketblock[ +@codeblock|{ +; each function : num(x) num(y) num(r) num(g) num(b) num(a) -> num (define (3x x y r g b a) (min (* 3 x) 255)) (define (3y x y r g b a) (min (* 3 y) 255)) (define (return-255 x y r g b a) 255) -(map4-image 3x zero 3y return-255 my-picture)] +(map4-image 3x zero 3y return-255 my-picture)}| produces an opaque 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. @@ -320,18 +378,20 @@ corresponding pixel of the resulting picture. The alpha component in the resulting picture is copied from the source picture. For example, -@racketblock[ +@codeblock|{ +; each function : num(x) num(y) num(r) num(g) num(b) -> num (define (zero x y r g b) 0) (define (same-g x y r g b) g) (define (same-b x y r g b) b) -(map3-image zero same-g same-b my-picture)] +(map3-image zero same-g same-b my-picture)}| produces a copy of @racket[my-picture] with all the red leached out; parts of the picture that were transparent are still transparent, and parts that were dithered are still dithered. -@racketblock[ +@codeblock|{ +; each function : num(x) num(y) num(r) num(g) num(b) num(a) -> num (define (3x x y r g b a) (min (* 3 x) 255)) (define (3y x y r g b a) (min (* 3 y) 255)) -(map3-image zero 3x 3y my-picture)] +(map3-image zero 3x 3y my-picture)}| produces a @racket[my-picture]-shaped "window" on a color-gradient. } @@ -339,14 +399,17 @@ produces a @racket[my-picture]-shaped "window" on a color-gradient. integer?]{ Not specific to colors, but useful if you're building colors by arithmetic. For example, -@racketblock[ - (define (bad-gradient x y) - (make-color (* 2.5 x) (* 1.6 y) 0)) - (build-image 50 30 bad-gradient) - (define (good-gradient x y) - (make-color (real->int (* 2.5 x)) (real->int (* 1.6 y)) 0)) - (build-image 50 30 good-gradient) - ] +@codeblock|{ +; bad-gradient : num(x) num(y) -> color +(define (bad-gradient x y) + (make-color (* 2.5 x) (* 1.6 y) 0)) +(build-image 50 30 bad-gradient) + +; good-gradient : num(x) num(y) -> color +(define (good-gradient x y) + (make-color (real->int (* 2.5 x)) (real->int (* 1.6 y)) 0)) +(build-image 50 30 good-gradient) +}| The version using @racket[bad-gradient] crashes because color components must be exact integers. The version using @racket[good-gradient] works.} @@ -396,16 +459,18 @@ Web page at the specified URL rather than from the keyboard.} Combines @racket[with-input-from-string] and @racket[with-output-to-string]: calls @tt{thunk} with its input coming from @tt{input} and accumulates its output into a string, which is returned. Especially useful for testing: -@racketblock[ - (define (ask question) - (begin (display question) - (read))) - (define (greet) - (local [(define name (ask "What is your name?"))] - (printf "Hello, ~a!" name))) - (check-expect - (with-io-strings "Steve" greet) - "What is your name?Hello, Steve!")] +@codeblock|{ +; ask : string -> prints output, waits for text input, returns it +(define (ask question) + (begin (display question) + (read))) +; greet : nothing -> prints output, waits for text input, prints output +(define (greet) + (local [(define name (ask "What is your name?"))] + (printf "Hello, ~a!" name))) +(check-expect + (with-io-strings "Steve" greet) + "What is your name?Hello, Steve!")}| } @; @include-section{worlds.scrbl} diff --git a/collects/picturing-programs/private/map-image.rkt b/collects/picturing-programs/private/map-image.rkt index 3e78913bc1..5136053ea3 100644 --- a/collects/picturing-programs/private/map-image.rkt +++ b/collects/picturing-programs/private/map-image.rkt @@ -9,6 +9,7 @@ ; Dec. 26, 2010: API for bitmaps has changed for 5.1, so I need to rewrite to match it. ; 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. (require racket/draw racket/snip @@ -41,6 +42,17 @@ (provide-higher-order-primitive build3-image (_ _ rfunc gfunc bfunc)) (provide-higher-order-primitive build4-image (_ _ rfunc gfunc bfunc afunc)) ;(provide-higher-order-primitive build-masked-image (_ _ f)) +(provide-higher-order-primitive build-image/extra (_ _ f _)) +(provide-higher-order-primitive map-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 +; catch non-procedure arguments before the "(and (procedure? f) ..." test ever sees them, +; but that's no longer true if you invoke them from an ISLL, ASL, or racket program, +; so I'm keeping the test. +(define (check-procedure-arity f n func-name msg) + (unless (and (procedure? f) (procedure-arity-includes? f n)) + (error func-name msg))) (define transparent (make-color 0 0 0 0)) @@ -88,7 +100,7 @@ (cond [(color? thing) thing] [(eqv? thing #f) transparent] [(image-color? thing) (name->color thing)] - [else (error 'colorize "Unrecognized type")])) + [else (error 'colorize (format "~v is not a color" thing))])) ; colorize-func : (... -> broad-color) -> (... -> color) (define (colorize-func f) @@ -199,10 +211,21 @@ (error 'build-image "Expected natural number as first argument")) (unless (natural? h) (error 'build-image "Expected natural number as second argument")) - (unless (procedure-arity-includes? f 2) - (error 'build-image "Expected function with contract num(x) num(y) -> color as third argument")) + (check-procedure-arity f 2 'build-image "Expected function with contract num(x) num(y) -> color as third argument") (build-image-internal w h (colorize-func f))) +; build-image/extra : natural(width) natural(height) (nat nat any -> broad-color) any -> image +; Like build-image, but passes a fixed extra argument to every call of the function. +; For students who don't yet know function closures. +(define (build-image/extra w h f extra) + (unless (natural? w) + (error 'build-image/extra "Expected natural number as first argument")) + (unless (natural? h) + (error 'build-image/extra "Expected natural number as second argument")) + (check-procedure-arity f 3 'build-image/extra "Expected function with contract num(x) num(y) any -> color as third argument") + (build-image-internal w h + (colorize-func (lambda (x y) (f x y extra))))) + ; build3-image : nat(width) nat(height) rfunc gfunc bfunc -> image ; where each of rfunc, gfunc, bfunc is (nat(x) nat(y) -> nat) (define (build3-image w h rfunc gfunc bfunc) @@ -210,12 +233,9 @@ (error 'build3-image "Expected natural number as first argument")) (unless (natural? h) (error 'build3-image "Expected natural number as second argument")) - (unless (procedure-arity-includes? rfunc 2) - (error 'build3-image "Expected function with contract num(x) num(y) -> color as third argument")) - (unless (procedure-arity-includes? gfunc 2) - (error 'build3-image "Expected function with contract num(x) num(y) -> color as fourth argument")) - (unless (procedure-arity-includes? bfunc 2) - (error 'build3-image "Expected function with contract num(x) num(y) -> color as fifth argument")) + (check-procedure-arity rfunc 2 'build3-image "Expected function with contract num(x) num(y) -> color as third argument") + (check-procedure-arity gfunc 2 'build3-image "Expected function with contract num(x) num(y) -> color as fourth argument") + (check-procedure-arity bfunc 2 'build3-image "Expected function with contract num(x) num(y) -> color as fifth argument") (build-image-internal w h (lambda (x y) (make-color (rfunc x y) (gfunc x y) (bfunc x y))))) @@ -227,14 +247,10 @@ (error 'build-image "Expected natural number as first argument")) (unless (natural? h) (error 'build-image "Expected natural number as second argument")) - (unless (procedure-arity-includes? rfunc 2) - (error 'build-image "Expected function with contract num(x) num(y) -> color as third argument")) - (unless (procedure-arity-includes? gfunc 2) - (error 'build-image "Expected function with contract num(x) num(y) -> color as fourth argument")) - (unless (procedure-arity-includes? bfunc 2) - (error 'build-image "Expected function with contract num(x) num(y) -> color as fifth argument")) - (unless (procedure-arity-includes? afunc 2) - (error 'build-image "Expected function with contract num(x) num(y) -> color as sixth argument")) + (check-procedure-arity rfunc 2 'build-image "Expected function with contract num(x) num(y) -> color as third argument") + (check-procedure-arity gfunc 2 'build-image "Expected function with contract num(x) num(y) -> color as fourth argument") + (check-procedure-arity bfunc 2 'build-image "Expected function with contract num(x) num(y) -> color as fifth argument") + (check-procedure-arity afunc 2 'build-image "Expected function with contract num(x) num(y) -> color as sixth argument") (build-image-internal w h (lambda (x y) (make-color (rfunc x y) (gfunc x y) (bfunc x y) (afunc x y))))) @@ -259,12 +275,23 @@ ; map-image : (int int color -> broad-color) image -> image (define (map-image f img) - (unless (procedure-arity-includes? f 3) - (error 'map-image "Expected function with contract num(x) num(y) color -> color as first argument")) + (check-procedure-arity f 3 'map-image "Expected function with contract num(x) num(y) color -> color as first argument") (unless (image? img) (error 'map-image "Expected image as second argument")) (map-image-internal (colorize-func f) img)) +; 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 function with contract num(x) num(y) color other -> color as first argument") + (unless (image? img) + (error 'map-image/extra "Expected image as second argument")) + (map-image-internal (colorize-func (lambda (x y c) (f x y c extra))) img)) + + + + ; The version for use before students have seen structs: ; map3-image : ; (int(x) int(y) int(r) int(g) int(b) -> int(r)) @@ -273,12 +300,9 @@ ; image -> image ; Note: by default, preserves alpha values from old image. (define (map3-image rfunc gfunc bfunc pic) - (unless (procedure-arity-includes? rfunc 5) - (error 'map3-image "Expected function with contract num(x) num(y) num(r) num(g) num(b) -> num(r) as first argument")) - (unless (procedure-arity-includes? gfunc 5) - (error 'map3-image "Expected function with contract num(x) num(y) num(r) num(g) num(b) -> num(g) as second argument")) - (unless (procedure-arity-includes? bfunc 5) - (error 'map3-image "Expected function with contract num(x) num(y) num(r) num(g) num(b) -> num(b) as third argument")) + (check-procedure-arity rfunc 5 'map3-image "Expected function with contract num(x) num(y) num(r) num(g) num(b) -> num(r) as first argument") + (check-procedure-arity gfunc 5 'map3-image "Expected function with contract num(x) num(y) num(r) num(g) num(b) -> num(g) as second argument") + (check-procedure-arity bfunc 5 'map3-image "Expected function with contract num(x) num(y) num(r) num(g) num(b) -> num(b) as third argument") (unless (image? pic) (error 'map3-image "Expected image as fourth argument")) (map-image-internal @@ -296,14 +320,10 @@ ; (int(x) int(y) int(r) int(g) int(b) int(a) -> int(a)) ; image -> image (define (map4-image rfunc gfunc bfunc afunc pic) - (unless (procedure-arity-includes? rfunc 6) - (error 'map4-image "Expected function with contract num(x) num(y) num(r) num(g) num(b) num(alpha) -> num(r) as first argument")) - (unless (procedure-arity-includes? gfunc 6) - (error 'map4-image "Expected function with contract num(x) num(y) num(r) num(g) num(b) num(alpha) -> num(g) as second argument")) - (unless (procedure-arity-includes? rfunc 6) - (error 'map4-image "Expected function with contract num(x) num(y) num(r) num(g) num(b) num(alpha) -> num(b) as third argument")) - (unless (procedure-arity-includes? gfunc 6) - (error 'map4-image "Expected function with contract num(x) num(y) num(r) num(g) num(b) num(alpha) -> num(alpha) as fourth argument")) + (check-procedure-arity rfunc 6 'map4-image "Expected function with contract num(x) num(y) num(r) num(g) num(b) num(alpha) -> num(r) as first argument") + (check-procedure-arity gfunc 6 'map4-image "Expected function with contract num(x) num(y) num(r) num(g) num(b) num(alpha) -> num(g) as second argument") + (check-procedure-arity bfunc 6 'map4-image "Expected function with contract num(x) num(y) num(r) num(g) num(b) num(alpha) -> num(b) as third argument") + (check-procedure-arity afunc 6 'map4-image "Expected function with contract num(x) num(y) num(r) num(g) num(b) num(alpha) -> num(alpha) as fourth argument") (unless (image? pic) (error 'map4-image "Expected image as fifth argument")) (map-image-internal diff --git a/collects/picturing-programs/tests/map-image-bsl-tests.rkt b/collects/picturing-programs/tests/map-image-bsl-tests.rkt index a234482c1d..b031156fe3 100644 --- a/collects/picturing-programs/tests/map-image-bsl-tests.rkt +++ b/collects/picturing-programs/tests/map-image-bsl-tests.rkt @@ -1,6 +1,6 @@ ;; The first three lines of this file were inserted by DrRacket. They record metadata ;; about the language level of this file in a form that our tools can easily process. -#reader(lib "htdp-beginner-reader.ss" "lang")((modname map-image-bsl-tests) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ()))) +#reader(lib "htdp-beginner-reader.ss" "lang")((modname new.map-image-bsl-tests) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ()))) (require picturing-programs) ; Test cases for primitives: @@ -36,10 +36,25 @@ (check-expect (color=? (make-color 5 10 15 255) (make-color 5 10 15)) true) (check-expect (color=? (make-color 5 10 15 0) false) true) (check-expect (color=? (make-color 5 10 15 20) false) false) -(check-error (color=? "white" 3) "colorize: Unrecognized type") +(check-error (color=? "white" 3) "colorize: 3 is not a color") (check-error (color=? "white" "plaid") "color=?: Expected two colors or color names as arguments") ; Test cases for map3-image: +;(check-error (map3-image 5 + + pic:bloch) +; "map3-image: Expected function with contract num(x) num(y) num(r) num(g) num(b) -> num(r) as first argument") +; Actually, the above is caught by Check Syntax, before map3-image has a chance to check anything. +(check-error (map3-image sqrt + + pic:bloch) + "map3-image: Expected function with contract num(x) num(y) num(r) num(g) num(b) -> num(r) as first argument") +;(check-error (map3-image + 5 + pic:bloch) +; "map3-image: Expected function with contract num(x) num(y) num(r) num(g) num(b) -> num(g) as second argument") +(check-error (map3-image + sqrt + pic:bloch) + "map3-image: Expected function with contract num(x) num(y) num(r) num(g) num(b) -> num(g) as second argument") +;(check-error (map3-image + + 5 pic:bloch) +; "map3-image: Expected function with contract num(x) num(y) num(r) num(g) num(b) -> num(b) as third argument") +(check-error (map3-image + + sqrt pic:bloch) + "map3-image: Expected function with contract num(x) num(y) num(r) num(g) num(b) -> num(b) as third argument") +(check-error (map3-image + + + 5) + "map3-image: Expected image as fourth argument") ; red-id : x y r g b -> num (define (red-id x y r g b) r) @@ -81,6 +96,24 @@ (map3-image blue-id red-id green-id bloch) "Test cases for map4-image:" +;(check-error (map4-image 5 + + + pic:bloch) +; "map4-image: Expected function with contract num(x) num(y) num(r) num(g) num(b) -> num(r) as first argument") +(check-error (map4-image sqrt + + + pic:bloch) + "map4-image: Expected function with contract num(x) num(y) num(r) num(g) num(b) num(alpha) -> num(r) as first argument") +;(check-error (map4-image + 5 + + pic:bloch) +; "map4-image: Expected function with contract num(x) num(y) num(r) num(g) num(b) num(alpha) -> num(g) as second argument") +(check-error (map4-image + sqrt + + pic:bloch) + "map4-image: Expected function with contract num(x) num(y) num(r) num(g) num(b) num(alpha) -> num(g) as second argument") +;(check-error (map4-image + + 5 + pic:bloch) +; "map4-image: Expected function with contract num(x) num(y) num(r) num(g) num(b) num(alpha) -> num(b) as third argument") +(check-error (map4-image + + sqrt + pic:bloch) + "map4-image: Expected function with contract num(x) num(y) num(r) num(g) num(b) num(alpha) -> num(b) as third argument") +;(check-error (map4-image + + + 5 pic:bloch) +; "map4-image: Expected function with contract num(x) num(y) num(r) num(g) num(b) num(alpha) -> num(a) as fourth argument") +(check-error (map4-image + + + sqrt pic:bloch) + "map4-image: Expected function with contract num(x) num(y) num(r) num(g) num(b) num(alpha) -> num(alpha) as fourth argument") +(check-error (map4-image + + + + 5) + "map4-image: Expected image as fifth argument") ; red-id6 : x y r g b a -> num (define (red-id6 x y r g b a) r) ; green-id6 : x y r g b a -> num @@ -115,6 +148,13 @@ (overlay (map4-image red-id6 green-id6 blue-id6 x-gradient-6 bloch) bluebox) ; Test cases for map-image: +;(check-error (map-image 5 pic:bloch) +; "map-image: Expected function with contract num(x) num(y) color -> color as first argument") +(check-error (map-image sqrt pic:bloch) + "map-image: Expected function with contract num(x) num(y) color -> color as first argument") +(check-error (map-image + 5) + "map-image: Expected image as second argument") + ; color-id : x y color -> color (define (color-id x y c) c) @@ -146,7 +186,7 @@ (define ex6 (map-image kill-red bloch)) ex6 (define (return-5 x y c) 5) -(check-error (map-image return-5 bloch) "colorize: Unrecognized type") +(check-error (map-image return-5 bloch) "colorize: 5 is not a color") "Test cases for build3-image:" (define (x-gradient-2 x y) (min 255 (* 4 x))) @@ -241,13 +281,6 @@ fuzzy-tri white-pixel->trans pic)) -(define (white-pixel->red x y old-color) - (if (color=? old-color 'white) - "red" - old-color)) -(define (white->red pic) - (map-image white-pixel->red pic)) - "(overlay (white->trans hieroglyphics) (rectangle 100 100 'solid 'blue)):" (define hier (white->trans hieroglyphics)) (overlay hier (rectangle 100 100 "solid" "blue")) @@ -275,4 +308,58 @@ fuzzy-tri "(overlay (color->gray hieroglyphics) bluebox):" (overlay (color->gray hieroglyphics) bluebox) "(overlay (color->gray (white->trans hieroglyphics)) bluebox):" -(overlay (color->gray (white->trans hieroglyphics)) bluebox) \ No newline at end of file +(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) + (make-color (- 255 (color-red color)) + (- 255 (color-green color)) + (- 255 (color-blue color)))) + +; invert-pic : image -> image +(define (invert-pic pic) + (map-image invert-pixel pic)) + +(check-expect (invert-pic (rectangle 30 20 "solid" "red")) + (rectangle 30 20 "solid" (make-color 0 255 255))) +(invert-pic pic:bloch) "should be Dr. Bloch in photonegative" + +; Test cases for map-image/extra and build-image/extra: +; Exercise 27.4.1: +; 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)) +(check-expect (new-pixel 58 40 (make-color 30 60 90) 100) + (make-color 30 60 102)) +(define (new-pixel x y c h) + ; x number + ; y number + ; c color + ; h number + (make-color (color-red c) + (color-green c) + (real->int (* 255 (/ y h))))) + +; apply-blue-gradient : image -> image +(define (apply-blue-gradient pic) + (map-image/extra new-pixel pic (image-height pic))) + +(apply-blue-gradient pic:bloch) +"should be Dr. Bloch with an amount of blue increasing steadily from top to bottom" +(apply-blue-gradient (rectangle 40 60 "solid" "red")) +"should be a rectangle shading from red at the top to purple at the bottom" + +; flip-pixel : num(x) num(y) image -> color +(define (flip-pixel x y pic) + (if (>= x y) + (get-pixel-color x y pic) + (get-pixel-color y x pic))) + +(define (diag-mirror pic) + (build-image/extra (image-width pic) (image-width pic) flip-pixel pic)) + +(diag-mirror pic:bloch) +"should be the upper-right corner of Dr. Bloch's head, mirrored to the lower-left" +