This is a simulation of a streetcrossing with traffic lights for all directions. ---- #: Ampel.tcl - HaJo Gurt - 2005-06-25 #: Street-crossing with traffic-lights # # See also: [Traffic lights] - http://wiki.tcl.tk/8410 # # Todo: # * Lights for pedestrians # * Buttons for pedestrians # * Night-cycle, Detector/Button for cars # * Moving Cars, see: # ** "Toy cars" : http://wiki.tcl.tk/12266 # ** "Car Racing in Tcl" : http://wiki.tcl.tk/4364 # ** "Braitenberg Vehicles" : http://wiki.tcl.tk/9047 #########1#########2#########3#########4#########5#########6#########7##### package require Tk set Debug -1 ;# -1: Off / 0: Status in Window-Title / 1: Console-Log set Title "Streetcrossing with trafficlight" proc RotateItem {w tagOrId Ox Oy angle} { #: Rotates a canvas item any angle about an arbitrary point #: by rotating the coordinates of the object. Works only with polygon and line. set angle [expr {$angle * atan(1) * 4 / 180.0}] ;# Radians foreach id [$w find withtag $tagOrId] { ;# Do each component separately set xy {} foreach {x y} [$w coords $id] { # rotates vector (Ox,Oy)->(x,y) by angle clockwise set x [expr {$x - $Ox}] ;# Shift to origin set y [expr {$y - $Oy}] set xx [expr {$x * cos($angle) - $y * sin($angle)}] ;# Rotate set yy [expr {$x * sin($angle) + $y * cos($angle)}] set xx [expr {$xx + $Ox}] ;# Shift back set yy [expr {$yy + $Oy}] lappend xy $xx $yy } $w coords $id $xy } } proc MoveItem {w Tag dx dy } { $w move $Tag $dx $dy } proc Animate {} { #: Move cars MoveItem .c "Car3" 2 0 MoveItem .c "Car4" -2 0 } proc Car {x y Tag angle c1} { #: Draw a car around x,y in color c1 #: Standard size: Width: 40, Length 80 set x1 [expr {$x-20}]; set x2 [expr {$x+20}] set y1 [expr {$y-40}]; set y2 [expr {$y+40}] #.c create rect $x1 $y1 $x2 $y2 -fill $c1 ;# Outline .c create poly $x1 $y1 $x1 $y2 $x2 $y2 $x2 $y1 -tags $Tag -fill $c1 # Windshield: set x1 [expr {$x-17}]; set x2 [expr {$x+17}] ;# 15 set y1 [expr {$y- 9}]; set y2 [expr {$y-22}] ;# 10,20 .c create poly $x1 $y1 $x1 $y2 $x2 $y2 $x2 $y1 -tags $Tag -fill $::Window # Headlights: set x1 [expr {$x-18}]; set x2 [expr {$x- 6}] set y1 [expr {$y-37}]; set y2 [expr {$y-40}] .c create poly $x1 $y1 $x1 $y2 $x2 $y2 $x2 $y1 -tags $Tag -fill yellow set x1 [expr {$x+18}]; set x2 [expr {$x+ 6}] .c create poly $x1 $y1 $x1 $y2 $x2 $y2 $x2 $y1 -tags $Tag -fill yellow # Taillights: set x1 [expr {$x+18}]; set x2 [expr {$x+12}] set y1 [expr {$y+37}]; set y2 [expr {$y+40}] .c create poly $x1 $y1 $x1 $y2 $x2 $y2 $x2 $y1 -tags $Tag -fill red set x1 [expr {$x-18}]; set x2 [expr {$x-12}] .c create poly $x1 $y1 $x1 $y2 $x2 $y2 $x2 $y1 -tags $Tag -fill red RotateItem .c $Tag $x $y $angle } #########1#########2#########3#########4#########5#########6#########7##### 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 } #########1#########2#########3#########4#########5#########6#########7##### proc every {ms body} { #: Repeating timer eval $body; after $ms [info level 0] } proc Check {} { #: Check if delay for next step is over #puts "$::Auto $::Time $::Mode" ;# Debug if {$::Auto == 0} { return } incr ::Time -1 if {$::Debug>=0} { wm title . "$::Mode - Phase: $::Phase Time: $::Time" } else { wm title . $::Title } if {$::Time <= 0} { Step } } proc Step {} { #: Go to next step of currently running TL-cycle if {$::Debug>=1} {puts "- $::Mode $::Select" } set ::Time 0 switch -- $::Mode { "Slow" { Mode1; return } "Fast" { Mode2; return } default { Blink } } } #########1#########2#########3#########4#########5#########6#########7##### proc Cmd { {A A1} {L "-"} } { #: Process commands for a single traffic-light if {$::Debug>=1} { puts "$::Mode - #$::Phase T$::Time - Cmd: $A $L" } foreach C $L { set X "$A && $C" if {$C eq "-"} { .c itemconfig $A -fill $::Dark } if {$C eq "R"} { .c itemconfig $X -fill $::Red } if {$C eq "Y"} { .c itemconfig $X -fill $::Yellow } if {$C eq "G"} { .c itemconfig $X -fill $::Green } } } proc Blink {} { #: "Mode0" : Flashing yellow for all directions 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 set ::Time 2 } else { set ::Time 1 set ::Mode $::Select ;# safe for switching modes } } proc Mode1 {} { #: "Slow" mode: discreet states, same timing for all directions global Phase Time Mode Select incr Phase if {$Phase >= 8} { set Phase 0; set Mode $Select } ;# safe time to switch modes set P [ expr {$Phase%8} ] #wm title . "$Phase : $P" ;# Debug if {$::Debug>=1} { puts "Mode1: $P" } if {$P==1} { set Time 1; Cmd A1 "- R" ; Cmd A3 "- R" ; Cmd A2 "- R" ; Cmd A4 "- R" } ;# if {$P==2} { set Time 3; Cmd A1 "- R" ; Cmd A3 "- R" ; Cmd A2 "- R Y"; Cmd A4 "- R Y" } if {$P==3} { set Time 10; Cmd A1 "- R" ; Cmd A3 "- R" ; Cmd A2 "- G" ; Cmd A4 "- G" } if {$P==4} { set Time 3; Cmd A1 "- R" ; Cmd A3 "- R" ; Cmd A2 "- Y" ; Cmd A4 "- Y" } if {$P==5} { set Time 1; Cmd A1 "- R" ; Cmd A3 "- R" ; Cmd A2 "- R" ; Cmd A4 "- R" } ;# if {$P==6} { set Time 3; Cmd A1 "- R Y"; Cmd A3 "- R Y"; Cmd A2 "- R" ; Cmd A4 "- R" } if {$P==7} { set Time 10; Cmd A1 "- G" ; Cmd A3 "- G" ; Cmd A2 "- R" ; Cmd A4 "- R" } if {$P==0} { set Time 3; Cmd A1 "- Y" ; Cmd A3 "- Y" ; Cmd A2 "- R" ; Cmd A4 "- R" } if {$::Debug>=0} { wm title . "$::Mode : Phase: $::Phase Time: $::Time" } } proc Mode2 {} { ;# #: "Fast" mode: overlapping R/Y-phases, shorter green for minor street global Phase Time Mode Select incr Phase if {$Phase >= 6} { set Phase 0; set Mode $Select } ;# safe time to switch modes set P [ expr {$Phase%6} ] if {$::Debug>=1} { puts "Mode2: $P" } if {$P==1} { set Time 2; Cmd A1 "- R" ; Cmd A3 "- R" ; Cmd A2 "- R Y"; Cmd A4 "- R Y" } if {$P==2} { set Time 10; Cmd A1 "- R" ; Cmd A3 "- R" ; Cmd A2 "- G" ; Cmd A4 "- G" } ;# E-W long if {$P==3} { set Time 3; Cmd A1 "- R" ; Cmd A3 "- R" ; Cmd A2 "- Y" ; Cmd A4 "- Y" } if {$P==4} { set Time 2; Cmd A1 "- R Y"; Cmd A3 "- R Y"; Cmd A2 "- R" ; Cmd A4 "- R" } if {$P==5} { set Time 6; Cmd A1 "- G" ; Cmd A3 "- G" ; Cmd A2 "- R" ; Cmd A4 "- R" } ;# N-S short if {$P==0} { set Time 3; Cmd A1 "- Y" ; Cmd A3 "- Y" ; Cmd A2 "- R" ; Cmd A4 "- R" } if {$::Debug>=0} { wm title . "$::Mode : Phase: $::Phase Time: $::Time" } } #########1#########2#########3#########4#########5#########6#########7##### wm title . $Title if {$::Debug>=1} { catch {console show} } 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" set Window grey44 set Auto 1 set Phase 0 set Time 0 set Mode "Blink" 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 #.c create line $a [expr {$c-100}] $d [expr {$c-100}] -fill $Paint -dash {6 4} ;# E-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 # Cars: Car [expr {$c-50}] [expr {$c+50}] "Car1" 0 cyan ;# S Car [expr {$b+50}] [expr {$b-50}] "Car2" 180 deeppink ;# N Car [expr {$b-50}] [expr {$c-50}] "Car3" 90 blue ;# W Car [expr {$c+50}] [expr {$b+50}] "Car4" 270 salmon ;# E frame .f pack .c .f tk_optionMenu .opt Select "Blink" "Slow" "Fast" checkbutton .cA -text "Automatic" -command {Step} -variable Auto button .bS -text "Step" -command {Step} pack .opt .cA .bS -in .f -side left every 500 Check every 20 Animate ---- I added a timer for automatic operation, as well as a new mode. Now there are three modes: flashing yellow for all directions (e.g. out-of-order or nighttime), and two different red/red+yellow/green/yellow (e.g. german style) modes named "slow" and "fast". Switching between these modes only happens after a complete cycle, e.g. when all lights are red. (E.g. when selecting a new mode, you have to wait until it happens) The "slow" mode has even timing for all directions, the "fast" mode has shorter green-time for the minor street (north-south on this crossing). 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. The routine from [Canvas Rotation] would have been nice (but a bit of overkill for this program), but it does not support rect and oval (yet). [RS]: As rect and oval items are determined only by two diagonal bbox corners, they can't really be rotated. But it's possible to convert a rect to a polygon (trivially), and for ovals see [Regular polygons]. [HJG] Ok, simple cars and simple animation added, but yet unrelated to the trafficlights. I had the idea of using the [Braitenberg Vehicles] to populate the streets. They would just need central object-sensors to avoid collision with other cars, and "heat-sensors" at the right to sense the red trafficlights. But it looks like the object-detection is not good enough - the car moves forward too long, until it runs over the object in front, e.g. a car that is waiting at a red light. [gold] added pix below ---- ***Screenshots*** [gold] added pix below [http://img244.imageshack.us/img244/6786/tclwikistreetcrossingwijo3.png0] [http://img244.imageshack.us/img244/tclwikistreetcrossingwijo3.png/1/w320.png] [http://img244.imageshack.us/my.php?image=tclwikistreetcrossingwijo3.png] [http://img141.imageshack.us/my.php?image=tclwikistreetcrossingwiox7.png] [http://tclerswiki.googlepages.com/TCL_wiki_Street_Crossing_with_Traffic_Lights.PNG] ---- !!!!!! %| [Category Toys] |% !!!!!!