1 ;; The first three lines of this file were inserted by DrScheme. They record metadata
2 ;; about the language level of this file in a form that our tools can easily process.
3 #reader(lib "htdp-intermediate-reader.ss" "lang")((modname |21.4|) (read-case-sensitive #t) (teachpacks ((lib "draw.ss" "teachpack" "htdp"))) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ((lib "draw.ss" "teachpack" "htdp")))))
4 
5 (define-struct circle (center radius color))
6 #|
7 ;A circle is a structure
8 ;(make-circle ce ra co)
9 ;where ce is a posn, ra is a number, and co is a symbol.
10 ;
11 ;draw-a-circle : circle -> boolean
12 ;Given a-circle, draw it and return true.
13 
14 (define (draw-a-circle a-circle)
15   (draw-solid-disk (circle-center a-circle)
16                    (circle-radius a-circle)
17                    (circle-color a-circle)))
18 
19 ;clear-a-circle : circle -> boolean
20 ;Given a-circle, clear it and return true.
21 
22 (define (clear-a-circle a-circle)
23   (clear-solid-disk (circle-center a-circle)
24                     (circle-radius a-circle)
25                     (circle-color a-circle)))
26 |#
27 ;process-circle : (circle -> X) circle -> X
28 ;Given operation and a-circle, process the circle according to operation (draw-solid-disk or clear-solid-disk).
29 
30 (define (process-circle operation a-circle)
31   (operation (circle-center a-circle)
32              (circle-radius a-circle)
33              (circle-color a-circle)))
34 
35 ;draw-a-circle : circle -> boolean
36 ;Given a-circle, draw it and return true.
37 
38 (define (draw-a-circle a-circle)
39   (process-circle draw-solid-disk a-circle))
40 
41 ;clear-a-circle : circle -> boolean
42 ;Given a-circle, clear it and return true.
43 
44 (define (clear-a-circle a-circle)
45   (process-circle clear-solid-disk a-circle))
46 
47 ;Exercise 21.4.1.   Abstract the functions draw-a-circle and clear-a-circle into a single function process-circle.
48 ;
49 ;Define translate-circle using process-circle. Hint: If a primitive function doesn't quite fit an abstraction, we have to define auxiliary functions. For now, use define to do so. Intermezzo 4 introduces a handy and important short-hand for that purpose.    Solution
50 
51 ;translate-circle : circle number -> circle
52 ;Given a-circle and delta, return a circle structure moved delta to the right.
53 ;
54 ;translate-delta : posn number symbol -> circle
55 ;Given delta, center, radius, and color, return a circle structure translated delta to the right.
56 
57 (define (translate-circle a-circle delta)
58   (local ((define (translate-delta center radius color)
59             (make-circle (make-posn (+ delta (posn-x center))
60                                     (posn-y center))
61                          radius
62                          color)))
63     (process-circle translate-delta a-circle)))
64 
65 (define-struct rectangle (upper-left width height color))
66 
67 ;A rectangle is a structure
68 ;(make-rectangle u w h c)
69 ;where u is a posn, w, h are numbers, and color is a symbol.
70 ;
71 ;A shape is either
72 ;1. a circle or
73 ;2. a rectangle.
74 
75 #|
76 Exercise 21.4.2.   Abstract the functions draw-a-rectangle and clear-a-rectangle into a single function process-rectangle.
77 
78 Define translate-rectangle using process-rectangle.    Solution
79 |#
80 
81 ;process-rectangle : (posn number number symbol -> X) rectangle -> X
82 ;Perform operation on a-rectangle.
83 
84 (define (process-rectangle operation a-rect)
85   (operation (rectangle-upper-left a-rect)
86              (rectangle-width a-rect)
87              (rectangle-height a-rect)
88              (rectangle-color a-rect)))
89 
90 ;draw-a-rectangle : (posn number number symbol -> boolean) rectangle -> boolean
91 (define (draw-a-rectangle a-rect)
92   (process-rectangle draw-solid-rect a-rect))
93 
94 ;clear-a-rectangle : (posn number number symbol -> boolean) rectangle -> boolean
95 (define (clear-a-rectangle a-rect)
96   (process-rectangle clear-solid-rect a-rect))
97 
98 ;translate-rectangle : (posn number number symbol -> boolean) rectangle number -> rectangle
99 ;Given a-rect and delta, return a rectangle structure translated delta to the right.
100 
101 (define (translate-rectangle a-rect delta)
102   (local ((define (translate-rectangle a-rect)
103             (process-rectangle translate-delta a-rect))
104           (define (translate-delta upper-left width height color)
105             (make-rectangle (make-posn (+ delta (posn-x upper-left))
106                                        (posn-y upper-left))
107                             width
108                             height
109                             color)))
110     (translate-rectangle a-rect)))
111 
112 ;process-shape : (posn number symbol -> X) or
113 ;                (posn number number symbol -> X) shape -> X
114 (define (process-shape operation a-shape)
115   (cond
116     [(circle? a-shape) (process-circle operation a-shape)]
117     [(rectangle? a-shape) (process-rectangle operation a-shape)]))
118 
119 (define (draw-shape a-shape)
120   (cond
121     [(circle? a-shape) (process-shape draw-solid-disk a-shape)]
122     [(rectangle? a-shape) (process-shape draw-solid-rect a-shape)]))
123 
124 (define (clear-shape a-shape)
125   (cond
126     [(circle? a-shape) (process-shape clear-solid-disk a-shape)]
127     [(rectangle? a-shape) (process-shape clear-solid-rect a-shape)]))
128 
129 (define (translate-shape a-shape delta)
130   (cond
131     [(circle? a-shape) (translate-circle a-shape delta)]
132     [(rectangle? a-shape) (translate-rectangle a-shape delta)]))
133 
134 ;Exercise 21.4.4.   Use Scheme's map and andmap to define draw-losh, clear-losh, and translate-losh.    Solution
135 
136 
137 ;draw-losh : (listof shapes) -> boolean 
138 ;Draws a (listof shapes) and return true.
139 (define (draw-losh alosh)
140   (andmap draw-shape alosh))
141 
142 ;clear-losh : (listof shapes) -> boolean 
143 ;Clears a (listof shapes) and return true.
144 (define (clear-losh alosh)
145   (andmap clear-shape alosh))
146 
147 ;translate-losh : number (listof shapes) -> (listof shapes)
148 ;Translates alosh delta to the right and returns a new (listof shapes).
149 
150 (define (translate-losh alosh delta)
151   (local ((define (translate-shape a-shape)
152             (cond
153               [(circle? a-shape) (translate-circle a-shape delta)]
154               [(rectangle? a-shape) (translate-rectangle a-shape delta)])))
155     (map translate-shape alosh)))
156 
157 (define SQUIDWARD
158   (list (make-circle (make-posn 100 100)
159                      80
160                      'blue)
161         (make-circle (make-posn 60 60)
162                      10
163                      'red)
164         (make-circle (make-posn 140 60)
165                      10
166                      'red)
167         (make-rectangle (make-posn 90 80)
168                         20
169                         50
170                         'yellow)
171         (make-rectangle (make-posn 60 140)
172                         80
173                         20
174                         'green)))
175 
176 (translate-losh SQUIDWARD 50)
177 
178 #|
179 ;; map : (X  ->  Y) (listof X)  ->  (listof Y)
180 ;; to construct a list by applying f to each item on alox
181 ;; that is, (map f (list x-1 ... x-n)) = (list (f x-1) ... (f x-n))
182 (define (map f alox) ...)
183 
184 ;; andmap : (X  ->  boolean) (listof X)  ->  boolean
185 ;; to determine whether p holds for every item on alox
186 ;; that is, (andmap p (list x-1 ... x-n)) = (and (p x-1) (and ... (p x-n)))
187 (define (andmap p alox) ...)
188 
189 ;; ormap : (X  ->  boolean) (listof X)  ->  boolean
190 ;; to determine whether p holds for at least one item on alox
191 ;; that is, (ormap p (list x-1 ... x-n)) = (or (p x-1) (or ... (p x-n)))
192 (define (ormap p alox) ...)
193 |#