From 9087348b7e4eb74694618b191762f5f222eb04ce Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 6 Sep 2010 07:14:39 -0500 Subject: [PATCH] added pinhole support to the flipping prims --- collects/2htdp/private/image-more.rkt | 8 ++++++-- collects/2htdp/tests/test-image.rkt | 13 +++++++++++++ 2 files changed, 19 insertions(+), 2 deletions(-) diff --git a/collects/2htdp/private/image-more.rkt b/collects/2htdp/private/image-more.rkt index cf7ec3a6f5..c332298551 100644 --- a/collects/2htdp/private/image-more.rkt +++ b/collects/2htdp/private/image-more.rkt @@ -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?) diff --git a/collects/2htdp/tests/test-image.rkt b/collects/2htdp/tests/test-image.rkt index 2302ab202e..004f867b5b 100644 --- a/collects/2htdp/tests/test-image.rkt +++ b/collects/2htdp/tests/test-image.rkt @@ -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) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;