minor fixes
This commit is contained in:
Stephen Bloch
parent
fb05266ad2
commit
437ea70080
|
|
@ -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)))))
|
||||
|
|
|
|||
|
|
@ -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 <integer between 0 and 255> 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)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user