From d0b4dc24ec274617b979ddf60dd179257800bb53 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 2 Oct 2009 11:20:30 +0000 Subject: [PATCH] added scaling to 2htdp/image svn: r16211 --- collects/2htdp/private/image-core.ss | 66 +++++++++++++------ collects/2htdp/private/image-more.ss | 22 ++++++- .../teachpack/2htdp/scribblings/image.scrbl | 19 +++++- collects/tests/2htdp/test-image.ss | 48 +++++++++++++- 4 files changed, 130 insertions(+), 25 deletions(-) diff --git a/collects/2htdp/private/image-core.ss b/collects/2htdp/private/image-core.ss index eefb4c86c9..f6777632e8 100644 --- a/collects/2htdp/private/image-core.ss +++ b/collects/2htdp/private/image-core.ss @@ -2,7 +2,11 @@ #| -(error 'fix-me-later) +Need to test copy & paste. Also test that if the "if" +expression in image-snipclass%'s read +method returns #f, then you get a black circle out. + +--- improvments/changes wrt to htdp/image: @@ -26,17 +30,7 @@ in the old library, these two images are the same: todo: sort out wxme library support (loading in text mode). -;; when rendering these things in error messages, -;; they should come out as # -;; (automatically scale them down so they fit) -;; or should it be just the image directly? - -;; redex randomized testing: see if normalization produces normalized shapes. -;; see if normalization always puts things in the right order - -;; need to change error messages to say "the width (second) argument" -;; by passing "width (second)" to the check-arg function - +------------ From Matthias: (to use to compare with this library) @@ -137,6 +131,9 @@ and they all have good sample contracts. (It is amazing what we can do with kids ;; - (make-translate dx dy shape) (define-struct/reg-mk translate (dx dy shape) #:transparent #:omit-define-syntaxes) ;; +;; - (make-scale x-factor y-factor shape) +(define-struct/reg-mk scale (x y shape) #:transparent #:omit-define-syntaxes) +;; ;; - atomic-shape ;; an atomic-shape is either: @@ -240,7 +237,10 @@ and they all have good sample contracts. (It is amazing what we can do with kids (define/override (copy) (make-image shape bb normalized?)) (define/override (draw dc x y left top right bottom dx dy draw-caret?) - (render-image this dc x y)) + (let ([smoothing (send dc get-smoothing)]) + (send dc set-smoothing 'aligned) + (render-image this dc x y) + (send dc set-smoothing smoothing))) (define/override (get-extent dc x y [w #f] [h #f] [descent #f] [space #f] [lspace #f] [rspace #f]) (send (get-the-snip-class-list) add snip-class) (let ([bottom (bb-bottom bb)]) @@ -273,7 +273,9 @@ and they all have good sample contracts. (It is amazing what we can do with kids (make-image (list-ref lst 0) (list-ref lst 1) #f) - (make-image (error 'fix-me-later))))) + (make-image (make-ellipse 100 100 0 'solid "black") + (make-bb 100 100 100) + #f)))) (super-new))) (provide snip-class) @@ -308,22 +310,33 @@ and they all have good sample contracts. (It is amazing what we can do with kids (let loop ([shape shape] [dx 0] [dy 0] + [x-scale 1] + [y-scale 1] [bottom #f]) (cond [(translate? shape) (loop (translate-shape shape) - (+ dx (translate-dx shape)) - (+ dy (translate-dy shape)) + (+ dx (* x-scale (translate-dx shape))) + (+ dy (* y-scale (translate-dy shape))) + x-scale + y-scale + bottom)] + [(scale? shape) + (loop (scale-shape shape) + dx + dy + (* x-scale (scale-x shape)) + (* y-scale (scale-y shape)) bottom)] [(overlay? shape) (loop (overlay-bottom shape) - dx dy + dx dy x-scale y-scale (loop (overlay-top shape) - dx dy bottom))] + dx dy x-scale y-scale bottom))] [(polygon? shape) (let ([this-one (make-polygon (map (λ (p) - (make-point (+ dx (point-x p)) - (+ dy (point-y p)))) + (make-point (+ dx (* x-scale (point-x p))) + (+ dy (* y-scale (point-y p))))) (polygon-points shape)) (polygon-mode shape) (polygon-color shape))]) @@ -331,7 +344,7 @@ and they all have good sample contracts. (It is amazing what we can do with kids (make-overlay bottom (f this-one)) (f this-one)))] [(np-atomic-shape? shape) - (let ([this-one (make-translate dx dy shape)]) + (let ([this-one (make-translate dx dy (scale-np-atomic x-scale y-scale shape))]) (if bottom (make-overlay bottom (f this-one)) (f this-one)))] @@ -350,6 +363,16 @@ and they all have good sample contracts. (It is amazing what we can do with kids (bitmap? shape))) +(define (scale-np-atomic x-scale y-scale shape) + (cond + [(ellipse? shape) + (make-ellipse (* x-scale (ellipse-width shape)) + (* y-scale (ellipse-height shape)) + (ellipse-angle shape) + (ellipse-mode shape) + (ellipse-color shape))] + [(text? shape) (error 'scaling-text)] + [(bitmap? shape) (error 'scaling-a-bitmap)])) ; @@ -437,6 +460,7 @@ and they all have good sample contracts. (It is amazing what we can do with kids (struct-out point) make-overlay overlay? overlay-top overlay-bottom make-translate translate? translate-dx translate-dy translate-shape + make-scale scale-x scale-y scale-shape make-ellipse ellipse? ellipse-width ellipse-height ellipse-angle ellipse-mode ellipse-color make-text text? text-string text-angle text-font make-polygon polygon? polygon-points polygon-mode polygon-color diff --git a/collects/2htdp/private/image-more.ss b/collects/2htdp/private/image-more.ss index 221477f9a5..e86b348490 100644 --- a/collects/2htdp/private/image-more.ss +++ b/collects/2htdp/private/image-more.ss @@ -24,6 +24,9 @@ show-image bring-between + scale + scale/xy + x-place? y-place? mode? @@ -166,9 +169,10 @@ 'non-negative-number i arg) arg] - [(dx dy) + [(dx dy factor x-factor y-factor) (check-arg fn-name - (number? arg) + (and (number? arg) + (real? arg)) 'number i arg) arg] @@ -229,6 +233,20 @@ ;; (the error message for a bad argument will list all of the currently installed example images; ;; we may want to have some way teachers can stick new ones in there) +;; scale : number image -> image +(define/chk (scale factor image) + (scale-internal factor factor image)) + +(define/chk (scale/xy x-factor y-factor image) + (scale-internal x-factor y-factor image)) + +(define (scale-internal x-factor y-factor image) + (make-image (make-scale x-factor y-factor (image-shape image)) + (make-bb (* x-factor (image-right image)) + (* y-factor (image-bottom image)) + (* y-factor (image-baseline image))) + #f)) + ;; overlay : image image image ... -> image ;; places images on top of each other with their upper left corners aligned. last one goes on the bottom diff --git a/collects/teachpack/2htdp/scribblings/image.scrbl b/collects/teachpack/2htdp/scribblings/image.scrbl index e096b65b1a..bcc506aafa 100644 --- a/collects/teachpack/2htdp/scribblings/image.scrbl +++ b/collects/teachpack/2htdp/scribblings/image.scrbl @@ -61,12 +61,29 @@ Images can be rotated, scaled, and overlaid on top of each other, as described b lined up with each other. } -@section{Rotating and Framing Images} +@section{Rotating, Scaling, and Framing Images} @defproc[(rotate [angle angle?] [image image?]) image?]{ Rotates @scheme[image] by @scheme[angle] degrees. } +@defproc[(scale [factor real?] [image image?]) image?]{ + Scales @scheme[image] by @scheme[factor]. For example, + scaling @scheme[(ellipse 40 60 "solid" "blue")] produces + @scheme[(ellipse 80 120 "solid" "blue")]. +} + +@defproc[(scale/xy [x-factor real?] [y-factor real?] [image image?]) image?]{ + Scales @scheme[image] by @scheme[x-factor] horizontally and by + @scheme[y-factor] vertically. For example, + @schemeblock[(scale/xy 3 + 2 + (ellipse 40 60 "solid" "blue"))] + produces + @scheme[(ellipse 120 120 "solid" "blue")]. +} + + @defproc[(frame [image image?]) image?]{ Returns an image just like @scheme[image], except with a black, single pixel frame drawn around the diff --git a/collects/tests/2htdp/test-image.ss b/collects/tests/2htdp/test-image.ss index 231b6359bf..83c07581db 100644 --- a/collects/tests/2htdp/test-image.ss +++ b/collects/tests/2htdp/test-image.ss @@ -10,6 +10,9 @@ ;; test case: (beside (text "a"...) (text "b" ...)) vs (text "ab") +(show-image (overlay (rectangle 200 20 'solid 'red) + (scale 2 (rectangle 200 20 'solid 'blue)))) + #; (show-image (overlay/xy (rectangle 100 10 'solid 'red) @@ -331,6 +334,47 @@ #t) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; scaling tests +;; + +(test (scale 2 (rectangle 100 10 'solid 'blue)) + => + (rectangle 200 20 'solid 'blue)) + +(test (scale 3 + (overlay/xy (rectangle 100 10 'solid 'blue) + 0 + 20 + (rectangle 100 10 'solid 'red))) + => + (overlay/xy (rectangle 300 30 'solid 'blue) + 0 + 60 + (rectangle 300 30 'solid 'red))) + +(test (scale 3 + (overlay/xy (rectangle 100 10 'solid 'blue) + 0 + 20 + (overlay/xy (rectangle 100 10 'solid 'blue) + 0 + 20 + (rectangle 100 10 'solid 'purple)))) + => + (overlay/xy (rectangle 300 30 'solid 'blue) + 0 + 60 + (overlay/xy (rectangle 300 30 'solid 'blue) + 0 + 60 + (rectangle 300 30 'solid 'purple)))) + +(test (scale/xy 3 4 (ellipse 30 60 'outline 'purple)) + => + (ellipse (* 30 3) (* 60 4) 'outline 'purple)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; misc tests @@ -338,4 +382,6 @@ (test (rectangle 100 10 'solid 'blue) => - (rectangle 100 10 "solid" "blue")) \ No newline at end of file + (rectangle 100 10 "solid" "blue")) + +