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-beginner-reader.ss" "lang")((modname 10.3.1) (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 ;Data Definitions
5 ;
6 ;A circle is a structure
7 ;(make-circle p n s) where p is a posn,
8 ;n is a number, and s is a symbol.
9 
10 (define-struct circle (center radius color))
11 ;
12 ;A rectangle is a structure
13 ;(make-rectangle p m n s) where p is a posn,
14 ;m and n are numbers, and s is a symbol.
15 
16 (define-struct rectangle (upper-left width height color))
17 
18 ;A shape is either
19 ;1. a circle or
20 ;2. a rectangle.
21 ;
22 ;A list-of-shapes is either
23 ;1. an empty list or
24 ;2. (cons s los) where s is a shape and
25 ;los is a list-of-shapes.
26 
27 (define FACE (cons
28               (make-circle (make-posn 50 50)
29                            40
30                            'red)
31               (cons
32                (make-rectangle (make-posn 30 20)
33                                5
34                                5
35                                'blue)
36                (cons
37                 (make-rectangle (make-posn 65 20)
38                                 5
39                                 5
40                                 'blue)
41                 (cons
42                  (make-rectangle (make-posn 40 75)
43                                  20
44                                  10
45                                  'red)
46                  (cons
47                   (make-rectangle (make-posn 45 35)
48                                   10
49                                   30
50                                   'blue) empty))))))
51 
52 ;Template
53 ;fun-for-losh : list-of-shapes -> ???
54 ;Consumes a list-of-shapes.
55 ;
56 ;(define (fun-for-losh alosh)
57 ;  (cond
58 ;    [(empty? alosh) ...]
59 ;    [(circle? (first alosh)) ... (first alosh) (fun-for-losh (rest alosh))]
60 ;    [(rectangle? (first alosh)) ...(first alosh) (fun-for-losh (rest alosh))]
61 ;    [else ...]))
62 
63 ;draw-losh : list-of-shapes -> boolean
64 ;Consumes alosh and draws the shapes on the canvas,
65 ;returning true.  If drawing fails, it returns false.
66 
67 (define (draw-losh alosh)
68   (cond
69     [(empty? alosh) true]
70     [(circle? (first alosh)) (and
71                               (draw-a-circle (first alosh))
72                               (draw-losh (rest alosh)))]
73     [(rectangle? (first alosh)) (and
74                                  (draw-a-rectangle (first alosh))
75                                  (draw-losh (rest alosh)))]
76     [else false]))
77 
78 ;draw-a-circle : circle -> boolean?
79 ;Draws a circle given a-circle (struct circle).
80 
81 (define (draw-a-circle a-circle)
82   (draw-solid-disk (circle-center a-circle)
83                    (circle-radius a-circle)
84                    (circle-color a-circle)))
85 
86 ; draw-a-rectangle : rectangle -> boolean
87 ; Returns true after drawing, consumes a-rect.
88 
89 (define (draw-a-rectangle a-rect)
90   (draw-solid-rect (rectangle-upper-left a-rect)
91                    (rectangle-width a-rect)
92                    (rectangle-height a-rect)
93                    (rectangle-color a-rect)))
94 
95 ;translate-losh : list-of-shapes number -> list-of-shapes
96 ;Given alosh, returns a list-of-shapes that have translated
97 ;delta pixels in the x direction.  This function
98 ;does not affect the canvas.
99 
100 (define (translate-losh alosh delta)
101   (cond
102     [(empty? alosh) empty]
103     [(circle? (first alosh))
104      (cons
105       (make-circle
106        (make-posn (+ (posn-x (circle-center (first alosh)))
107                      delta)
108                   (posn-y (circle-center (first alosh))))
109        (circle-radius (first alosh))
110        (circle-color (first alosh)))
111       (translate-losh (rest alosh) delta))]
112     [(rectangle? (first alosh))
113      (cons
114       (make-rectangle
115        (make-posn (+ (posn-x (rectangle-upper-left (first alosh)))
116                      delta)
117                   (posn-y (rectangle-upper-left (first alosh))))
118        (rectangle-width (first alosh))
119        (rectangle-height (first alosh))
120        (rectangle-color (first alosh)))
121       (translate-losh (rest alosh) delta))]
122     [else (error 'translate-losh "unexpected error")]))
123 
124 ;clear-losh : list-of-shapes -> boolean
125 ;Clears shapes corresponding to entries in alosh
126 ;and returns true.  Does so by calling clear-a-rectangle
127 ;and clear-a-circle.
128 
129 (define (clear-losh alosh)
130   (cond
131     [(empty? alosh) true]
132     [(circle? (first alosh)) (and
133                               (clear-a-circle (first alosh))
134                               (clear-losh (rest alosh)))]
135     [(rectangle? (first alosh)) (and
136                                  (clear-a-rectangle (first alosh))
137                                  (clear-losh (rest alosh)))]
138     [else false]))
139 
140 ; clear-a-circle : circle -> boolean
141 ; Clears a circle given a-circle, returns true if
142 ; evaluation completes successfully, false otherwise.
143 
144 (define (clear-a-circle a-circle)
145   (clear-solid-disk (circle-center a-circle)
146                     (circle-radius a-circle)))
147 
148 ; clear-a-rectangle : rectangle -> boolean
149 ; Clears rectangle specified by a-rect and returns true
150 ; if evaluation suceeds, false otherwise.
151 
152 (define (clear-a-rectangle a-rect)
153   (clear-solid-rect (rectangle-upper-left a-rect)
154                     (rectangle-width a-rect)
155                     (rectangle-height a-rect)))
156 
157 ;Data Definition
158 ;
159 ;A picture is a list-of-shapes?, I think.
160 ;
161 ;draw-and-clear-picture : picture -> boolean
162 ;Draws alosh, sleeps for a while, then clears alosh.
163 ;!!!CHANGE!!! Now it clears, sleeps for a while,
164 ;then draws alosh.
165 
166 (define (draw-and-clear-picture alosh)
167   (and
168 
169    (draw-losh alosh)
170 ;   (sleep-for-a-while 2)
171    (clear-losh alosh)))
172 ;
173 ;move-picture : number picture -> picture
174 ;Draws a picture delta pixels to the right, sleeps for a while,
175 ;clears the picture, and then returns the translated picture.
176 
177 (define (move-picture delta alosh)
178   (cond
179    [(draw-and-clear-picture (translate-losh alosh delta))
180     (translate-losh alosh delta)]
181    [else false]))
182 
183 (start 500 100)
184 
185 (control-left-right FACE 100 move-picture draw-losh)