This is a simulation of a streetcrossing with traffic lights for all directions.
#: Ampel.tcl - HaJo Gurt - 2005-06-24
#: Street-crossing with traffic-lights
#
# See also: [Traffic lights] - http://wiki.tcl.tk/8410
#
# Todo:
# * Timer
# * Lights for pedestrians
# * Buttons for pedestrians
# * Night-cycle, Detector/Button for cars
# * Moving Cars
#########1#########2#########3#########4#########5#########6#########7#####
package require Tk
proc Ampel {x y r id} {
#: Draw a traffic-light
#: Width 20 , Height 60, Center at yellow
switch -- $r {
"S" {
set x1 [expr {$x-10}]; set x2 [expr {$x+10}]
set y1 [expr {$y-30}]; set y2 [expr {$y+30}]
}
"N" {
set x1 [expr {$x+10}]; set x2 [expr {$x-10}]
set y1 [expr {$y+30}]; set y2 [expr {$y-30}]
}
"E" {
set x1 [expr {$x-30}]; set x2 [expr {$x+30}]
set y1 [expr {$y-10}]; set y2 [expr {$y+10}]
}
"W" {
set x1 [expr {$x+30}]; set x2 [expr {$x-30}]
set y1 [expr {$y+10}]; set y2 [expr {$y-10}]
}
}
.c create rect $x1 $y1 $x2 $y2 -fill $::Box
set x1 [expr {$x-9}]; set x2 [expr {$x+9}]
set y1 [expr {$y-9}]; set y2 [expr {$y+9}]
.c create oval $x1 $y1 $x2 $y2 -tags [list $id "Y" ] -fill $::Dark
switch -- $r {
"S" {
set x1 [expr {$x- 9}]; set x2 [expr {$x+ 9}]
set y1 [expr {$y-11}]; set y2 [expr {$y-29}]
set x3 [expr {$x- 9}]; set x4 [expr {$x+ 9}]
set y3 [expr {$y+11}]; set y4 [expr {$y+29}]
}
"N" {
set x1 [expr {$x- 9}]; set x2 [expr {$x+ 9}]
set y1 [expr {$y+11}]; set y2 [expr {$y+29}]
set x3 [expr {$x- 9}]; set x4 [expr {$x+ 9}]
set y3 [expr {$y-11}]; set y4 [expr {$y-29}]
}
"E" {
set x1 [expr {$x-29}]; set x2 [expr {$x-11}]
set y1 [expr {$y- 9}]; set y2 [expr {$y+ 9}]
set x3 [expr {$x+29}]; set x4 [expr {$x+11}]
set y3 [expr {$y+ 9}]; set y4 [expr {$y- 9}]
}
"W" {
set x1 [expr {$x+29}]; set x2 [expr {$x+11}]
set y1 [expr {$y+ 9}]; set y2 [expr {$y- 9}]
set x3 [expr {$x-29}]; set x4 [expr {$x-11}]
set y3 [expr {$y+ 9}]; set y4 [expr {$y- 9}]
}
}
.c create oval $x1 $y1 $x2 $y2 -tags [list $id "R" ] -fill $::Dark
.c create oval $x3 $y3 $x4 $y4 -tags [list $id "G" ] -fill $::Dark
}
proc Blink {} {
#: Flashing yellow for every direction
incr ::Phase
if {$::Phase > 0} {set ::Phase -1 }
.c itemconfig { A1 || A2 || A3 || A4 } -fill $::Dark
if {$::Phase < 0 } {
.c itemconfig "Y" -fill $::Yellow ;# all yellow lights on
}
}
proc Cmd { {A A1} {S "-"} } {
#: Process commands for a single traffic-light
foreach C $S {
set X "$A && $C"
if { $C=="-" } { .c itemconfig $A -fill $::Dark }
if { $C=="R" } { .c itemconfig $X -fill $::Red }
if { $C=="Y" } { .c itemconfig $X -fill $::Yellow }
if { $C=="G" } { .c itemconfig $X -fill $::Green }
}
}
proc Next {} {
#: Next step in daytime-cycle
global Phase
incr Phase
set P [expr {$Phase%8}]
#wm title . "$Phase : $P" ;# Debug
if {$P==1 } { Cmd A1 "- R" ; Cmd A3 "- R" ; }
if {$P==2 } { Cmd A1 "R" ; Cmd A3 "R"; Cmd A2 "- R Y"; Cmd A4 "- R Y"; }
if {$P==3 } { Cmd A1 "R" ; Cmd A3 "R"; Cmd A2 "- G" ; Cmd A4 "- G" ; }
if {$P==4 } { Cmd A1 "R" ; Cmd A3 "R"; Cmd A2 "- Y" ; Cmd A4 "- Y" ; }
if {$P==5 } { Cmd A1 "R" ; Cmd A3 "R"; Cmd A2 "- R" ; Cmd A4 "- R" ; }
if {$P==6 } { Cmd A1 "- R Y"; Cmd A3 "- R Y"; Cmd A2 "R" ; Cmd A4 "R" ; }
if {$P==7 } { Cmd A1 "- G" ; Cmd A3 "- G" ; Cmd A2 "R" ; Cmd A4 "R" ; }
if {$P==0 } { Cmd A1 "- Y" ; Cmd A3 "- Y" ; Cmd A2 "R" ; Cmd A4 "R" ; }
if {$Phase >= 8} { set Phase 0 }
}
#########1#########2#########3#########4#########5#########6#########7#####
#wm title . "Ampel"
wm title . "Street-crossing with traffic-light"
set canvas_width 400
set canvas_height 400
set a 0
set b 100
set c 300
set d 400
set Street grey66
set Paint grey99
set Corner grey88
set Box black
set Dark grey33
set Red red
set Yellow yellow ;# yellow2 gold
set Green green3 ;# green3 "lime green"
canvas .c -width $canvas_width -height $canvas_height -bg $Street
# Corners:
.c create rect $a $a $b $b -fill $Corner
.c create rect $c $a $d $b -fill $Corner
.c create rect $a $c $b $d -fill $Corner
.c create rect $c $c $d $d -fill $Corner
# Decorations:
.c create line $b $b [expr {$b+100}] $b -fill $Paint ;# N
.c create line [expr {$c-100}] $c $c $c -fill $Paint ;# S
#.c create line $c $b $c [expr {$b+100}] -fill $Paint ;# E
#.c create line $b [expr {$c-100}] $b $c -fill $Paint ;# W
# Traffic-lights:
Ampel [expr {$c+15}] [expr {$c+35}] S A1 ;# South
Ampel [expr {$c+35}] [expr {$b-15}] E A2 ;# East
Ampel [expr {$b-15}] [expr {$b-35}] N A3 ;# North
Ampel [expr {$b-35}] [expr {$c+15}] W A4 ;# West
set Phase 0
frame .f
pack .c .f
button .b0 -text "Blink" -command {Blink}
button .b1 -text "Next" -command {Next}
pack .b0 .b1 -in .f -side leftThere are two cycles: the normal red/red+yellow/green/yellow (e.g. german style), and flashing yellow for all directions (e.g. out-of-order or nighttime).
I had some trouble processing multiple tags, so this is likely not the most elegant solution. Same for the way of rotating the picture of the trafficlight...