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 (define WIDTH 500)
5 (define HEIGHT 500)
6 (define RADIUS 40)
7 (define INTERDIST 20)
8 (define X-BULB (/ WIDTH 6))
9 (define Y-RED (+ (* 6 INTERDIST) RADIUS))
10 (define Y-YELLOW (+ Y-RED (* 2 RADIUS) INTERDIST))
11 (define Y-GREEN (+ Y-YELLOW (* 2 RADIUS) INTERDIST))
12 (define Y-BULB (/ HEIGHT 6))
13 (define X-RED (+ (* 6 INTERDIST) RADIUS))
14 (define X-YELLOW (+ X-RED (* 2 RADIUS) INTERDIST))
15 (define X-GREEN (+ X-YELLOW (* 2 RADIUS) INTERDIST))
16 
17 ;A traffic-light color (TL-color) is either
18 ;1. 'red,
19 ;2. 'yellow, or
20 ;3. 'green.
21 
22 ;;State Variables:
23 
24 ;;current-color1 : TL-color
25 ;;The current color of the first traffic-light.
26 (define current-color1 'red)
27 
28 ;;current-color2: TL-color
29 ;;The current color of the second traffic-light.
30 (define current-color2 'red)
31 
32 ;;change-color : -> void
33 ;;Changes the color of the first and second traffic lights, ie, its effect is to change current-color1 and current-color2 in a way that obeys traffic laws.
34 
35 (define (change-color)
36   (cond
37     [(symbol=? current-color1 'green)
38      (begin (set! current-color1 'yellow)
39             (set! current-color2 'red))]
40     [(symbol=? current-color1 'yellow)
41      (begin (set! current-color1 'red)
42             (set! current-color2 'green))]
43     [(symbol=? current-color2 'green)
44      (begin (set! current-color1 'red)
45             (set! current-color2 'yellow))]
46     [(symbol=? current-color2 'yellow)
47      (begin (set! current-color1 'green)
48             (set! current-color2 'red))]
49     [else (begin (set! current-color1 'green)
50                  (set! current-color2 'red))]))
51 
52 ;next : -> true
53 ;Effect: Changes the traffic light colors, redraws the traffic lights, then returns true.
54 
55 (define (next)
56   (local ((define previous-color1 current-color1)
57           (define previous-color2 current-color2))
58     (begin (change-color)
59            (switch current-color1 previous-color1 1)
60            (switch current-color2 previous-color2 2))))
61 
62 ;;init-current-color : -> true
63 ;Opens the canvas and draws the outline of the 3 traffic light bulbs as well as lighting up the red lightbulb.
64 
65 (define (init-current-color)
66   (begin (start WIDTH HEIGHT)
67          (draw-circle (make-posn X-BULB Y-RED) (+ RADIUS 1) 'black)
68          (draw-circle (make-posn X-BULB Y-YELLOW) (+ RADIUS 1) 'black)
69          (draw-circle (make-posn X-BULB Y-GREEN) (+ RADIUS 1) 'black)
70          (draw-circle (make-posn X-RED Y-BULB) (+ RADIUS 1) 'black)
71          (draw-circle (make-posn X-YELLOW Y-BULB) (+ RADIUS 1) 'black)
72          (draw-circle (make-posn X-GREEN Y-BULB) (+ RADIUS 1) 'black)
73          (set! current-color1 'red)
74          (set! current-color2 'red)
75          (fill-bulb current-color1 1)
76          (fill-bulb current-color2 2)))
77 
78 ;;op-bulb : symbol N -> boolean
79 ;; Performs op on a given bulb based on color and bulb#; returns true if the function evaluates properly, false otherwise.
80 
81 (define (op-bulb color op bulb#)
82   (local ((define x-bulb (cond
83                            [(= bulb# 1) X-BULB]
84                            [(symbol=? color 'red) X-RED]
85                            [(symbol=? color 'yellow) X-YELLOW]
86                            [(symbol=? color 'green) X-GREEN]))
87           (define y-bulb (cond
88                            [(= bulb# 2) Y-BULB]
89                            [(symbol=? color 'red) Y-RED]
90                            [(symbol=? color 'yellow) Y-YELLOW]
91                            [(symbol=? color 'green) Y-GREEN])))
92     (cond
93       [(symbol=? color 'red)
94        (op (make-posn x-bulb y-bulb) RADIUS 'red)]
95       [(symbol=? color 'yellow)
96        (op (make-posn x-bulb y-bulb) RADIUS 'yellow)]
97       [(symbol=? color 'green)
98        (op (make-posn x-bulb y-bulb) RADIUS 'green)])))
99 
100 ;; fill-bulb : symbol N -> boolean
101 ;; Fills in a given bulb based on color and bulb#; returns true if the function evaluates properly, false otherwise.
102 
103 (define (fill-bulb color bulb#)
104   (op-bulb color draw-solid-disk bulb#))
105 
106 ;; clear-bulb : symbol N N -> boolean
107 ;; Clears a given bulb based on color, x-bulb, and y-bulb; returns true if the function evaluates properly, false otherwise.
108 
109 (define (clear-bulb color bulb#)
110   (op-bulb color clear-solid-disk bulb#))
111 
112 ;; switch : symbol symbol -> boolean
113 ;; Fills in bulb based on fill and clears another based on clear to switch colors.  Returns true if evaluation completes, false otherwise.
114 
115 (define (switch fill clear bulb#)
116   (and
117    (clear-bulb clear bulb#)
118    (fill-bulb fill bulb#)))
119 
120 (init-current-color)
121 
122 ;;Code that needs to be modified
123 
124 ;;Controller
125 
126 (define (next-callback event)
127   (next))
128 
129 (create-window (list (list (make-button "Next" next-callback))))