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