From ca7bf92054fb0fdcfc1672472e622e5f8215086f Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 17 Jun 2010 16:26:49 -0500 Subject: [PATCH] added basic flipping (bitmaps not done yet) --- collects/2htdp/image.rkt | 2 + collects/2htdp/private/image-more.rkt | 143 +++++++++++++++++++++++--- collects/2htdp/tests/test-image.rkt | 37 +++++++ 3 files changed, 168 insertions(+), 14 deletions(-) diff --git a/collects/2htdp/image.rkt b/collects/2htdp/image.rkt index ba1b5d8ffa..3087ed30ea 100644 --- a/collects/2htdp/image.rkt +++ b/collects/2htdp/image.rkt @@ -68,6 +68,8 @@ and they all have good sample contracts. (It is amazing what we can do with kids crop rotate + flip-horizontal + flip-vertical frame place-image place-image/align diff --git a/collects/2htdp/private/image-more.rkt b/collects/2htdp/private/image-more.rkt index 3dd470d739..66eef0ccce 100644 --- a/collects/2htdp/private/image-more.rkt +++ b/collects/2htdp/private/image-more.rkt @@ -261,18 +261,22 @@ (cdr rst)))]))) -; -; ;; ;; ;; -; ;; ;; ;;; -; ;;;; ;;;; ;;;;;; ;;; ;;;;; ;; ;; ;;; ;;;; ;;;;; ;;;; ;;;; ;;;;; -; ;;;;;; ;;;;;; ;;;;;;;;;; ;;;;;; ;; ;;;;;; ;; ;; ;;;; ;;;;;; ;;;; ;; ;; -; ;;; ;;; ;;; ;; ;; ;; ;; ;;; ;; ;; ;; ;;;; ;;; ;;; ;;; ;; ;;;;; -; ;;; ;;; ;;; ;; ;; ;; ;; ;;; ;; ;; ;; ;;; ;; ;;; ;;; ;;; ;; ;;;; -; ;;;;;; ;;;;;; ;; ;; ;; ;;;;;; ;; ;; ;; ;;; ;; ;;;; ;;;;;; ;; ;; ;;; -; ;;;; ;;;; ;; ;; ;; ;; ;; ;; ;; ;; ;;;;;; ;;; ;;;; ;; ;;;;; -; -; -; +; +; +; +; ;;;; ;; ; +; ;;;; ;; ;; +; ;;;;; ;;;; ;;;;;;; ;;;; ;;;;;;; ;;;; ;;; ;;;;;;; ;;;;; ;;;; ;;; ;;; ;;;;; +; ;;;;;; ;;;;;; ;;;;;;;;;;;;; ;;;;;;;; ;;;; ;;;;;;;;; ;;;;;;;; ;;;;;; ;;;;;; ;;;;;;; ;;;;;; +; ;;;;;;; ;;;;;;;; ;;;; ;;; ;;;; ;;;;;;;;; ;;;; ;;;; ;;;; ;;;; ;;;; ;;;;;;;; ;;;; ;; ;;;; +; ;;;; ;;;; ;;; ;;;; ;;; ;;;; ;;;; ;;;; ;;;; ;;;; ;;;; ;;;;;;; ;;;; ;;;; ;;; ;;;; ;;;; +; ;;;;;;; ;;;;;;;; ;;;; ;;; ;;;; ;;;;;;;;; ;;;; ;;;; ;;;; ;; ;;;; ;;;;; ;;;;;;;; ;;;; ;;;; +; ;;;;;; ;;;;;; ;;;; ;;; ;;;; ;;;;;;;; ;;;; ;;;; ;;;; ;;;;;;;; ;;;;; ;;;;;; ;;;; ;;;;;; +; ;;;;; ;;;; ;;;; ;;; ;;;; ;;;;;;; ;;;; ;;;; ;;;; ;; ;;;; ;;;; ;;;; ;;;; ;;;;; +; +; +; + ;; crop : number number number number image -> image ;; crops an image to be w x h from (x,y) @@ -385,7 +389,7 @@ (rotate-simple angle shape)])) ;; rotate-simple : angle simple-shape -> simple-shape -(define (rotate-simple θ simple-shape) +(define/contract (rotate-simple θ simple-shape) (-> number? simple-shape? simple-shape?) (cond [(line-segment? simple-shape) @@ -488,7 +492,7 @@ (let-values ([(left top right bottom) (points->ltrb-values points)]) (make-ltrb left top right bottom))) -(define (np-atomic-bb atomic-shape) +(define/contract (np-atomic-bb atomic-shape) (-> np-atomic-shape? (values number? number? number? number?)) (cond [(ellipse? atomic-shape) @@ -639,6 +643,115 @@ [else (loop (- x upper-bound))]))) +(define/chk (flip-horizontal image) + (rotate 90 (flip-vertical (rotate -90 image)))) + +(define/chk (flip-vertical image) + (let* ([flipped-shape (flip-normalized-shape + (send image get-normalized-shape))] + [ltrb (normalized-shape-bb flipped-shape)]) + (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))) + +(define/contract (flip-normalized-shape shape) + (-> normalized-shape? normalized-shape?) + (cond + [(overlay? shape) + (let ([top-shape (flip-normalized-shape (overlay-top shape))] + [bottom-shape (flip-cn-or-simple-shape (overlay-bottom shape))]) + (make-overlay top-shape bottom-shape))] + [else + (flip-cn-or-simple-shape shape)])) + +(define/contract (flip-cn-or-simple-shape shape) + (-> cn-or-simple-shape? cn-or-simple-shape?) + (cond + [(crop? shape) + (make-crop (flip-points (crop-points shape)) + (flip-normalized-shape (crop-shape shape)))] + [else + (flip-simple shape)])) + +(define/contract (flip-simple simple-shape) + (-> simple-shape? simple-shape?) + (cond + [(line-segment? simple-shape) + (make-line-segment (flip-point (line-segment-start simple-shape)) + (flip-point (line-segment-end simple-shape)) + (line-segment-color simple-shape))] + [(curve-segment? simple-shape) + (make-curve-segment (flip-point (curve-segment-start simple-shape)) + (curve-segment-s-angle simple-shape) + (curve-segment-s-pull simple-shape) + (flip-point (curve-segment-end simple-shape)) + (curve-segment-e-angle simple-shape) + (curve-segment-e-pull simple-shape) + (curve-segment-color simple-shape))] + [(polygon? simple-shape) + (make-polygon (flip-points (polygon-points simple-shape)) + (polygon-mode simple-shape) + (polygon-color simple-shape))] + [else + (make-translate (translate-dx simple-shape) + (- (translate-dy simple-shape)) + (flip-atomic (translate-shape simple-shape)))])) + +(define/contract (flip-atomic atomic-shape) + (-> np-atomic-shape? np-atomic-shape?) + (cond + [(ellipse? atomic-shape) + (cond + [(= (ellipse-width atomic-shape) + (ellipse-height atomic-shape)) + atomic-shape] + [else + (let ([new-angle (bring-between (- 180 (ellipse-angle atomic-shape)) 180)]) + (cond + [(< new-angle 90) + (make-ellipse (ellipse-width atomic-shape) + (ellipse-height atomic-shape) + new-angle + (ellipse-mode atomic-shape) + (ellipse-color atomic-shape))] + [else + (make-ellipse (ellipse-height atomic-shape) + (ellipse-width atomic-shape) + (- new-angle 90) + (ellipse-mode atomic-shape) + (ellipse-color atomic-shape))]))])] + [(text? atomic-shape) + (error 'flip "cannot flip shapes that contain text")] + [(bitmap? atomic-shape) + atomic-shape + #;(make-bitmap (bitmap-raw-bitmap atomic-shape) + (bitmap-raw-mask atomic-shape) + (bring-between (+ θ (bitmap-angle atomic-shape)) 360) + (bitmap-x-scale atomic-shape) + (bitmap-y-scale atomic-shape) + #f + #f)])) + +(define (flip-point point) (make-point (point-x point) (- (point-y point)))) +(define (flip-points points) (map flip-point points)) +; +; +; +; ;;;; ;; ;; +; ;;;; ;; ;; +; ;;;;;;; ;;;;;;; ;;;;; ;;;;; ;;;;;;; ;;;; ;;;;;;; ;;;;;;; ;;; ;;;;; +; ;;;;;;;; ;;;;;;;; ;;;;;; ;;;; ;;;;;; ;;;; ;;;;;;;;;;;;; ;;;;;;;; ;;;;;;;; ;;;;; ;;;;;; +; ;;;;;;;;; ;;;; ;;;; ;;;; ;;;;;;; ;;;; ;;;; ;;; ;;;; ;;;; ;;; ;;;; ;;;; ;; ;;;; +; ;;;; ;;;; ;;;;;;; ;;;; ;;;; ;;;; ;;;; ;;;; ;;; ;;;; ;;;;;;; ;;;;;;;; ;;;;;;; ;;;; +; ;;;;;;;;; ;; ;;;; ;;;; ;;;; ;;;;;;; ;;;; ;;;; ;;; ;;;; ;; ;;;; ;;;;;;; ;;;;; ;;;; +; ;;;;;;;; ;;;;;;;; ;;;;;; ;;;; ;;;;;; ;;;; ;;;; ;;; ;;;; ;;;;;;;; ; ;;;; ;;;;;; ;;;;;; +; ;;;;;;; ;; ;;;; ;;;;; ;;;; ;;;;; ;;;; ;;;; ;;; ;;;; ;; ;;;; ;;;;;;;; ;;;; ;;;;; +; ;;;;;;;; +; ;;;;;; +; + (define/chk (polygon posns mode color) (check-mode/color-combination 'polygon 3 mode color) @@ -939,6 +1052,8 @@ rotate crop + flip-vertical + flip-horizontal frame place-image diff --git a/collects/2htdp/tests/test-image.rkt b/collects/2htdp/tests/test-image.rkt index 6f95b625ce..0d509889b0 100644 --- a/collects/2htdp/tests/test-image.rkt +++ b/collects/2htdp/tests/test-image.rkt @@ -1366,6 +1366,43 @@ => (count-crops (normalize-shape (image-shape an-image+crop))))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; flipping +;; + +(test (flip-horizontal (rotate -30 (rectangle 100 10 'solid 'red))) + => + (rotate 30 (rectangle 100 10 'solid 'red))) + +(test (flip-vertical (rotate -30 (rectangle 100 10 'solid 'red))) + => + (rotate 30 (rectangle 100 10 'solid 'red))) +(test (flip-vertical + (rotate + -30 + (overlay (rectangle 100 10 'solid 'red) + (ellipse 10 100 'solid 'blue)))) + => + (rotate + 30 + (overlay (rectangle 100 10 'solid 'red) + (ellipse 10 100 'solid 'blue)))) +(test (flip-horizontal (overlay/xy (rectangle 100 10 'solid 'red) + 10 10 + (ellipse 10 100 'solid 'blue))) + => + (overlay/xy (rectangle 100 10 'solid 'red) + 80 10 + (ellipse 10 100 'solid 'blue))) +(test (flip-vertical (overlay/xy (rectangle 100 10 'solid 'red) + 10 10 + (ellipse 10 100 'solid 'blue))) + => + (overlay/xy (rectangle 100 10 'solid 'red) + 10 -100 + (ellipse 10 100 'solid 'blue))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; pen arguments