Added some illegal-argument tests to map-image.rkt.
Added test cases for these to map-image-bsl-tests.rkt. Modified an error message from colorize, and its test cases. Added map-image/extra and build-image/extra functions.
This commit is contained in:
Stephen Bloch
parent
1db3ae3476
commit
79778e0a1e
|
|
@ -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}
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
(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"
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user