Version 0 of Traffic lights
Updated 2003-02-19 08:44:05
if 0 {Richard Suchenwirth 2003-02-19 - More than a month after we discussed it in the Tcl chatroom, here comes a little traffic light simulator, which might interest children: both to play with a bit, and see how it was done, especially the "states" section below (state machines are child�s play!) - which models the behavior of German traffic lights.
Change phase by clicking on the button, or <Return>. Turning on the timer makes lights automatically change every second. Feel free to modify it! (In Austria I think they have a yellow+green phase between green and yellow ...)
As I wrote this on the iPAQ, please pardon the Regular Polygons workaround. On fully functional Tk, one may replace poly [rp ..] with oval .., and discard the rp proc. }
package require Tk
proc rp {x0 y0 x1 y1 {n 0}} {
set xm [expr {($x0+$x1)/2.}]
set ym [expr {($y0+$y1)/2.}]
set rx [expr {$xm-$x0}]
set ry [expr {$ym-$y0}]
if {$n==0} {set n [expr {round(($rx+$ry)*0.4)}] }
set step [expr {atan(1)*8/$n}]
set res ""
set th [expr {atan(1)*6}] ;#top
for {set i 0} {$i<$n} {incr i} {
lappend res \
[expr {$xm+$rx*cos($th)}] \
[expr {$ym+$ry*sin($th)}]
set th [expr {$th+$step}]
}
set res
}
proc light args {
.c itemconfig light -fill black
foreach i $args {.c itemconfig $i -fill $i}
}
proc next what {
if $::timer {
after 1000 $what
} else {set ::next $what}
}#------------------- the states:
proc red {} {
light red; next red+yellow
}
proc red+yellow {} {
light red yellow; next green
}
proc green {} {
light green; next yellow
}
proc yellow {} {
light yellow; next red
}#----------- Graphical User Interface:
pack [canvas .c -width 120 -height 100]
.c create rect 5 5 35 85 -fill gray20
.c create poly [rp 10 10 30 30] -tags {red light}
.c create poly [rp 10 35 30 55] -tags {yellow light}
.c create poly [rp 10 60 30 80] -tags {green light}
checkbutton .c.t -text Timer -variable timer
set timer 0
.c create window 50 50 -window .c.t -anchor w
button .c.b -text Next -command {eval $next}
.c create window 50 70 -window .c.b -anchor w
bind . <Return> {eval $next}
red ;# initial state