From 3aae13cb60716415928a275134be85f54e50275a Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 13 Oct 2009 22:16:17 +0000 Subject: [PATCH] fixed a bug in rotating non-polygons svn: r16315 --- collects/2htdp/private/image-core.ss | 2 +- collects/2htdp/private/image-more.ss | 54 ++++++++++++++++------------ collects/tests/2htdp/test-image.ss | 40 ++++++++++++++++----- 3 files changed, 65 insertions(+), 31 deletions(-) diff --git a/collects/2htdp/private/image-core.ss b/collects/2htdp/private/image-core.ss index 0a4e1755b0..1c7a9ba2e0 100644 --- a/collects/2htdp/private/image-core.ss +++ b/collects/2htdp/private/image-core.ss @@ -489,7 +489,7 @@ and they all have good sample contracts. (It is amazing what we can do with kids [(outline) (send the-brush-list find-or-create-brush "black" 'transparent)] [(solid) (send the-brush-list find-or-create-brush color 'solid)])) -(provide make-image image-shape +(provide make-image image-shape image-bb image-normalized? image% (struct-out bb) (struct-out point) diff --git a/collects/2htdp/private/image-more.ss b/collects/2htdp/private/image-more.ss index feab38ce69..58e35da772 100644 --- a/collects/2htdp/private/image-more.ss +++ b/collects/2htdp/private/image-more.ss @@ -449,21 +449,24 @@ (values left top right bottom)))] [else (let ([dx (translate-dx simple-shape)] - [dy (translate-dy simple-shape)] - [atomic-shape (translate-shape simple-shape)]) - (cond - [(ellipse? atomic-shape) - (let-values ([(w h) (ellipse-rotated-size (ellipse-width atomic-shape) - (ellipse-height atomic-shape) - (ellipse-angle atomic-shape))]) - (values dx - dy - (+ dx w) - (+ dy h)))] - [else - (fprintf (current-error-port) "BAD BOUNDING BOX\n") - (values 0 0 100 100)]))])) + [dy (translate-dy simple-shape)]) + (let-values ([(l t r b) (atomic-bb (translate-shape simple-shape))]) + (values (+ l dx) + (+ t dy) + (+ r dx) + (+ b dy))))])) +(define (atomic-bb atomic-shape) + (cond + [(ellipse? atomic-shape) + (let-values ([(w h) (ellipse-rotated-size (ellipse-width atomic-shape) + (ellipse-height atomic-shape) + (ellipse-angle atomic-shape))]) + (values 0 0 w h))] + [else + (fprintf (current-error-port) "BAD BOUNDING BOX\n") + (values 0 0 100 100)])) + ;; rotate-simple : angle simple-shape -> simple-shape (define (rotate-simple θ simple-shape) (cond @@ -475,13 +478,19 @@ (polygon-mode simple-shape) (polygon-color simple-shape))] [else - (let-values ([(dx dy) (c->xy (* (make-polar 1 (degrees->radians θ)) - (xy->c (translate-dx simple-shape) - (translate-dy simple-shape))))]) - (make-translate - dx - dy - (rotate-atomic θ (translate-shape simple-shape))))])) + (let* ([unrotated (translate-shape simple-shape)] + [rotated (rotate-atomic θ unrotated)]) + (let-values ([(dx dy) (c->xy (- (* (make-polar 1 (degrees->radians θ)) + (+ (xy->c (translate-dx simple-shape) + (translate-dy simple-shape)) + (center-point unrotated))) + (center-point unrotated)))]) + (make-translate dx dy rotated)))])) + +(define (center-point atomic-shape) + (let-values ([(l t r b) (atomic-bb atomic-shape)]) + (xy->c (/ (- r l) 2) + (/ (- b t) 2)))) ;; rotate-atomic : angle np-atomic-shape -> np-atomic-shape (define (rotate-atomic θ atomic-shape) @@ -530,7 +539,8 @@ ;; bring-between : number number -> number ;; returns a number that is much like the modulo of 'x' and 'upper-bound' -;; but does this by repeated subtraction, since modulo only works on integers +;; but does this by repeated subtraction (or addition if it is negative), +;; since modulo only works on integers (define (bring-between x upper-bound) (let loop ([x x]) (cond diff --git a/collects/tests/2htdp/test-image.ss b/collects/tests/2htdp/test-image.ss index b3d16e2faa..b113bfe4b2 100644 --- a/collects/tests/2htdp/test-image.ss +++ b/collects/tests/2htdp/test-image.ss @@ -10,7 +10,7 @@ ;; test case: (beside (text "a"...) (text "b" ...)) vs (text "ab") -;(show-image (frame (rotate 210 (ellipse 200 400 'solid 'purple)))) +;(show-image (frame (rotate 30 (ellipse 200 400 'solid 'purple)))) #; (show-image @@ -47,12 +47,19 @@ n))] [(pair? x) (cons (loop (car x)) (loop (cdr x)))] [(vector? x) (apply vector (map loop (vector->list x)))] + [(is-a? x image%) + (make-image + (loop (image-shape x)) + (loop (image-bb x)) + (loop (image-normalized? x)))] + [(object? x) + ;; add a random number here to hack around the way Eli's tester treats two errors as a passing test + (error 'round-numbers/proc "cannot handle objects ~a" (random))] [(let-values ([(a b) (struct-info x)]) a) => (λ (struct-type) (apply - (struct-type-make-constructor - struct-type) + (struct-type-make-constructor struct-type) (map loop (cdr (vector->list (struct->vector x))))))] [else x]))) @@ -306,13 +313,13 @@ (normalize-shape (image-shape (rotate 180 (rectangle 50 100 'solid 'purple))) values))) -(test (normalize-shape (image-shape (rotate 90 (ellipse 10 10 'solid 'red)))) +(test (round-numbers (normalize-shape (image-shape (rotate 90 (ellipse 10 10 'solid 'red))))) => - (normalize-shape (image-shape (ellipse 10 10 'solid 'red)))) + (round-numbers (normalize-shape (image-shape (ellipse 10 10 'solid 'red))))) -(test (normalize-shape (image-shape (rotate 90 (ellipse 10 12 'solid 'red)))) +(test (round-numbers (normalize-shape (image-shape (rotate 90 (ellipse 10 12 'solid 'red))))) => - (normalize-shape (image-shape (ellipse 12 10 'solid 'red)))) + (round-numbers (normalize-shape (image-shape (ellipse 12 10 'solid 'red))))) (test (normalize-shape (image-shape (rotate 135 (ellipse 10 12 'solid 'red)))) => @@ -336,6 +343,21 @@ => #t) +(test (round-numbers + (normalize-shape + (image-shape + (rotate + 90 + (overlay/xy (rectangle 20 100 'solid 'purple) + 20 0 + (ellipse 40 40 'solid 'orange)))))) + => + (round-numbers + (normalize-shape + (image-shape + (overlay/xy (rectangle 100 20 'solid 'purple) + 0 -40 + (ellipse 40 40 'solid 'orange)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; @@ -416,9 +438,11 @@ (test (image-baseline (image-snip->image (make-object image-snip% blue-10x20-bitmap))) => 20) +#| (test (scale 2 (make-object image-snip% blue-10x20-bitmap)) => (image-snip->image (make-object image-snip% blue-20x40-bitmap))) (test (rotate 90 (make-object image-snip% blue-10x20-bitmap)) => - (image-snip->image (make-object image-snip% blue-20x10-bitmap))) \ No newline at end of file + (image-snip->image (make-object image-snip% blue-20x10-bitmap))) +|# \ No newline at end of file