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

cleaned up rotation

Browse Source 
svn: r15782
This commit is contained in:
Robby Findler 2009-08-19 12:14:09 +00:00
parent a18bbc154b
commit d3ececcee6
3 changed files with 161 additions and 221 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
collects/2htdp/picture.ss
View File

@ -8,7 +8,6 @@
beside/places beside/places
rotate rotate
rotate/places
frame frame

168
collects/2htdp/private/picture.ss
View File

@ -13,7 +13,6 @@
beside/places beside/places
rotate rotate
rotate/places
frame frame
@ -25,7 +24,8 @@
show-picture show-picture
normalize-shape normalize-shape
rotate-atomic
rotate-simple
simple-bb simple-bb
make-picture picture-shape make-picture picture-shape
@ -34,9 +34,10 @@
make-translate make-translate
make-ellipse make-ellipse
make-text make-text
make-polygon) make-polygon
make-point)
(define-struct posn (x y) #:transparent) (define-struct point (x y) #:transparent)
;; when rendering these things in error messages, ;; when rendering these things in error messages,
;; they should come out as #<picture: {THE ACTUAL PICTURE}> ;; they should come out as #<picture: {THE ACTUAL PICTURE}>
@ -112,10 +113,10 @@ and they all have good sample contracts. (It is amazing what we can do with kids
(define-struct ellipse (width height angle pen brush) #:transparent #:omit-define-syntaxes) (define-struct ellipse (width height angle pen brush) #:transparent #:omit-define-syntaxes)
;; ;;
;; - (make-text string angle font) ;; - (make-text string angle font)
(define-struct text (string angle font) #:omit-define-syntaxes) (define-struct text (string angle font) #:omit-define-syntaxes #:transparent)
;; ;;
;; - (make-polygon (listof points) angle pen brush) ;; - (make-polygon (listof points) angle pen brush)
(define-struct polygon (points angle pen brush)) (define-struct polygon (points angle pen brush) #:transparent)
;; ;;
;; - (make-bitmap (is-a?/c bitmap%) angle) ;; - (make-bitmap (is-a?/c bitmap%) angle)
(define-struct bitmap (bitmap angle)) (define-struct bitmap (bitmap angle))
@ -164,38 +165,6 @@ and they all have good sample contracts. (It is amazing what we can do with kids
(polygon? shape) (polygon? shape)
(bitmap? shape))) (bitmap? shape)))
;; simple-bb : simple-shape -> (values number number number number)
;; returns the bounding box of 'shape'
;; (only called for rotated shapes, so bottom=baseline)
(define (simple-bb shape)
(let ([dx (translate-dx shape)]
[dy (translate-dy shape)]
[simple-shape (translate-shape shape)])
(cond
[(polygon? simple-shape)
(let ([θ (polygon-angle simple-shape)]
[points (polygon-points simple-shape)])
(let-values ([(x y) (rotate-point (+ dx (posn-x (car points)))
(+ dy (posn-y (car points)))
θ)])
(let ([left x]
[top y]
[right x]
[bottom y])
(for-each (λ (posn)
(let-values ([(new-x new-y)
(rotate-point (+ dx (posn-x posn))
(+ dy (posn-y posn))
θ)])
(set! left (min new-x left))
(set! top (min new-y top))
(set! right (max new-x right))
(set! bottom (max new-y bottom))))
(cdr points))
(values left top right bottom))))]
[else
(fprintf (current-error-port) "BAD\n")
(values 0 0 100 100)])))
;; rotate-point : x,y theta -> x,y ;; rotate-point : x,y theta -> x,y
(define (rotate-point x y θ) (define (rotate-point x y θ)
@ -235,7 +204,7 @@ and they all have good sample contracts. (It is amazing what we can do with kids
(define-syntax define/chk (define-syntax define/chk
(λ (stx) (λ (stx)
(syntax-case stx () (syntax-case stx ()
[(define/chk (fn-name args ... . final-arg) body) [(define/chk (fn-name args ... . final-arg) body ...)
(identifier? #'final-arg) (identifier? #'final-arg)
(let ([len (length (syntax->list #'(args ...)))]) (let ([len (length (syntax->list #'(args ...)))])
(with-syntax ([(i ...) (build-list len values)]) (with-syntax ([(i ...) (build-list len values)])
@ -243,12 +212,12 @@ and they all have good sample contracts. (It is amazing what we can do with kids
(let ([args (check/normalize 'fn-name 'args args i)] ... (let ([args (check/normalize 'fn-name 'args args i)] ...
[final-arg (map/i (λ (x j) (check/normalize 'fn-name 'final-arg x (+ #,len j))) [final-arg (map/i (λ (x j) (check/normalize 'fn-name 'final-arg x (+ #,len j)))
final-arg)]) final-arg)])
body))))] body ...))))]
[(define/chk (fn-name args ...) body) [(define/chk (fn-name args ...) body ...)
(with-syntax ([(i ...) (build-list (length (syntax->list #'(args ...))) add1)]) (with-syntax ([(i ...) (build-list (length (syntax->list #'(args ...))) add1)])
#'(define (fn-name args ...) #'(define (fn-name args ...)
(let ([args (check/normalize 'fn-name 'args args i)] ...) (let ([args (check/normalize 'fn-name 'args args i)] ...)
body)))]))) body ...)))])))
(define (map/i f l) (define (map/i f l)
(let loop ([l l] (let loop ([l l]
@ -414,12 +383,12 @@ and they all have good sample contracts. (It is amazing what we can do with kids
(let ([path (new dc-path%)] (let ([path (new dc-path%)]
[points (polygon-points atomic-shape)] [points (polygon-points atomic-shape)]
[θ (polygon-angle atomic-shape)]) [θ (polygon-angle atomic-shape)])
(send path move-to (posn-x (car points)) (posn-y (car points))) (send path move-to (point-x (car points)) (point-y (car points)))
(let loop ([points (cdr points)]) (let loop ([points (cdr points)])
(unless (null? points) (unless (null? points)
(send path line-to (posn-x (car points)) (posn-y (car points))) (send path line-to (point-x (car points)) (point-y (car points)))
(loop (cdr points)))) (loop (cdr points))))
(send path line-to (posn-x (car points)) (posn-y (car points))) (send path line-to (point-x (car points)) (point-y (car points)))
(send path rotate θ) (send path rotate θ)
(send dc set-pen (polygon-pen atomic-shape)) (send dc set-pen (polygon-pen atomic-shape))
(send dc set-brush (polygon-brush atomic-shape)) (send dc set-brush (polygon-brush atomic-shape))
@ -582,27 +551,14 @@ and they all have good sample contracts. (It is amazing what we can do with kids
;; rotate : I number -> I ;; rotate : I number -> I
;; rotates the I around the top-left corner by the given angle ;; rotates the I around the top-left corner by the given angle
;; (in degrees) ;; (in degrees)
;; LINEAR TIME OPERATION (sigh)
(define/chk (rotate angle picture) (define/chk (rotate angle picture)
(rotate/internal 'left 'top angle picture))
;; rotate/places : string string I number -> I
;; rotates the I around the given point inside the I, using
;; the strings like overlay does.
;; this function is bogus! It doesn't matter where you rotate it around. it still looks the same!
(define/chk (rotate/places x-place y-place angle picture)
(rotate/internal x-place y-place angle picture))
;; LINEAR TIME OPERATION!!
(define (rotate/internal x-place y-place angle picture)
(define left #f) (define left #f)
(define top #f) (define top #f)
(define right #f) (define right #f)
(define bottom #f) (define bottom #f)
(define (add-to-bounding-box/rotate simple-shape) (define (add-to-bounding-box/rotate simple-shape)
(let ([rotated-shape (apply-rotation angle simple-shape)]) (let ([rotated-shape (rotate-simple angle simple-shape)])
(let-values ([(this-left this-top this-right this-bottom) (simple-bb rotated-shape)]) (let-values ([(this-left this-top this-right this-bottom) (simple-bb rotated-shape)])
(set! left (if left (min this-left left) this-left)) (set! left (if left (min this-left left) this-left))
(set! top (if top (min this-top top) this-top)) (set! top (if top (min this-top top) this-top))
@ -614,31 +570,67 @@ and they all have good sample contracts. (It is amazing what we can do with kids
(make-bb (- right left) (- bottom top) (- bottom top)) (make-bb (- right left) (- bottom top) (- bottom top))
#f))) #f)))
;; apply-rotation : angle simple-shape -> simple-shape ;; simple-bb : simple-shape -> (values number number number number)
(define (apply-rotation θ simple-shape) ;; returns the bounding box of 'shape'
(let ([shape (translate-shape simple-shape)]) ;; (only called for rotated shapes, so bottom=baseline)
(define (simple-bb simple-shape)
(let ([dx (translate-dx simple-shape)]
[dy (translate-dy simple-shape)]
[atomic-shape (translate-shape simple-shape)])
(cond
[(polygon? atomic-shape)
(let ([θ (polygon-angle atomic-shape)]
[points (polygon-points atomic-shape)])
(let-values ([(x y) (rotate-point (point-x (car points)) (point-y (car points)) θ)])
(let ([left x]
[top y]
[right x]
[bottom y])
(for-each (λ (point)
(let-values ([(new-x new-y)
(rotate-point (point-x point) (point-y point) θ)])
(set! left (min new-x left))
(set! top (min new-y top))
(set! right (max new-x right))
(set! bottom (max new-y bottom))))
(cdr points))
(values (+ dx left) (+ dy top) (+ dx right) (+ dy bottom)))))]
[else
(fprintf (current-error-port) "BAD\n")
(values 0 0 100 100)])))
;; rotate-simple : angle simple-shape -> simple-shape
(define (rotate-simple θ simple-shape)
(let-values ([(dx dy) (c->xy (* (make-polar 1 θ)
(xy->c (translate-dx simple-shape)
(translate-dy simple-shape))))])
(make-translate (make-translate
(translate-dx simple-shape) dx
(translate-dy simple-shape) dy
(cond (rotate-atomic θ (translate-shape simple-shape)))))
[(ellipse? shape)
(make-ellipse (ellipse-width shape) ;; rotate-atomic : angle atomic-shape -> atomic-shape
(ellipse-height shape) (define (rotate-atomic θ atomic-shape)
(+ θ (ellipse-angle shape)) (cond
(ellipse-pen shape) [(ellipse? atomic-shape)
(ellipse-brush shape))] (make-ellipse (ellipse-width atomic-shape)
[(text? shape) (ellipse-height atomic-shape)
(make-text (text-string shape) (+ θ (ellipse-angle atomic-shape))
(+ θ (text-angle shape)) (ellipse-pen atomic-shape)
(text-font shape))] (ellipse-brush atomic-shape))]
[(polygon? shape) [(text? atomic-shape)
(make-polygon (polygon-points shape) (make-text (text-string atomic-shape)
(+ θ (polygon-angle shape)) (+ θ (text-angle atomic-shape))
(polygon-pen shape) (text-font atomic-shape))]
(polygon-brush shape))] [(polygon? atomic-shape)
[(bitmap? shape) (make-polygon (polygon-points atomic-shape)
(make-bitmap (bitmap-bitmap shape) (+ θ (polygon-angle atomic-shape))
(+ θ (bitmap-angle shape)))])))) (polygon-pen atomic-shape)
(polygon-brush atomic-shape))]
[(bitmap? atomic-shape)
(make-bitmap (bitmap-bitmap atomic-shape)
(+ θ (bitmap-angle atomic-shape)))]))
;; stamp : I I -> I ;; stamp : I I -> I
;; treats the first I as if it were a mask and uses that mask to ;; treats the first I as if it were a mask and uses that mask to
@ -657,10 +649,10 @@ and they all have good sample contracts. (It is amazing what we can do with kids
;; rectangle ;; rectangle
(define/chk (rectangle width height mode color) (define/chk (rectangle width height mode color)
(make-picture (make-polygon (list (make-posn 0 0) (make-picture (make-polygon (list (make-point 0 0)
(make-posn width 0) (make-point width 0)
(make-posn width height) (make-point width height)
(make-posn 0 height)) (make-point 0 height))
0 0
(mode-color->pen mode color) (mode-color->pen mode color)
(mode-color->brush mode color)) (mode-color->brush mode color))

213
collects/tests/2htdp/test-picture.ss
View File

@ -3,36 +3,38 @@
scheme/math scheme/math
tests/eli-tester) tests/eli-tester)
(let* ([first (rectangle 100 10 'solid 'red)] #;
[second (show-picture
(overlay/places 'center (let loop ([picture (rectangle 400 8 'solid 'red)]
'center [n 2])
first (cond
(rotate/places 'center 'center [(= n 7) picture]
(* pi 1/4) [else
first))] (loop (overlay/places 'center 'center
[third picture
(overlay/places 'center (rotate (* pi (/ 1 n)) picture))
'center (+ n 1))])))
(frame second)
(rotate/places 'center 'center
(* pi 1/8)
(frame second)))])
(show-picture second
#;(frame third)))
(define (round-numbers x) (define-syntax-rule
(round-numbers e)
(call-with-values (λ () e) round-numbers/values))
(define (round-numbers/values . args) (apply values (round-numbers/proc args)))
(define (round-numbers/proc x)
(let loop ([x x]) (let loop ([x x])
(cond (cond
[(number? x) (/ (round (* 100. x)) 100)] [(number? x) (/ (round (* 100. x)) 100)]
[(pair? x) (cons (loop (car x)) (loop (cdr x)))] [(pair? x) (cons (loop (car x)) (loop (cdr x)))]
[(vector? x) (apply vector (map loop (vector->list x)))]
[(let-values ([(a b) (struct-info x)]) a) [(let-values ([(a b) (struct-info x)]) a)
=> =>
(λ (struct-type) (λ (struct-type)
(apply (apply
(struct-type-make-constructor (struct-type-make-constructor
struct-type) struct-type)
(map loop (cdr (vector->list (struct->vector x))))))]))) (map loop (cdr (vector->list (struct->vector x))))))]
[else x])))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;
@ -208,17 +210,6 @@
(ellipse 50 100 'solid 'red) (ellipse 50 100 'solid 'red)
(ellipse 100 50 'solid 'blue))) (ellipse 100 50 'solid 'blue)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; testing rotation bounding boxes.
;;
#|
(test (simple-bb (make-translate 0 0 (make-rotate (* pi 1/4) (picture-shape (rectangle 100 50 'solid 'red)))))
=>
(values 0.0
(- (imag-part (* (make-rectangular 100 0) (make-polar 1 (* pi 1/4)))))
(real-part (* (make-rectangular 100 -50) (make-polar 1 (* pi 1/4))))
(- (imag-part (* (make-rectangular 0 -50) (make-polar 1 (* pi 1/4)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;
@ -226,142 +217,100 @@
;; ;;
(test (normalize-shape (picture-shape (ellipse 50 100 'solid 'red)) (test (normalize-shape (picture-shape (ellipse 50 100 'solid 'red))
void) values)
=> =>
(make-translate 0 0 (make-rotate 0 (picture-shape (ellipse 50 100 'solid 'red))))) (make-translate 0 0 (picture-shape (ellipse 50 100 'solid 'red))))
(test (normalize-shape (make-overlay (picture-shape (ellipse 50 100 'solid 'red)) (test (normalize-shape (make-overlay (picture-shape (ellipse 50 100 'solid 'red))
(picture-shape (ellipse 50 100 'solid 'blue))) (picture-shape (ellipse 50 100 'solid 'blue)))
void) values)
=> =>
(make-overlay (make-translate 0 0 (make-rotate 0 (picture-shape (ellipse 50 100 'solid 'red)))) (make-overlay (make-translate 0 0 (picture-shape (ellipse 50 100 'solid 'red)))
(make-translate 0 0 (make-rotate 0 (picture-shape (ellipse 50 100 'solid 'blue)))))) (make-translate 0 0 (picture-shape (ellipse 50 100 'solid 'blue)))))
(test (normalize-shape (make-overlay (test (normalize-shape (make-overlay
(make-overlay (picture-shape (ellipse 50 100 'solid 'red)) (make-overlay (picture-shape (ellipse 50 100 'solid 'red))
(picture-shape (ellipse 50 100 'solid 'blue))) (picture-shape (ellipse 50 100 'solid 'blue)))
(picture-shape (ellipse 50 100 'solid 'green))) (picture-shape (ellipse 50 100 'solid 'green)))
void) values)
=> =>
(make-overlay (make-overlay
(make-overlay (make-translate 0 0 (make-rotate 0 (picture-shape (ellipse 50 100 'solid 'red)))) (make-overlay (make-translate 0 0 (picture-shape (ellipse 50 100 'solid 'red)))
(make-translate 0 0 (make-rotate 0 (picture-shape (ellipse 50 100 'solid 'blue))))) (make-translate 0 0 (picture-shape (ellipse 50 100 'solid 'blue))))
(make-translate 0 0 (make-rotate 0 (picture-shape (ellipse 50 100 'solid 'green)))))) (make-translate 0 0 (picture-shape (ellipse 50 100 'solid 'green)))))
(test (normalize-shape (make-overlay (test (normalize-shape (make-overlay
(picture-shape (ellipse 50 100 'solid 'green)) (picture-shape (ellipse 50 100 'solid 'green))
(make-overlay (picture-shape (ellipse 50 100 'solid 'red)) (make-overlay (picture-shape (ellipse 50 100 'solid 'red))
(picture-shape (ellipse 50 100 'solid 'blue)))) (picture-shape (ellipse 50 100 'solid 'blue))))
void) values)
=> =>
(make-overlay (make-overlay
(make-overlay (make-translate 0 0 (make-rotate 0 (picture-shape (ellipse 50 100 'solid 'green)))) (make-overlay (make-translate 0 0 (picture-shape (ellipse 50 100 'solid 'green)))
(make-translate 0 0 (make-rotate 0 (picture-shape (ellipse 50 100 'solid 'red))))) (make-translate 0 0 (picture-shape (ellipse 50 100 'solid 'red))))
(make-translate 0 0 (make-rotate 0 (picture-shape (ellipse 50 100 'solid 'blue)))))) (make-translate 0 0 (picture-shape (ellipse 50 100 'solid 'blue)))))
(test (normalize-shape (make-translate 100 100 (picture-shape (ellipse 50 100 'solid 'blue))) (test (normalize-shape (make-translate 100 100 (picture-shape (ellipse 50 100 'solid 'blue)))
void) values)
=> =>
(make-translate 100 100 (make-rotate 0 (picture-shape (ellipse 50 100 'solid 'blue))))) (make-translate 100 100 (picture-shape (ellipse 50 100 'solid 'blue))))
(test (normalize-shape (make-translate 10 20 (make-translate 100 100 (picture-shape (ellipse 50 100 'solid 'blue)))) (test (normalize-shape (make-translate 10 20 (make-translate 100 100 (picture-shape (ellipse 50 100 'solid 'blue))))
void) values)
=> =>
(make-translate 110 120 (make-rotate 0 (picture-shape (ellipse 50 100 'solid 'blue))))) (make-translate 110 120 (picture-shape (ellipse 50 100 'solid 'blue))))
(test (normalize-shape (make-rotate pi (picture-shape (ellipse 50 100 'solid 'blue)))
void)
=>
(make-translate 0 0 (make-rotate pi (picture-shape (ellipse 50 100 'solid 'blue)))))
(test (normalize-shape (make-rotate (* pi 1/2) (make-rotate (* pi 1/2) (picture-shape (ellipse 50 100 'solid 'blue)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
void) ;;
=> ;; testing rotating
(make-translate 0 0 (make-rotate pi (picture-shape (ellipse 50 100 'solid 'blue))))) ;;
(test (round-numbers
(normalize-shape (make-rotate pi (make-translate 100 100 (picture-shape (rectangle 50 100 'solid 'blue))))
void))
=>
(round-numbers (make-translate -100 -100 (make-rotate pi (picture-shape (rectangle 50 100 'solid 'blue))))))
(test (round-numbers (test (round-numbers
(normalize-shape (make-rotate (* pi 1/2) (make-translate 100 50 (picture-shape (rectangle 50 100 'solid 'blue)))) (simple-bb
void)) (make-translate
50.0
0
(make-polygon
(list (make-point 0 0) (make-point 50 0) (make-point 50 100) (make-point 0 100))
pi
'pen
'brush))))
=> =>
(round-numbers (make-translate 50 -100 (make-rotate (* pi 1/2) (picture-shape (rectangle 50 100 'solid 'blue)))))) (values 0. -100. 50. 0.))
(test (normalize-shape (picture-shape (rotate pi (rectangle 50 100 'solid 'blue)))
values)
=>
(make-translate 50.0 100.0 (rotate-atomic pi (picture-shape (rectangle 50 100 'solid 'blue)))))
(test (rotate-simple (* pi 1/2)
(rotate-simple (* pi 1/2)
(make-translate 0 0
(picture-shape (rectangle 50 100 'solid 'purple)))))
=>
(rotate-simple pi
(make-translate 0 0 (picture-shape (rectangle 50 100 'solid 'purple)))))
(test (normalize-shape (picture-shape (rotate (* pi 1/2) (rotate (* pi 1/2) (rectangle 50 100 'solid 'blue))))
values)
=>
(make-translate 50.0 100.0 (rotate-atomic pi (picture-shape (rectangle 50 100 'solid 'blue)))))
(test (round-numbers (test (round-numbers
(normalize-shape (normalize-shape
(make-rotate (picture-shape
(* pi 1/4) (rotate pi
(make-translate (overlay/xy (rectangle 50 50 'solid 'blue)
100 100 50 50
(picture-shape (rectangle 100 10 'solid 'red)))) (rectangle 50 50 'solid 'red))))
void)) values))
=> =>
(round-numbers (round-numbers
(make-translate
(* 100 (sqrt 2))
0.0
(make-rotate
(* pi 1/4)
(picture-shape (rectangle 100 10 'solid 'red))))))
(test (round-numbers
(normalize-shape (normalize-shape
(make-rotate (picture-shape
(* pi 1/4) (overlay/xy (rectangle 50 50 'solid 'red)
(make-translate 50 50
100 100 (rectangle 50 50 'solid 'blue))))))
(make-rotate
(* pi 1/4)
(make-translate
100 100
(picture-shape (rectangle 100 10 'solid 'red))))))
void))
=>
(round-numbers
(make-translate
200
0
(make-rotate
(* pi 1/2)
(picture-shape (rectangle 100 10 'solid 'red))))))
(test (round-numbers
(normalize-shape
(make-rotate
(* pi 1/4)
(make-translate
100 100
(make-rotate
(* pi 1/4)
(make-translate
100 100
(picture-shape (rectangle 100 10 'solid 'red))))))
void))
=>
(round-numbers
(make-translate
(* (sqrt 2) 100 2)
0
(make-rotate
(* pi 1/2)
(picture-shape (rectangle 100 10 'solid 'red))))))
(test (round-numbers
(normalize-shape
(picture-shape
(rotate (* pi 1/8) (rotate (* pi 1/8) (rectangle 100 10 'solid 'red))))
void))
=>
(round-numbers
(normalize-shape
(picture-shape
(rotate (* pi 1/4) (rectangle 100 10 'solid 'red)))
void)))
|#