Updated 2016-04-28 20:41:16 by gold

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