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-advanced-reader.ss" "lang")((modname |39.2|) (read-case-sensitive #t) (teachpacks ((lib "guess-gui.ss" "teachpack" "htdp") (lib "guess.ss" "teachpack" "htdp") (lib "gui.ss" "teachpack" "htdp") (lib "draw.ss" "teachpack" "htdp"))) (htdp-settings #(#t constructor repeating-decimal #t #t none #f ((lib "guess-gui.ss" "teachpack" "htdp") (lib "guess.ss" "teachpack" "htdp") (lib "gui.ss" "teachpack" "htdp") (lib "draw.ss" "teachpack" "htdp")))))
4 ;TODO:
5 ;
6 ;Fill in examples for make-city
7 ;Abstract x-posn using absolute definitions
8 
9 #|
10 Exercise 39.2.1.   Develop the program make-city. It manages a collection of traffic lights. The program should provide four services:
11 
12    1. adding a traffic light with a label (string);
13    2. removing a traffic light by label;
14    3. switching the state of a traffic light with some given label; and
15    4. resetting a traffic light to red with some given label.
16 
17 Hint: The first two services are provided directly; the last two are implemented by the simulated traffic lights.
18 
19 After the development of the program is completed, develop a graphical user interface.    Solution
20 |#
21 
22 ;;Data Definition
23 ;;A traffic-light color (TL-color) is either
24 ;;1. 'red,
25 ;;2. 'yellow, or
26 ;;3. 'green.
27 
28 ;;A traffic-light is an interface
29 ;;1. 'next : -> true
30 ;;2. 'reset : -> true
31 
32 ;;A city is an interface
33 ;;1.'add-light :: symbol -> void
34 ;;2.'remove-light :: symbol -> void
35 ;;3.'access-light :: symbol -> traffic-light
36 
37 ;make-city : symbol -> city
38 ;;Consumes location.  Produces a city interface, which can ultimately be used to perform 4 possible services: 
39 
40 ;;   1. adding a traffic light with a label (string);
41 ;;   2. removing a traffic light by label;
42 ;;   3. switching the state of a traffic light with some given label; and
43 ;;   4. resetting a traffic light to red with some given label.
44 
45 ;;Examples
46 
47 ;;((make-city) 'add-light 'Germany) should set city-lights to (list (list 'Germany (make-traffic-light 'Germany))).  It should also draw the traffic-light on the canvas.  Output should be true.
48 ;;(define my-city (make-city "Los Angeles"))
49 ;;((my-city 'add-light) 'Boulevard)
50 ;;((my-city 'add-light) 'Street)
51 ;;((my-city 'add-light) 'Drive)
52 ;;((my-city 'add-light) 'Road)
53 ;;Should give a city with 4 traffic-lights and should draw 4 traffic lights on a canvas.
54 
55 (define (make-city location)
56   (local
57     (;;State Variables:
58      ;;city-lights : (listof (list symbol traffic-light))
59      ;;Records the traffic-lights in the city, the first symbol represents the location
60      (define city-lights empty)
61      
62      ;;add-light : symbol -> void
63      ;;Effect: Adds (list symbol traffic-light) to the front of city-lights
64      (define (add-light alocation) 
65        (local ((define x-posn (+ 200 (* 100 (sub1 (length city-lights))))))
66          (set! city-lights
67                (cons (list alocation (make-traffic-light alocation x-posn))
68                      city-lights))))
69      
70      ;;remove-light : symbol -> void
71      ;;Effect: Removes a light from city-lights
72      (define (remove-light alocation)
73        (local ((define (remove-aux alox x)
74                  (filter (lambda (an-x) (not (equal? (first an-x) x))) alox))
75                (define x-posn (+ 200 (* 100 (sub1 (sub1 (length city-lights)))))))
76          (begin 
77            (clear-bulb 'red x-posn) 
78            (clear-bulb 'yellow x-posn)
79            (clear-bulb 'green x-posn)
80            (clear-border x-posn)
81            (set! city-lights (remove-aux city-lights alocation)))))
82      
83      
84      (define (access-light alocation)
85        (local ((define (access-aux alox x)
86                  (cond
87                    [(empty? alox) false]
88                    [(equal? (first (first alox)) x) (second (first alox))]
89                    [else (access-aux (rest alox) x)])))
90          (access-aux city-lights alocation)))
91      (define (service-manager msg) 
92        (cond
93          [(equal? msg 'add-light) add-light]
94          [(equal? msg 'remove-light) remove-light]
95          [(equal? msg 'access-light) access-light]
96          [else (error 'make-city "message not understood")])))
97     service-manager))
98 
99 ;;Model
100 
101 ;;make-traffic-light : symbol number -> (symbol -> true)
102 ;;Consumes location and x-posn, which indicates the position of the traffic light.
103 ;;Output: Creates a function that acts as a service manager, which has two functions.  If the argument 'next is passed, a given traffic light will switch (effect: current-color will switch for the given light and the canvas will change accordingly).  If the argument 'reset is passed, the traffic light will be reset to 'red (effect: current-color and canvas will change accordingly).
104 
105 (define (make-traffic-light location x-posn)
106   (local
107     (;;State Variable:
108      ;;current-color : TL-color
109      (define current-color 'red)
110      
111      ;;next : -> true
112      ;;Effect: Changes current-color from 'red to 'green, 'green to 'yellow,
113      ;;or 'yellow to 'red depending on what the current-color is.  Returns true.
114      (define (next)
115        (local ((define previous-color current-color))
116          (begin (set! current-color (next-color current-color))
117                 (switch previous-color current-color x-posn))))
118      
119      ;next-color : TL-color -> TL-color
120      ;Given acolor, returns the next logical color.
121      (define (next-color acolor)
122        (cond
123          [(symbol=? acolor 'red) 'green]
124          [(symbol=? acolor 'yellow) 'red]
125          [(symbol=? acolor 'green) 'yellow]))
126      
127      ;;init-current-color : -> true
128      ;;Opens the canvas and draws the outline of the 3 traffic light
129      ;;bulbs as well as lighting up the red lightbulb.
130      (define (init-traffic-light)
131        (begin (draw-border x-posn)
132               (clear-bulb current-color x-posn)
133               (set! current-color 'red)
134               (fill-bulb current-color x-posn)))
135      (define (service-manager msg)
136        (cond
137          [(symbol=? msg 'next) (next)]
138          [(symbol=? msg 'reset) (init-traffic-light)]
139          [else (error 'service-manager "message not understood")])))
140     (begin (init-traffic-light)
141            service-manager)))
142 
143 
144 ;;View
145 
146 (define WIDTH 1000)
147 (define HEIGHT 340)
148 (define RADIUS 40)
149 (define INTERDIST 20)
150 (define Y-RED (+ INTERDIST RADIUS))
151 (define Y-YELLOW (+ Y-RED (* 2 RADIUS) INTERDIST))
152 (define Y-GREEN (+ Y-YELLOW (* 2 RADIUS) INTERDIST))
153 
154 ;;op-bulb : (posn N symbol -> true) symbol number -> boolean
155 ;;Perform op on a bulb given op, color, and x-posn.
156 
157 (define (op-bulb op color x-posn)
158   (cond
159     [(symbol=? color 'red)
160      (op (make-posn x-posn Y-RED) RADIUS 'red)]
161     [(symbol=? color 'yellow)
162      (op (make-posn x-posn Y-YELLOW) RADIUS 'yellow)]
163     [(symbol=? color 'green)
164      (op (make-posn x-posn Y-GREEN) RADIUS 'green)]))
165 
166 ;; fill-bulb : symbol number -> boolean
167 ;; Fills in a given bulb based on color and x-posn; returns true if the function evaluates properly, false otherwise.
168 
169 (define (fill-bulb color x-posn)
170   (op-bulb draw-solid-disk color x-posn))
171 
172 ;; clear-bulb : symbol number -> boolean
173 ;; Clears a bulb given color and x-posn; returns true if evaluation completes, false otherwise.
174 
175 (define (clear-bulb color x-posn)
176   (op-bulb clear-solid-disk color x-posn))
177 
178 ;;op-border : (posn number symbol -> true) number -> true
179 ;;Performs an operation on the borders of circles of a traffic light.
180 
181 (define (op-border op x-posn)
182   (and (op (make-posn x-posn Y-RED) (+ RADIUS 1) 'black)
183        (op (make-posn x-posn Y-YELLOW) (+ RADIUS 1) 'black)
184        (op (make-posn x-posn Y-GREEN) (+ RADIUS 1) 'black)))
185 
186 ;;draw-border : number -> true
187 ;;Draws the borders for the 3 traffic lights given x-posn.
188 
189 (define (draw-border x-posn)
190   (op-border draw-circle x-posn))
191 
192 ;;clear-border : number -> true
193 ;;Clears the borders for the 3 traffic lights given x-posn.
194 
195 (define (clear-border x-posn)
196   (op-border clear-circle x-posn))
197 
198 ;switch : symbol symbol number -> true
199 ;Switches clear to fill for the lightbulb given x-posn.
200 
201 (define (switch clear fill x-posn)
202   (and
203    (fill-bulb fill x-posn)
204    (clear-bulb clear x-posn)))
205 
206 
207 
208 
209 #|
210 (define lights
211   (list (make-traffic-light 'AdobeCircle 50)
212         (make-traffic-light 'Pereira 200)
213         (make-traffic-light 'CampusDr 350)
214         (make-traffic-light 'HarvardSt 500)
215         (make-traffic-light 'BrenRd 650)
216         (make-traffic-light 'UniversityBlvd 800)))
217 
218 (start WIDTH HEIGHT)
219 
220 ;;Controller
221 
222 (define (next-callback event)
223   (andmap (lambda (a-light) (a-light 'next)) lights))
224 
225 (define (reset-callback event)
226   (andmap (lambda (a-light) (a-light 'reset)) lights))
227 
228 (define next-buttons
229 (build-list (length lights)
230             (lambda (n)
231               (local ((define (next-indiv-callback event)
232                         ((list-ref lights n) 'next)))
233                 (make-button (number->string (add1 n)) next-indiv-callback)))))
234 
235 (create-window (list (list (make-button "Next" next-callback)
236                            (make-button "Reset" reset-callback))
237                      next-buttons))
238 
239 |#
240 
241 (start WIDTH HEIGHT)
242 
243 (define my-city (make-city "Los Angeles"))
244 ((my-city 'add-light) 'Germany)
245 ((my-city 'add-light) 'Naples)
246 ((my-city 'add-light) 'Paris)
247 ((my-city 'add-light) 'Italy)