From 437ea70080df1caf065a99d2bbe27614ae1c27c2 Mon Sep 17 00:00:00 2001 From: Stephen Bloch Date: Tue, 28 Dec 2010 16:32:13 -0500 Subject: [PATCH] minor fixes --- collects/picturing-programs/map-image.rkt | 10 +- .../tests/map-image-bsl-tests.rkt | 191 ++++++++++++------ 2 files changed, 139 insertions(+), 62 deletions(-) diff --git a/collects/picturing-programs/map-image.rkt b/collects/picturing-programs/map-image.rkt index 128c854586..207614160b 100644 --- a/collects/picturing-programs/map-image.rkt +++ b/collects/picturing-programs/map-image.rkt @@ -301,15 +301,15 @@ ; where each of rfunc, gfunc, bfunc is (nat(x) nat(y) -> nat) (define (build3-image w h rfunc gfunc bfunc) (unless (natural? w) - (error 'build-image "Expected natural number as first argument")) + (error 'build3-image "Expected natural number as first argument")) (unless (natural? h) - (error 'build-image "Expected natural number as second argument")) + (error 'build3-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")) + (error 'build3-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")) + (error 'build3-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")) + (error '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))))) diff --git a/collects/picturing-programs/tests/map-image-bsl-tests.rkt b/collects/picturing-programs/tests/map-image-bsl-tests.rkt index 606b7c94f9..28c9cca20d 100755 --- a/collects/picturing-programs/tests/map-image-bsl-tests.rkt +++ b/collects/picturing-programs/tests/map-image-bsl-tests.rkt @@ -5,17 +5,6 @@ (require picturing-programs/map-image) (require 2htdp/image) -;(define (always-red x y) (name->color "red")) -;"(build-image 50 35 (lambda (x y) red)):" -;(build-image 50 35 always-red) -;"should be a 50x35 red rectangle" -;(define (a-gradient x y) (make-color (real->int (* x 2.5)) -; (real->int (* y 2.5)) -; 0)) -;"(build-image 100 100 (lambda (x y) (make-color (* x 2.5) (* y 2.5) 0))):" -;(build-image 100 100 a-gradient) -;"should be a 100x100 square with a color gradient increasing in red from left to right, and in green from top to bottom" - ; Test cases for primitives: (check-expect (real->int 3.2) 3) (check-expect (real->int 3.7) 4) @@ -37,6 +26,7 @@ (check-expect (name->color "black") (make-color 0 0 0)) (check-expect (name->color "blue") (make-color 0 0 255)) (check-expect (name->color "plaid") false) +(check-error (name->color 7) "name->color: argument must be a string or symbol") (check-expect (color=? (make-color 5 10 15) (make-color 5 10 15)) true) (check-expect (color=? (make-color 5 10 15) (make-color 5 15 10)) false) @@ -48,6 +38,8 @@ (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" "plaid") "color=?: Expected two colors or color names as arguments") ; Test cases for map3-image: @@ -74,19 +66,57 @@ "(map3-image zero-5-args green-id blue-id bloch) should be a de-redded Steve Bloch:" (map3-image zero-5-args green-id blue-id bloch) -; gradient-g : x y r g b -> num -(define (gradient-g x y r g b) (min 255 (* 4 x))) -; gradient-b : x y r g b -> num -(define (gradient-b x y r g b) (min 255 (* 4 y))) -"(map3-image zero-5-args gradient-g gradient-b tri) should be a triangular window on a 2-dimensional color gradient:" -(map3-image zero-5-args gradient-g gradient-b tri) +; x-gradient-5 : x y r g b -> num +(define (x-gradient-5 x y r g b) (min 255 (* 4 x))) +; y-gradient-5 : x y r g b -> num +(define (y-gradient-5 x y r g b) (min 255 (* 4 y))) +"(map3-image zero-5-args x-gradient-5 y-gradient-5 tri) should be a triangular window on a 2-dimensional color gradient:" +(map3-image zero-5-args x-gradient-5 y-gradient-5 tri) "The same thing with some red:" -(map3-image red-id gradient-g gradient-b tri) +(map3-image red-id x-gradient-5 y-gradient-5 tri) "And now let's try it on bloch. Should get a rectangular 2-dimensional color gradient:" -(map3-image zero-5-args gradient-g gradient-b bloch) +(map3-image zero-5-args x-gradient-5 y-gradient-5 bloch) "The same thing preserving the red:" -(map3-image red-id gradient-g gradient-b bloch) +(map3-image red-id x-gradient-5 y-gradient-5 bloch) +"Rotating colors r->g->b->r:" +(map3-image blue-id red-id green-id bloch) +; Test cases for map4-image: +; 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 +(define (green-id6 x y r g b a) g) +; blue-id6 : x y r g b a -> num +(define (blue-id6 x y r g b a) b) +; alpha-id6 : x y r g b a -> num +(define (alpha-id6 x y r g b a) a) +; zero-6-args : x y r g b a -> num +(define (zero-6-args x y r g b a) 0) +; + +"tri:" tri +"(map4-image red-id6 green-id6 blue-id6 alpha-id6 tri) should be tri:" +(map4-image red-id6 green-id6 blue-id6 alpha-id6 tri) +"(map4-image zero-6-args green-id6 blue-id6 alpha-id6 tri) should be a green triangle:" +(map4-image zero-6-args green-id6 blue-id6 alpha-id6 tri) + +"(map4-image zero-6-args green-id6 blue-id6 alpha-id6 bloch) should be a de-redded Steve Bloch:" +(map4-image zero-6-args green-id6 blue-id6 alpha-id6 bloch) + +(define bluebox (rectangle 100 100 "solid" "light blue")) +; x-gradient-6 : x y r g b a -> num +(define (x-gradient-6 x y r g b a) (min 255 (* 4 x))) +; y-gradient-6 : x y r g b a -> num +(define (y-gradient-6 x y r g b a) (min 255 (* 4 y))) +"(map4-image zero-6-args x-gradient-6 y-gradient-6 alpha-id6 tri) should be a triangular window on a 2-dimensional color gradient, light blue background:" +(overlay (map4-image zero-6-args x-gradient-6 y-gradient-6 alpha-id6 tri) bluebox) +"(map4-image red-id green-id blue-id x-gradient-6 tri) should be a triangle with a 1-dimensional alpha gradient:" +(overlay (map4-image red-id6 green-id6 blue-id6 x-gradient-6 tri) bluebox) + +"Same thing on bloch:" +(overlay (map4-image red-id6 green-id6 blue-id6 x-gradient-6 bloch) bluebox) + +; Test cases for map-image: ; color-id : x y color -> color (define (color-id x y c) c) @@ -101,8 +131,6 @@ (define (make-gradient x y c) (make-color 0 (min (* 4 x) 255) (min (* 4 y) 255))) -(define (id x) x) - "tri:" tri "(map-image color-id tri):" (define ex1 (map-image color-id tri)) ex1 @@ -118,41 +146,90 @@ (define ex5 (map-image kill-red scheme-logo)) ex5 "(map-image kill-red bloch):" (define ex6 (map-image kill-red bloch)) ex6 +(define (return-5 x y c) 5) -;(define (other-bloch-pixel x y) -; (get-pixel-color x (- (image-height bloch) y) bloch)) -;(define flipped-bloch (build-image (image-width bloch) (image-height bloch) other-bloch-pixel)) -;flipped-bloch -; -; -;(define RADIUS 3) -; -;(define (clip-to n low high) -; (min (max n low) high)) -;(check-expect (clip-to 10 5 15) 10) -;(check-expect (clip-to 10 15 20) 15) -;(check-expect (clip-to 10 -20 7) 7) -; -;(define (near-bloch-pixel x y) -; (get-pixel-color -; (clip-to (+ x (- RADIUS) (random (+ 1 RADIUS RADIUS))) 0 (image-width bloch)) -; (clip-to (+ y (- RADIUS) (random (+ 1 RADIUS RADIUS))) 0 (image-height bloch)) -; bloch)) -; -;(define fuzzy-bloch -; (build-image (image-width bloch) (image-height bloch) near-bloch-pixel)) -;fuzzy-bloch -; -;(define (near-tri-mpixel x y) -; (if (pixel-visible? x y tri) -; (get-pixel-color -; (clip-to (+ x (- RADIUS) (random (+ 1 RADIUS RADIUS))) 0 (image-width tri)) -; (clip-to (+ y (- RADIUS) (random (+ 1 RADIUS RADIUS))) 0 (image-height tri)) -; tri) -; false)) -;(define fuzzy-tri -; (build-masked-image (image-width tri) (image-height tri) near-tri-mpixel)) -;fuzzy-tri +(check-error (map-image return-5 bloch) "colorize: Unrecognized type") + +; Test cases for build3-image: +(define (x-gradient-2 x y) (min 255 (* 4 x))) +(define (y-gradient-2 x y) (min 255 (* 4 y))) +(define (zero-2-args x y) 0) +"(build3-image 60 40 zero-2-args x-gradient-2 y-gradient-2) should be a 60x40 rectangle with no red, green increasing from left to right, and blue increasing from top to bottom:" +(build3-image 60 40 zero-2-args x-gradient-2 y-gradient-2) +(check-error (build3-image "hello" true sqrt sqrt sqrt) + "build3-image: Expected natural number as first argument") +(check-error (build3-image 17 true sqrt sqrt sqrt) + "build3-image: Expected natural number as second argument") +(check-error (build3-image 17 24 sqrt sqrt sqrt) + "build3-image: Expected function with contract num(x) num(y) -> color as third argument") +(check-error (build3-image 17 24 x-gradient-2 sqrt sqrt) + "build3-image: Expected function with contract num(x) num(y) -> color as fourth argument") +(check-error (build3-image 17 24 x-gradient-2 y-gradient-2 sqrt) + "build3-image: Expected function with contract num(x) num(y) -> color as fifth argument") + +(define (return-minus-5 x y) -5) +(check-error (build3-image 17 24 x-gradient-2 y-gradient-2 return-minus-5) + "make-color: expected as third argument, given: -5") + +; Test cases for build4-image: + +; Test cases for build-image: +(define (always-red x y) (name->color "red")) +"(build-image 50 35 (lambda (x y) red)):" +(build-image 50 35 always-red) +"should be a 50x35 red rectangle" +(define (a-gradient x y) (make-color (real->int (* x 2.5)) + (real->int (* y 2.5)) + 0)) +"(build-image 100 100 (lambda (x y) (make-color (* x 2.5) (* y 2.5) 0))):" +(build-image 100 100 a-gradient) +"should be a 100x100 square with a color gradient increasing in red from left to right, and in green from top to bottom" +(check-error (build-image 3.2 100 a-gradient) "build-image: Expected natural number as first argument") +(check-error (build-image 100 -2 a-gradient) "build-image: Expected natural number as second argument") +(check-error (build-image 100 100 sqrt) "build-image: Expected function with contract num(x) num(y) -> color as third argument") + + + +(define (other-bloch-pixel x y) + (get-pixel-color x (- (image-height bloch) y 1) bloch)) +"(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 RADIUS 3) + +(define (clip-to n low high) + (min (max n low) high)) +(check-expect (clip-to 10 5 15) 10) +(check-expect (clip-to 10 15 20) 15) +(check-expect (clip-to 10 -20 7) 7) + +(define (near-bloch-pixel x y) + (get-pixel-color + (clip-to (+ x (- RADIUS) (random (+ 1 RADIUS RADIUS))) 0 (sub1 (image-width bloch))) + (clip-to (+ y (- RADIUS) (random (+ 1 RADIUS RADIUS))) 0 (sub1 (image-height bloch))) + bloch)) + +"fuzzy bloch, radius=3, not adjusting size of image:" +(define fuzzy-bloch + (build-image (image-width bloch) (image-height bloch) near-bloch-pixel)) +fuzzy-bloch + +(define (near-tri-mpixel x y) + (get-pixel-color + (clip-to (+ x (- RADIUS) (random (+ 1 RADIUS RADIUS))) + 0 (+ RADIUS RADIUS -1 (image-width tri))) + (clip-to (+ y (- RADIUS) (random (+ 1 RADIUS RADIUS))) + 0 (+ RADIUS RADIUS -1 (image-height tri))) + tri) + ) +(define fuzzy-tri + (build-image (+ RADIUS RADIUS (image-width tri)) + (+ RADIUS RADIUS (image-height tri)) + near-tri-mpixel)) +"fuzzy triangle, radius=3, adjusting size of image to allow fuzz on all sides:" +fuzzy-tri ; Convert all white pixels to transparent (define (white-pixel->trans x y old-color) @@ -193,4 +270,4 @@ (map-image pixel->gray pic)) (color->gray bloch) -(color->gray hieroglyphics) \ No newline at end of file +(color->gray hieroglyphics)