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.1|) (read-case-sensitive #t) (teachpacks ((lib "draw.ss" "teachpack" "htdp") (lib "arrow.ss" "teachpack" "htdp") (lib "gui.ss" "teachpack" "htdp"))) (htdp-settings #(#t constructor repeating-decimal #t #t none #f ((lib "draw.ss" "teachpack" "htdp") (lib "arrow.ss" "teachpack" "htdp") (lib "gui.ss" "teachpack" "htdp")))))
4 ;;Data Definition
5 ;;A traffic-light color (TL-color) is either
6 ;;1. 'red,
7 ;;2. 'yellow, or
8 ;;3. 'green.
9 
10 ;;View
11 
12 (define WIDTH 1000)
13 (define HEIGHT 340)
14 (define RADIUS 40)
15 (define INTERDIST 20)
16 (define Y-RED (+ INTERDIST RADIUS))
17 (define Y-YELLOW (+ Y-RED (* 2 RADIUS) INTERDIST))
18 (define Y-GREEN (+ Y-YELLOW (* 2 RADIUS) INTERDIST))
19 
20 ;;op-bulb : (posn N symbol -> true) symbol number -> boolean
21 ;;Perform op on a bulb given op, color, and x-posn.
22 
23 (define (op-bulb op color x-posn)
24   (cond
25     [(symbol=? color 'red)
26      (op (make-posn x-posn Y-RED) RADIUS 'red)]
27     [(symbol=? color 'yellow)
28      (op (make-posn x-posn Y-YELLOW) RADIUS 'yellow)]
29     [(symbol=? color 'green)
30      (op (make-posn x-posn Y-GREEN) RADIUS 'green)]))
31 
32 ;; fill-bulb : symbol number -> boolean
33 ;; Fills in a given bulb based on color and x-posn; returns true if the function evaluates properly, false otherwise.
34 
35 (define (fill-bulb color x-posn)
36   (op-bulb draw-solid-disk color x-posn))
37 
38 ;; clear-bulb : symbol number -> boolean
39 ;; Clears a bulb given color and x-posn; returns true if evaluation completes, false otherwise.
40 
41 (define (clear-bulb color x-posn)
42   (op-bulb clear-solid-disk color x-posn))
43 
44 ;draw-border : number -> true
45 ;Draws the borders for the 3 traffic lights given x-posn.
46 
47 (define (draw-border x-posn)
48   (and (draw-circle (make-posn x-posn Y-RED) (+ RADIUS 1) 'black)
49        (draw-circle (make-posn x-posn Y-YELLOW) (+ RADIUS 1) 'black)
50        (draw-circle (make-posn x-posn Y-GREEN) (+ RADIUS 1) 'black)))
51 
52 ;switch : symbol symbol number -> true
53 ;Switches clear to fill for the lightbulb given x-posn.
54 
55 (define (switch clear fill x-posn)
56   (and
57    (fill-bulb fill x-posn)
58    (clear-bulb clear x-posn)))
59 
60 ;;Model
61 
62 ;;make-traffic-light : symbol number -> (symbol -> true)
63 ;;Consumes location and x-posn, which indicates the position of the traffic light.
64 ;;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).
65 
66 (define (make-traffic-light location x-posn)
67   (local
68     (;;State Variable:
69      ;;current-color : TL-color
70      (define current-color 'red)
71      
72      ;;next : -> true
73      ;;Effect: Changes current-color from 'red to 'green, 'green to 'yellow,
74      ;;or 'yellow to 'red depending on what the current-color is.  Returns true.
75      (define (next)
76        (local ((define previous-color current-color))
77          (begin (set! current-color (next-color current-color))
78                 (switch previous-color current-color x-posn))))
79      
80      ;next-color : TL-color -> TL-color
81      ;Given acolor, returns the next logical color.
82      (define (next-color acolor)
83        (cond
84          [(symbol=? acolor 'red) 'green]
85          [(symbol=? acolor 'yellow) 'red]
86          [(symbol=? acolor 'green) 'yellow]))
87      
88      ;;init-current-color : -> true
89      ;;Opens the canvas and draws the outline of the 3 traffic light
90      ;;bulbs as well as lighting up the red lightbulb.
91      (define (init-traffic-light)
92        (begin (draw-border x-posn)
93               (clear-bulb current-color x-posn)
94               (set! current-color 'red)
95               (fill-bulb current-color x-posn)))
96      (define (service-manager msg)
97        (cond
98          [(symbol=? msg 'next) (next)]
99          [(symbol=? msg 'reset) (init-traffic-light)]
100          [else (error 'service-manager "message not understood")])))
101     (begin (init-traffic-light)
102            service-manager)))
103 
104 (start WIDTH HEIGHT)
105 (define lights
106   (list (make-traffic-light 'AdobeCircle 50)
107         (make-traffic-light 'Pereira 200)
108         (make-traffic-light 'CampusDr 350)
109         (make-traffic-light 'HarvardSt 500)
110         (make-traffic-light 'BrenRd 650)
111         (make-traffic-light 'UniversityBlvd 800)))
112 
113 
114 ;;Controller
115 
116 (define (next-callback event)
117   (andmap (lambda (a-light) (a-light 'next)) lights))
118 
119 (define (reset-callback event)
120   (andmap (lambda (a-light) (a-light 'reset)) lights))
121 
122 (define next-buttons
123 (build-list (length lights)
124             (lambda (n)
125               (local ((define (next-indiv-callback event)
126                         ((list-ref lights n) 'next)))
127                 (make-button (number->string (add1 n)) next-indiv-callback)))))
128 
129 (create-window (list (list (make-button "Next" next-callback)
130                            (make-button "Reset" reset-callback))
131                      next-buttons))
132