From 8d2db5f4bffaf38c2d61c0155695886f627c0dd4 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 22 Aug 2010 20:33:30 -0500 Subject: [PATCH] fixed a bug found by random testing --- collects/2htdp/private/image-more.rkt | 62 ++++++++--------- collects/2htdp/tests/test-image.rkt | 68 ++++++++++++++----- .../teachpack/2htdp/scribblings/image.scrbl | 8 +-- 3 files changed, 85 insertions(+), 53 deletions(-) diff --git a/collects/2htdp/private/image-more.rkt b/collects/2htdp/private/image-more.rkt index 02fcab3ced..65b85e9a0c 100644 --- a/collects/2htdp/private/image-more.rkt +++ b/collects/2htdp/private/image-more.rkt @@ -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?)) diff --git a/collects/2htdp/tests/test-image.rkt b/collects/2htdp/tests/test-image.rkt index 8496466442..50f717fdc1 100644 --- a/collects/2htdp/tests/test-image.rkt +++ b/collects/2htdp/tests/test-image.rkt @@ -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) + diff --git a/collects/teachpack/2htdp/scribblings/image.scrbl b/collects/teachpack/2htdp/scribblings/image.scrbl index 5dc52c69bf..267552d7e2 100644 --- a/collects/teachpack/2htdp/scribblings/image.scrbl +++ b/collects/teachpack/2htdp/scribblings/image.scrbl @@ -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"))