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

fixed a bug in rotating non-polygons

Browse Source 
svn: r16315
This commit is contained in:
Robby Findler 2009-10-13 22:16:17 +00:00
parent 56757bf8b0
commit 3aae13cb60
3 changed files with 65 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/2htdp/private/image-core.ss
View File

@ -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)

54
collects/2htdp/private/image-more.ss
View File

@ -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

40
collects/tests/2htdp/test-image.ss
View File

@ -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)))
(image-snip->image (make-object image-snip% blue-20x10-bitmap)))
|#