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"))) (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")))))
5 Exercise 39.2.1. Develop the program make-city. It manages a collection of traffic lights. The program should provide four services:
7 1. adding a traffic light with a label (string);
8 2. removing a traffic light by label;
9 3. switching the state of a traffic light with some given label; and
10 4. resetting a traffic light to red with some given label.
12 Hint: The first two services are provided directly; the last two are implemented by the simulated traffic lights.
14 After the development of the program is completed, develop a graphical user interface. Solution
17 make-city : -> traffic-light.
19 A traffic-light is an interface
20 1. 'add-light : string -> (symbol number -> (symbol -> true))
21 2. 'remove-light : string -> true
28 ;;A traffic-light color (TL-color) is either
39 (define Y-RED (+ INTERDIST RADIUS))
40 (define Y-YELLOW (+ Y-RED (* 2 RADIUS) INTERDIST))
41 (define Y-GREEN (+ Y-YELLOW (* 2 RADIUS) INTERDIST))
43 ;;op-bulb : (posn N symbol -> true) symbol number -> boolean
44 ;;Perform op on a bulb given op, color, and x-posn.
46 (define (op-bulb op color x-posn)
48 [(symbol=? color 'red)
49 (op (make-posn x-posn Y-RED) RADIUS 'red)]
50 [(symbol=? color 'yellow)
51 (op (make-posn x-posn Y-YELLOW) RADIUS 'yellow)]
52 [(symbol=? color 'green)
53 (op (make-posn x-posn Y-GREEN) RADIUS 'green)]))
55 ;; fill-bulb : symbol number -> boolean
56 ;; Fills in a given bulb based on color and x-posn; returns true if the function evaluates properly, false otherwise.
58 (define (fill-bulb color x-posn)
59 (op-bulb draw-solid-disk color x-posn))
61 ;; clear-bulb : symbol number -> boolean
62 ;; Clears a bulb given color and x-posn; returns true if evaluation completes, false otherwise.
64 (define (clear-bulb color x-posn)
65 (op-bulb clear-solid-disk color x-posn))
67 ;draw-border : number -> true
68 ;Draws the borders for the 3 traffic lights given x-posn.
70 (define (draw-border x-posn)
71 (and (draw-circle (make-posn x-posn Y-RED) (+ RADIUS 1) 'black)
72 (draw-circle (make-posn x-posn Y-YELLOW) (+ RADIUS 1) 'black)
73 (draw-circle (make-posn x-posn Y-GREEN) (+ RADIUS 1) 'black)))
75 ;switch : symbol symbol number -> true
76 ;Switches clear to fill for the lightbulb given x-posn.
78 (define (switch clear fill x-posn)
80 (fill-bulb fill x-posn)
81 (clear-bulb clear x-posn)))
85 ;;make-traffic-light : symbol number -> (symbol -> true)
86 ;;Consumes location and x-posn, which indicates the position of the traffic light.
87 ;;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).
89 (define (make-traffic-light location x-posn)
92 ;;current-color : TL-color
93 (define current-color 'red)
96 ;;Effect: Changes current-color from 'red to 'green, 'green to 'yellow,
97 ;;or 'yellow to 'red depending on what the current-color is. Returns true.
99 (local ((define previous-color current-color))
100 (begin (set! current-color (next-color current-color))
101 (switch previous-color current-color x-posn))))
103 ;next-color : TL-color -> TL-color
104 ;Given acolor, returns the next logical color.
105 (define (next-color acolor)
107 [(symbol=? acolor 'red) 'green]
108 [(symbol=? acolor 'yellow) 'red]
109 [(symbol=? acolor 'green) 'yellow]))
111 ;;init-current-color : -> true
112 ;;Opens the canvas and draws the outline of the 3 traffic light
113 ;;bulbs as well as lighting up the red lightbulb.
114 (define (init-traffic-light)
115 (begin (draw-border x-posn)
116 (clear-bulb current-color x-posn)
117 (set! current-color 'red)
118 (fill-bulb current-color x-posn)))
119 (define (service-manager msg)
121 [(symbol=? msg 'next) (next)]
122 [(symbol=? msg 'reset) (init-traffic-light)]
123 [else (error 'service-manager "message not understood")])))
124 (begin (init-traffic-light)
131 (list (make-traffic-light 'AdobeCircle 50)
132 (make-traffic-light 'Pereira 200)
133 (make-traffic-light 'CampusDr 350)
134 (make-traffic-light 'HarvardSt 500)
135 (make-traffic-light 'BrenRd 650)
136 (make-traffic-light 'UniversityBlvd 800)))
141 (define (next-callback event)
142 (andmap (lambda (a-light) (a-light 'next)) lights))
144 (define (reset-callback event)
145 (andmap (lambda (a-light) (a-light 'reset)) lights))
148 (build-list (length lights)
150 (local ((define (next-indiv-callback event)
151 ((list-ref lights n) 'next)))
152 (make-button (number->string (add1 n)) next-indiv-callback)))))
154 (create-window (list (list (make-button "Next" next-callback)
155 (make-button "Reset" reset-callback))
