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 |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 (define WIDTH 100)
5 (define HEIGHT 340)
6 (define RADIUS 40)
7 (define INTERDIST 20)
8 (define X-BULB (/ WIDTH 2))
9 (define Y-RED (+ INTERDIST RADIUS))
10 (define Y-YELLOW (+ Y-RED (* 2 RADIUS) INTERDIST))
11 (define Y-GREEN (+ Y-YELLOW (* 2 RADIUS) INTERDIST))
12 
13 ;A traffic-light color (TL-color) is either
14 ;1. 'red,
15 ;2. 'yellow, or
16 ;3. 'green.
17 
18 ;;State Variable:
19 ;;current-color : TL-color
20 (define current-color 'red)
21 
22 ;next : -> true
23 ;Effect: Changes current-color from 'red to 'green, 'green to 'yellow, or 'yellow to 'red depending on what the current-color is.  Returns true once evaluation completes.
24 
25 (define (next)
26   (local ((define previous-color current-color))
27     (begin (set! current-color (next-color current-color))
28                  (switch current-color previous-color))))
29 
30 ;next-color : TL-color -> TL-color
31 ;Given acolor, returns the next logical color.
32 
33 (define (next-color acolor)
34   (cond
35     [(symbol=? acolor 'red) 'green]
36     [(symbol=? acolor 'yellow) 'red]
37     [(symbol=? acolor 'green) 'yellow]))
38 
39 ;;init-current-color : -> true
40 ;Opens the canvas and draws the outline of the 3 traffic light bulbs as well as lighting up the red lightbulb.
41 
42 (define (init-current-color)
43   (begin (start WIDTH HEIGHT)
44          (draw-circle (make-posn X-BULB Y-RED) (+ RADIUS 1) 'black)
45          (draw-circle (make-posn X-BULB Y-YELLOW) (+ RADIUS 1) 'black)
46          (draw-circle (make-posn X-BULB Y-GREEN) (+ RADIUS 1) 'black)
47          (set! current-color 'red)
48          (fill-bulb current-color)))
49 
50 ;; fill-bulb : symbol -> boolean
51 ;; Fills in a given bulb based on color; returns true if the function evaluates properly, false otherwise.
52 
53 (define (fill-bulb color)
54   (cond
55     [(symbol=? color 'red)
56      (draw-solid-disk (make-posn X-BULB Y-RED) RADIUS 'red)]
57     [(symbol=? color 'yellow)
58      (draw-solid-disk (make-posn X-BULB Y-YELLOW) RADIUS 'yellow)]
59     [(symbol=? color 'green)
60      (draw-solid-disk (make-posn X-BULB Y-GREEN) RADIUS 'green)]))
61 
62 ;; clear-bulb : symbol -> boolean
63 ;; Clears a bulb given color; returns true if evaluation completes, false otherwise.
64 
65 (define (clear-bulb color)
66   (cond
67     [(symbol=? color 'red)
68      (clear-solid-disk (make-posn X-BULB Y-RED) RADIUS 'red)]
69     [(symbol=? color 'yellow)
70      (clear-solid-disk (make-posn X-BULB Y-YELLOW) RADIUS 'yellow)]
71     [(symbol=? color 'green)
72      (clear-solid-disk (make-posn X-BULB Y-GREEN) RADIUS 'green)]))
73 
74 ;; switch : symbol symbol -> boolean
75 ;; Fills in bulb based on fill and clears another based on clear to switch colors.  Returns true if evaluation completes, false otherwise.
76 
77 (define (switch fill clear)
78   (and
79    (fill-bulb fill)
80    (clear-bulb clear)))
81 
82 (init-current-color)