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