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

added scaling to 2htdp/image

Browse Source 
svn: r16211
This commit is contained in:
Robby Findler 2009-10-02 11:20:30 +00:00
parent 0354154f70
commit d0b4dc24ec
4 changed files with 130 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

66
collects/2htdp/private/image-core.ss
View File

@ -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 #<image: {THE ACTUAL PICTURE}>
;; (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

22
collects/2htdp/private/image-more.ss
View File

@ -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

19
collects/teachpack/2htdp/scribblings/image.scrbl
View File

@ -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

48
collects/tests/2htdp/test-image.ss
View File

@ -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"))
(rectangle 100 10 "solid" "blue"))