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