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") (lib "arrow.ss" "teachpack" "htdp"))) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ((lib "draw.ss" "teachpack" "htdp") (lib "arrow.ss" "teachpack" "htdp")))))
4 ;A circle is a structure
5 ;(make-circle ce ra co)
6 ;where ce is a posn, ra is a number, and co is a symbol.
7 
8 ;A rectangle is a structure
9 ;(make-rectangle u w h c)
10 ;where u is a posn, w, h are numbers, and color is a symbol.
11 
12 ;A line is a structure
13 ;(make-line s e c)
14 ;where s, e are posn and c is a symbol.
15 
16 ;A shape is either
17 ;1. a circle,
18 ;2. a rectangle, or
19 ;3. a line.
20 
21 ;translate-posn : posn number number -> posn
22 ;Given a-posn, down, and right, translate the posn down and right.
23 
24 ;process-circle : (circle -> X) circle -> X
25 ;Given operation and a-circle, process the circle according to operation (draw-solid-disk or clear-solid-disk).
26 
27 ;process-rectangle : (posn number number symbol -> X) rectangle -> X
28 ;Perform operation on a-rectangle.
29 
30 ;process-line : (posn posn symbol -> X) line -> X
31 
32 ;draw-a-circle : circle -> boolean
33 ;Given a-circle, draw it and return true.
34 
35 ;draw-a-rectangle : rectangle -> boolean
36 ;clear-a-rectangle : rectangle -> boolean
37 
38 ;clear-a-circle : circle -> boolean
39 ;Given a-circle, clear it and return true.
40 
41 ;translate-circle : circle number number -> circle
42 
43 ;translate-rectangle : rectangle number number -> rectangle
44 ;Given a-rect, right, and down, return a rectangle structure translated right to the right and down.
45 
46 ;Given a-circle and right, return a circle structure moved right towards the x-axis and down towards the y-axis.
47 
48 ;translate-right : number posn number symbol -> circle
49 ;Given right, center, radius, and color, return a circle structure translated right units towards the x-axis.
50 
51 ;translate-down : number posn number symbol -> circle
52 ;Given down, center, radius, and color, return a circle structure translated down units towards the y-axis.
53 
54 ;translate-line : line number number -> line
55 ;Given a-line, right, and down, return a new line translated right and down.
56 
57 ;process-shape : (shape -> X) shape -> X
58 
59 ;draw-shape : (shape -> X) shape -> X
60 
61 ;clear-shape : (shape -> X) shape -> X
62 
63 ;translate-shape : (shape -> shape) shape number number -> shape
64 
65 ;draw-losh : (listof shapes) -> boolean 
66 ;Draws a (listof shapes) and return true.
67 
68 ;clear-losh : (listof shapes) -> boolean 
69 ;Clears a (listof shapes) and return true.
70 
71 ;translate-losh : (listof shapes) number number -> (listof shapes)
72 ;Translates alosh right and down and returns a new (listof shapes).
73 
74 (define-struct circle (center radius color))
75 
76 (define-struct rectangle (upper-left width height color))
77 
78 (define-struct line (start end color))
79 
80 (define (translate-posn a-posn right down)
81   (make-posn (+ right (posn-x a-posn))
82              (+ down (posn-y a-posn))))
83 
84 (define (process-circle operation a-circle)
85   (operation (circle-center a-circle)
86              (circle-radius a-circle)
87              (circle-color a-circle)))
88 
89 (define (process-rectangle operation a-rect)
90   (operation (rectangle-upper-left a-rect)
91              (rectangle-width a-rect)
92              (rectangle-height a-rect)
93              (rectangle-color a-rect)))
94 
95 (define (process-line operation a-line)
96   (operation (line-start a-line)
97              (line-end a-line)
98              (line-color a-line)))
99 
100 (define (draw-a-circle a-circle)
101   (process-circle draw-solid-disk a-circle))
102 
103 (define (draw-a-rectangle a-rect)
104   (process-rectangle draw-solid-rect a-rect))
105 
106 (define (draw-a-line a-line)
107   (process-line draw-solid-line a-line))
108 
109 (define (clear-a-circle a-circle)
110   (process-circle clear-solid-disk a-circle))
111 
112 (define (clear-a-rectangle a-rect)
113   (process-rectangle clear-solid-rect a-rect))
114 
115 (define (clear-a-line a-line)
116   (process-line clear-solid-line a-line))
117 
118 (define (translate-circle a-circle right down)
119   (local ((define (translate-right-down center radius color)
120             (make-circle (translate-posn center right down)
121                          radius
122                          color)))
123     (process-circle translate-right-down a-circle)))
124 
125 (define (translate-rectangle a-rect right down)
126   (local ((define (translate-right-down upper-left width height color)
127             (make-rectangle (translate-posn upper-left right down)
128                             width
129                             height
130                             color)))
131     (process-rectangle translate-right-down a-rect)))
132 
133 
134 (define (translate-line a-line right down)
135   (local ((define (translate-right-down start end color)
136             (make-line (translate-posn start right down)
137                        (translate-posn end right down)
138                        color)))
139     (process-line translate-right-down a-line)))
140 
141 (define (process-shape operation a-shape)
142   (operation a-shape))
143 
144 (define (draw-shape a-shape)
145   (cond
146     [(circle? a-shape) (process-shape draw-a-circle a-shape)]
147     [(rectangle? a-shape) (process-shape draw-a-rectangle a-shape)]
148     [(line? a-shape) (process-shape draw-a-line a-shape)]))
149 
150 (define (clear-shape a-shape)
151   (cond
152     [(circle? a-shape) (process-shape clear-a-circle a-shape)]
153     [(rectangle? a-shape) (process-shape clear-a-rectangle a-shape)]
154     [(line? a-shape) (process-shape clear-a-line a-shape)]))
155 
156 (define (translate-shape a-shape right down)
157   (local ((define (translate-shape-right-down a-shape)
158             (cond
159               [(circle? a-shape) (translate-circle a-shape right down)]
160               [(rectangle? a-shape) (translate-rectangle a-shape right down)]
161               [(line? a-shape) (translate-line a-shape right down)])))
162     (process-shape translate-shape-right-down a-shape)))
163 
164 (define (draw-losh alosh)
165   (andmap draw-shape alosh))
166 
167 (define (clear-losh alosh)
168   (andmap clear-shape alosh))
169 
170 (define (translate-losh alosh right down)
171   (local ((define (translate-shape-right-down a-shape)
172             (translate-shape a-shape right down)))
173     (map translate-shape-right-down alosh)))
174 
175 (define SQUIDWARD
176   (list (make-circle (make-posn 100 100)
177                      80
178                      'blue)
179         (make-circle (make-posn 60 60)
180                      10
181                      'red)
182         (make-circle (make-posn 140 60)
183                      10
184                      'red)
185         (make-rectangle (make-posn 90 80)
186                         20
187                         50
188                         'yellow)
189         (make-rectangle (make-posn 60 140)
190                         80
191                         20
192                         'green)
193         (make-line (make-posn 60 150)
194                    (make-posn 140 150)
195                    'brown)
196         (make-line (make-posn 60 200)
197                    (make-posn 140 200)
198                    'brown)))
199 
200 ;(start 500 500)
201 ;(translate-losh SQUIDWARD 15 25)
202 ;(draw-losh SQUIDWARD)
203 
204 (define LUNAR (list (make-circle (make-posn 375
205                                             375)
206                                  100 'blue)
207                     (make-line (make-posn (- 375 (* 50 (sqrt 2))) (+ 375 (* 50 (sqrt 2))))
208                                (make-posn 150 600)
209                                'black)
210                     (make-line (make-posn (+ 375 (* 50 (sqrt 2))) (+ 375 (* 50 (sqrt 2))))
211                                (make-posn 600 600)
212                                'black)
213                     (make-rectangle (make-posn 400 300) 100 75 'gray)))
214 
215 
216 ;move-lr : number (listof shape) -> (listof shape)
217 ;Given right and alosh, moves the (listof shapes) right.
218 
219 (define (move-lr right alosh)
220   (translate-losh alosh right 0))
221 
222 ;move-ud : number (listof shape) -> (listof shape)
223 ;Given down and alosh, moves the (listof shapes) down.
224 
225 (define (move-ud down alosh)
226   (translate-losh alosh 0 down))
227 
228 ;clear-and-draw-losh : (listof shapes) -> boolean
229 ;Clears and draws alosh.
230 (define (clear-and-draw-losh alosh)
231   (and (clear-losh alosh)
232        (draw-losh alosh)))
233 
234 ;lunar-lander : (listof shapes) number -> boolean
235 ;Given alosh and delta, moves alosh using a GUI controller.
236 
237 (start 750 750)
238 (draw-losh LUNAR)
239 (control LUNAR 5 move-lr move-ud clear-and-draw-losh)