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

added pinhole support to the flipping prims

Browse Source
This commit is contained in:
Robby Findler 2010-09-06 07:14:39 -05:00
parent 157e9c2512
commit 9087348b7e
2 changed files with 19 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -671,12 +671,16 @@
(define/chk (flip-vertical image)
(let* ([flipped-shape (flip-normalized-shape
(send image get-normalized-shape))]
[ltrb (normalized-shape-bb flipped-shape)])
[ltrb (normalized-shape-bb flipped-shape)]
[ph (send image get-pinhole)])
(make-image (make-translate (- (ltrb-left ltrb)) (- (ltrb-top ltrb)) flipped-shape)
(make-bb (- (ltrb-right ltrb) (ltrb-left ltrb))
(- (ltrb-bottom ltrb) (ltrb-top ltrb))
(- (ltrb-bottom ltrb) (ltrb-top ltrb)))
#f)))
#f
(and ph
(make-point (+ (point-x ph) (- (ltrb-left ltrb)))
(+ (- (point-y ph)) (- (ltrb-top ltrb))))))))
(define/contract (flip-normalized-shape shape)
(-> normalized-shape? normalized-shape?)

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

@ -1606,6 +1606,19 @@
(test (round-numbers (pinhole-y (rotate 90 (center-pinhole (rectangle 40 20 'solid 'red)))))
=>
20.0)
(test (pinhole-x (flip-vertical (put-pinhole 1 2 (rectangle 10 20 'solid 'red))))
=>
1)
(test (pinhole-y (flip-vertical (put-pinhole 1 2 (rectangle 10 20 'solid 'red))))
=>
18)
(test (pinhole-x (flip-horizontal (put-pinhole 1 2 (rectangle 10 20 'solid 'red))))
=>
9.0)
(test (pinhole-y (flip-horizontal (put-pinhole 1 2 (rectangle 10 20 'solid 'red))))
=>
2.0)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;