suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fixed a bug found by random testing

Browse Source
This commit is contained in:
Robby Findler 2010-08-22 20:33:30 -05:00
parent 720a86052f
commit 8d2db5f4bf
3 changed files with 85 additions and 53 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

62
collects/2htdp/private/image-more.rkt
View File

@ -281,13 +281,13 @@
;; crops an image to be w x h from (x,y)
(define/chk (crop x1 y1 width height image)
(check-arg 'crop
(x1 . <= . (image-width image))
(format "number that is smaller than the width (~a)" (image-width image))
(<= 0 x1 (image-width image))
(format "number that is between 0 than the width (~a)" (image-width image))
1
x1)
(check-arg 'crop
(y1 . <= . (image-height image))
(format "number that is smaller than the width (~a)" (image-width image))
(<= 0 y1 (image-height image))
(format "number that is between 0 and the height (~a)" (image-height image))
2
y1)
(let ([w (min width (- (image-width image) x1))]
@ -295,14 +295,12 @@
(crop/internal x1 y1 w h image)))
(define (crop/internal x1 y1 width height image)
(let* ([iw (min width (get-right image))]
[ih (min height (get-bottom image))]
[points (rectangle-points iw ih)])
(let* ([points (rectangle-points width height)])
(make-image (make-crop points
(make-translate (- x1) (- y1) (image-shape image)))
(make-bb iw
ih
(min ih (get-baseline image)))
(make-bb width
height
(min height (get-baseline image)))
#f)))
;; place-image : image x y scene -> scene
@ -432,19 +430,19 @@
(translate-dy simple-shape))))])
(make-translate dx dy rotated)))]))
(define-struct ltrb (left top right bottom))
(struct ltrb (left top right bottom) #:transparent)
(define (union-ltrb ltrb1 ltrb2)
(make-ltrb (min (ltrb-left ltrb1) (ltrb-left ltrb2))
(min (ltrb-top ltrb1) (ltrb-top ltrb2))
(max (ltrb-right ltrb1) (ltrb-right ltrb2))
(max (ltrb-bottom ltrb1) (ltrb-bottom ltrb2))))
(ltrb (min (ltrb-left ltrb1) (ltrb-left ltrb2))
(min (ltrb-top ltrb1) (ltrb-top ltrb2))
(max (ltrb-right ltrb1) (ltrb-right ltrb2))
(max (ltrb-bottom ltrb1) (ltrb-bottom ltrb2))))
;; only intersection if they already overlap.
(define (intersect-ltrb ltrb1 ltrb2)
(make-ltrb (max (ltrb-left ltrb1) (ltrb-left ltrb2))
(max (ltrb-top ltrb1) (ltrb-top ltrb2))
(min (ltrb-right ltrb1) (ltrb-right ltrb2))
(min (ltrb-bottom ltrb1) (ltrb-bottom ltrb2))))
(ltrb (max (ltrb-left ltrb1) (ltrb-left ltrb2))
(max (ltrb-top ltrb1) (ltrb-top ltrb2))
(min (ltrb-right ltrb1) (ltrb-right ltrb2))
(min (ltrb-bottom ltrb1) (ltrb-bottom ltrb2))))
(define/contract (normalized-shape-bb shape)
(-> normalized-shape? ltrb?)
@ -477,33 +475,33 @@
[y1 (point-y (line-segment-start simple-shape))]
[x2 (point-x (line-segment-end simple-shape))]
[y2 (point-y (line-segment-end simple-shape))])
(make-ltrb (min x1 x2)
(min y1 y2)
(+ (max x1 x2) 1)
(+ (max y1 y2) 1)))]
(ltrb (min x1 x2)
(min y1 y2)
(+ (max x1 x2) 1)
(+ (max y1 y2) 1)))]
[(curve-segment? simple-shape)
(let ([x1 (point-x (curve-segment-start simple-shape))]
[y1 (point-y (curve-segment-start simple-shape))]
[x2 (point-x (curve-segment-end simple-shape))]
[y2 (point-y (curve-segment-end simple-shape))])
(make-ltrb (min x1 x2)
(min y1 y2)
(+ (max x1 x2) 1)
(+ (max y1 y2) 1)))]
(ltrb (min x1 x2)
(min y1 y2)
(+ (max x1 x2) 1)
(+ (max y1 y2) 1)))]
[(polygon? simple-shape)
(points->ltrb (polygon-points simple-shape))]
[else
(let ([dx (translate-dx simple-shape)]
[dy (translate-dy simple-shape)])
(let-values ([(l t r b) (np-atomic-bb (translate-shape simple-shape))])
(make-ltrb (+ l dx)
(+ t dy)
(+ r dx)
(+ b dy))))]))
(ltrb (+ l dx)
(+ t dy)
(+ r dx)
(+ b dy))))]))
(define (points->ltrb points)
(let-values ([(left top right bottom) (points->ltrb-values points)])
(make-ltrb left top right bottom)))
(ltrb left top right bottom)))
(define/contract (np-atomic-bb atomic-shape)
(-> np-atomic-shape? (values number? number? number? number?))

68
collects/2htdp/tests/test-image.rkt
View File

@ -1388,6 +1388,9 @@
(check-exn #rx"crop" (λ () (crop 100 100 10 10 (rectangle 20 20 "solid" "black"))))
(check-exn #rx"crop" (λ () (crop 9 100 10 10 (rectangle 20 20 "solid" "black"))))
(check-exn #rx"crop" (λ () (crop 100 9 10 10 (rectangle 20 20 "solid" "black"))))
(check-exn #rx"crop" (λ () (crop -9 9 10 10 (rectangle 20 20 "solid" "black"))))
(check-exn #rx"crop" (λ () (crop 9 -9 10 10 (rectangle 20 20 "solid" "black"))))
(test (crop 20 20 100 100 (rectangle 40 40 "solid" "black"))
=>
(rectangle 20 20 "solid" "black"))
@ -1622,8 +1625,8 @@
(underlay image image)
(underlay/xy image coord coord image)
(let ([i image])
(crop (min (image-width i) coord)
(min (image-height i) coord)
(crop (max 0 (min (image-width i) coord))
(max 0 (min (image-height i) coord))
size
size
i))
@ -1672,15 +1675,6 @@
(error 'test-image.ss "found differing sizes for ~s:\n ~s\n ~s"
img-sexp raw-size norm-size))))
(define (test-save/load img fn)
(let ([t1 (new text%)]
[t2 (new text%)])
(send t1 insert img)
(send t1 save-file fn)
(send t2 load-file fn)
(let ([s1 (send t1 find-first-snip)]
[s2 (send t2 find-first-snip)])
(equal? s1 s2))))
(time
(redex-check
@ -1691,17 +1685,57 @@
(to-img (eval (term image) (namespace-anchor->namespace anchor))))
#:attempts 1000))
;; this one is commented out because it catches
;; a bug where cropping a shape outside of its
;; bounding box leads to strange, bad behavior.
(define (test-save/load img fn)
(let ([t1 (new text%)]
[t2 (new text%)])
(send t1 insert img)
(send t1 save-file fn)
(send t2 load-file fn)
(let ([s1 (send t1 find-first-snip)]
[s2 (send t2 find-first-snip)])
(equal? s1 s2))))
;; scale-down : image -> image
;; scale image so that it is at most 10000 pixels in area
(define (scale-down img)
(let* ([w (image-width img)]
[h (image-height img)]
[s (* w h)]
[max-s (sqr 100)])
(if (< s max-s)
img
(scale/xy (/ (sqrt max-s) w)
(/ (sqrt max-s) h)
img))))
#;
(time
(let ([fn (make-temporary-file "test-image~a")])
(redex-check
2htdp/image
image
(let ([img (to-img (eval (term image) (namespace-anchor->namespace anchor)))])
(unless (test-save/load img fn)
(error 'test-image.rkt "saving and loading this image fails:\n ~s" (term image))))
(let-values ([(ans real cpu gc)
(time-apply
(λ ()
(let ([img (to-img (eval (term image) (namespace-anchor->namespace anchor)))])
(test-save/load (scale-down img) fn)))
'())])
(unless (car ans)
(error 'test-image.rkt
"saving and loading this image fails:\n ~s"
(term image)))
(unless (< cpu 2000)
(error 'test-image.rkt
"saving and loading this image takes too longer than 2 seconds:\n ~s"
(term image))))
#:attempts 1000)))
;;This expression was found by the below. Its problematic because it has a negative width.
#;
(begin
(define i
(let* ([b (rectangle 17 17 "solid" "black")]
[i (overlay/xy b -37 40 b)])
(rotate 30 (crop 54 30 20 10 i))))
(image-width i) (image-height i) i)

8
collects/teachpack/2htdp/scribblings/image.scrbl
View File

@ -1019,8 +1019,8 @@ the parts that fit onto @racket[scene].
(scale/xy 1 1/2 (flip-vertical (star 40 "solid" "gray"))))]
}
@defproc[(crop [x (and/c real? (<=/c (image-width image)))]
[y (and/c real? (<=/c (image-height image)))]
@defproc[(crop [x (and/c real? (between/c 0 (image-width image)))]
[y (and/c real? (between/c 0 (image-height image)))]
[width (and/c real? (not/c negative?))]
[height (and/c real? (not/c negative?))]
[image image?])
@ -1029,8 +1029,8 @@ the parts that fit onto @racket[scene].
Crops @racket[image] to the rectangle with the upper left at the point (@racket[x],@racket[y])
and with @racket[width] and @racket[height].
The @racket[x] and @racket[y] arguments must be smaller than or equal to
the @racket[width] and @racket[height], respectively.
The @racket[x] and @racket[y] arguments must be between 0 and
the @racket[width] or @racket[height], respectively.
@image-examples[(crop 0 0 40 40 (circle 40 "solid" "chocolate"))
(crop 40 60 40 60 (ellipse 80 120 "solid" "dodgerblue"))