array unset g
set g(#) 0
set g(dx) 0
#-- convenience wrapper for car definitions:
proc define {name code} {set ::g($name) $code}Every vehicle is a set of canvas items, with coordinates and colors. The dummy color "pink" will later be overridden by the color wanted by the user, or drawn at random. Here's a few car types (feel free to make them better): define Sedan {
poly 1 -6 0 -25 34 -29 47 -44 95 -44 105 -30 130 -27 128 -6 -fill pink -outline black
poly 32 -29 45 -43 48 -42 40 -30 -fill white -outline black
poly 52 -41 43 -28 70 -28 70 -41 -fill white -outline black
poly 73 -28 73 -41 91 -41 95 -28 -fill white -outline black
line 38 -7 38 -28 42 -28
line 71 -7 71 -30
line 96 -10 96 -30
rect 1 -22 4 -16 -fill white
rect 123 -19 129 -14 -fill red
oval 10 -18 28 0 -fill grey90 -outline black -width 4
oval 92 -18 110 0 -fill grey90 -outline black -width 4
}
define Pickup {
poly 2 -6 0 -27 3 -29 34 -29 47 -47 77 -47 79 -30 130 -30 130 -6 -fill pink -outline black
poly 34 -30 45 -45 48 -43 40 -32 -fill white -outline black
poly 52 -44 43 -30 70 -30 70 -44 -fill white -outline black
line 38 -7 38 -31 40 -31
line 71 -7 71 -30
oval 10 -18 28 0 -fill pink -outline black -width 4
oval 95 -18 113 0 -fill pink -outline black -width 4
rect 0 -22 4 -15 -fill orange
rect 126 -27 130 -15 -fill red
}
define Camper {
poly 46 -47 33 -47 45 -66 136 -66 146 -61 146 -21 75 -21 -fill beige -outline black
rect 49 -61 69 -55 -fill lightblue
rect 96 -54 123 -38 -fill lightblue
line 109 -53 109 -38
poly 2 -6 0 -27 3 -29 34 -29 47 -47 77 -47 77 -21 140 -21 140 -6 -fill pink -outline black
poly 34 -30 45 -45 48 -43 40 -32 -fill lightblue -outline black
poly 52 -44 43 -30 70 -30 70 -44 -fill lightblue -outline black
line 38 -7 38 -31 40 -31
line 71 -7 71 -30
oval 10 -18 28 0 -fill white -outline black -width 4
oval 105 -18 123 0 -fill white -outline black -width 4
rect 0 -22 4 -15 -fill orange
rect 136 -22 140 -15 -fill red
}
define Police {
poly 1 -6 0 -27 34 -32 47 -47 95 -47 105 -32 130 -26 130 -6 -fill white
poly 34 -32 45 -45 48 -43 40 -32 -fill lightblue
poly 52 -44 43 -30 70 -30 70 -44 -fill lightblue -outline black
poly 73 -30 73 -44 91 -43 95 -30 -fill lightblue -outline black
poly 38 -7 38 -31 96 -30 90 -7 -fill black
rect 60 -54 66 -47 -fill red
oval 10 -18 28 0 -fill white -outline black -width 4
oval 93 -18 111 0 -fill white -outline black -width 4
}
define Van {
poly 1 -6 0 -27 34 -32 47 -47 118 -47 130 -26 130 -6 -fill pink
poly 34 -32 45 -45 48 -43 40 -32 -fill white -outline black
poly 52 -44 43 -30 70 -30 70 -44 -fill white -outline black
poly 73 -30 73 -44 91 -44 95 -30 -fill white -outline black
poly 98 -30 94 -44 114 -44 120 -30 -fill white -outline black
line 38 -7 38 -31 40 -31
line 71 -7 71 -30
oval 10 -18 28 0 -fill white -outline black -width 4
oval 93 -18 111 0 -fill white -outline black -width 4
}
define Ambulance {
poly 1 -6 0 -27 34 -32 47 -47 118 -47 130 -26 130 -6 -fill white
poly 34 -32 45 -45 48 -43 40 -32 -fill lightblue
poly 52 -44 43 -30 70 -30 70 -44 -fill lightblue -outline red
poly 73 -30 73 -44 91 -44 95 -30 -fill white -outline red
poly 98 -30 94 -44 114 -44 120 -30 -fill white -outline red
line 38 -7 38 -31 40 -31
line 71 -7 71 -30
poly 48 -22 52 -22 52 -26 58 -26 58 -22 62 -22 62 -18 58 -18 58 -14 52 -14 52 -18 48 -18 -fill red
rect 59 -54 64 -47 -fill blue
oval 10 -18 28 0 -fill red -outline black -width 4
oval 93 -18 111 0 -fill red -outline black -width 4
}
define Convertible {
poly 1 -6 0 -24 34 -28 47 -43 55 -41 47 -28 110 -28 130 -22 130 -6 -fill pink
poly 34 -28 45 -41 50 -39 42 -28 -fill white
poly 80 -26 80 -31 105 -33 105 -26 -fill black
oval 58 -38 68 -28 -fill orange
line 40 -7 40 -27 46 -27
line 73 -7 73 -28
oval 10 -18 28 0 -fill white -outline black -width 4
oval 93 -18 111 0 -fill white -outline black -width 4
}
define Beetle {
poly 0 -6 3 -8 6 -18 20 -26 33 -26 36 -27 44 -42 72 -42 82 -38 92 -27 104 -7 100 -6 -fill pink -outline black -smooth 1
line 12 -20 34 -28 36 -6 -smooth 1
line 68 -6 69 -21 97 -24 100 -6 -smooth 1
line 39 -26 39 -9
line 63 -39 63 -9
rect 2 -12 7 -7 -fill grey90
rect 38 -9 68 -6 -fill darkgrey
rect 96 -18 99 -13 -fill red
rect 99 -12 103 -7 -fill grey90
poly 40 -27 45 -35 50 -38 61 -38 61 -27 -fill lightblue -outline black
poly 65 -27 65 -38 74 -37 78 -33 79 -30 77 -27 -fill lightblue -outline black
oval 12 -16 28 0 -fill white -outline black -width 3
oval 76 -16 92 0 -fill white -outline black -width 3
}
define Truck {
rect 0 -18 120 -8 -fill black
rect 0 -55 40 -12 -fill pink
rect 0 -50 5 -35 -fill white
rect 7 -50 25 -35 -fill white
rect 50 -70 265 -23 -fill pink
text 150 -43 -text "Tcl & Tk Deliver!" -font {Helvetica 18}
oval 10 -20 30 0 -fill darkgrey -outline black -width 6
oval 65 -20 85 0 -fill darkgrey -outline black -width 6
oval 95 -20 115 0 -fill darkgrey -outline black -width 6
rect 180 -21 260 -8 -fill black
oval 190 -20 210 0 -fill darkgrey -outline black -width 6
oval 225 -20 245 0 -fill darkgrey -outline black -width 6
}
define Prototype1 {
poly 0 -8 0 -13 18 -22 128 -22 131 -13 131 -9 115 -4 10 -4 -fill pink
poly 48 -32 90 -31 98 -22 128 -22 127 -23 101 -23 91 -33 -fill pink -outline black
poly 47 -31 30 -19 30 -7 67 -7 67 -31 -fill pink -outline grey
poly 70 -7 93 -7 98 -22 90 -31 70 -31 -fill pink -outline grey
poly 34 -22 67 -22 67 -30 47 -30 -fill black -outline grey
poly 70 -22 98 -22 90 -30 70 -30 -fill black -outline grey
poly 18 -22 32 -22 48 -31 -fill black -outline grey
poly 102 -24 125 -24 94 -32 -fill black -outline grey
poly 0 -8 0 -13 10 -13 10 -5 -fill grey -outline black
poly 115 -5 131 -9 131 -13 115 -13 -fill grey -outline black
oval 11 -18 29 0 -fill pink -outline black -width 5
oval 94 -18 112 0 -fill pink -outline black -width 5
}
define Steamroller {
oval 0 -30 30 0 -fill brown -width 2
line 15 -15 15 -35 -width 3
poly 10 -35 30 -35 39 -15 110 -15 110 -45 10 -45 -fill orange -outline red
text 50 -37 -text ACME
oval 65 -40 105 0 -fill brown -width 2
oval 83 -22 87 -18 -outline black
line 71 -60 71 -44
line 102 -60 102 -44
rect 67 -65 107 -60 -fill brown
oval 82 -55 91 -46 -fill bisque
}
define Motorbike {
oval 10 -18 28 0 -outline black -width 3
oval 56 -18 74 0 -outline black -width 3
rect 22 -29 28 -24 -fill pink
line 19 -9 32 -29 37 -27 -width 3 -fill grey90
line 36 -8 66 -9 52 -17 38 -9 -fill grey90 -width 3
poly 29 -19 31 -24 52 -20 53 -8 36 -8 -fill pink
rect 44 -24 70 -20 -fill black
oval 36 -53 49 -38 -fill pink
rect 37 -48 40 -44 -fill black
line 40 -5 44 -8 37 -19 52 -27 48 -40 37 -28 -width 7 -fill gray30
}The add proc adds, of course, a vehicle to the road. You specify its position, type, color, and optionally the direction it goes, east or west (which is the default). proc add {w x y what args} {
global g
set tag t[incr g(#)]
foreach part [split $g($what) \n] {
if {[llength $part]==0} continue
set color [lindex $args 0]
set id [eval $w create [string map "pink $color" $part] -tag $tag]
$w move $id $x $y
}
$w addtag y$y withtag $tag
if [in $args east] {
lappend g(east) $tag
$w scale $tag $x $y -1 1
} else {
lappend g(west) $tag
}
}This procedure is called 20 times a second. It moves the cars by a random amount, limited by the speed set by the user. When they drive out of sight, they are deleted, and a new random car is created at the other side of the viewport, so the road never gets empty: proc animate w {
global g
foreach car $g(west) {
foreach {x0 y0 x1 y1} [$w bbox $car] break
set dx [expr {$g(dx)*(0.5+rand())}]
set x2 [expr {$x0+$dx}]
set ym [expr {($y0+$y1)/2.}]
if {[$w find overlap $x2 $ym [expr {$x2-50}] $ym] eq ""} {
$w move $car $dx 0
if {$x1 < 0} {
$w delete $car
lremove g(west) $car
random'car $w 1000 $y1
}
}
}
foreach car $g(east) {
foreach {x0 y0 x1 y1} [$w bbox $car] break
set dx [expr {-$g(dx)*(0.5+rand())}]
set x2 [expr {$x1+$dx}]
set ym [expr {($y0+$y1)/2.}]
if {[$w find overlap $x2 $ym [expr {$x2+50}] $ym] eq ""} {
$w move $car $dx 0
if {$x0 > 1000} {
$w delete $car
lremove g(east) $car
random'car $w -200 $y1
}
}
}
}This routine picks one of the patterns that start with an uppercase letter (so if you want no Steamroller, just change its name to #Steamroller or such) with a random color: proc random'car {w x y} {
global g
set type [lpick [array names g {[A-Z]*}]]
set color [lpick {
beige yellow orange red brown purple green blue magenta grey90 pink
darkblue darkgreen white black cyan
}]
set direction [expr {$x>0? "west" : "east"}]
set y [expr {($y/10)*10}]
add $w $x $y $type $color $direction
}
#-- General utilities:
proc every {ms body} {eval $body; after $ms [info level 0]}
proc in {list element} {expr {[lsearch -exact $list $element]>=0}}
proc lpick list {lindex $list [expr {int(rand()*[llength $list])}]}
proc lremove {listVar element} {
upvar 1 $listVar list
set pos [lsearch $list $element]
set list [lreplace $list $pos $pos]
}For rapid turnaround, the main part was coded so the script can be repeatedly sourced (by just hitting <Escape>) - either the canvas is created; or it's cleared, and all events flushed: if [catch {
pack [canvas .c -width 600] -fill both -expand 1
}] {
.c delete all
foreach i [after info] {after cancel $i}
}
.c create rect 0 0 1000 30 -fill green4 ;# "north" meadow
.c create line 0 120 1000 120 -fill yellow -width 3 ;# mid-road line
.c create rect 0 210 1000 1000 -fill green3 ;# "south" meadow
#-- And here comes the initial set of vehicles
add .c 1000 50 Steamroller orange
add .c 100 50 Prototype1 lightblue
add .c 500 100 Motorbike orange
add .c 300 100 Police -
add .c 300 150 Camper magenta east
add .c 600 150 Beetle red east
add .c 150 200 Truck bisque east
add .c 1000 200 Sedan darkblue east
bind . <Up> {incr g(dx) -10}
bind . <Down> {if {$g(dx)} {incr g(dx) 10}}
every 50 {
animate .c
.c raise y50; .c raise y100; .c raise y150; .c raise y200
}
bind . <Escape> {source $argv0}
bind . <F1> {console show}AM Maybe add random cars at random intervals? - RS: Done in this revised version. SS Very nice! - RS: See HTC Magician for the story of how I brought it to run under Tclkit Mobile 3.Could you add a frog that the user controls to navigate the road? The frog would be place at the bottom of the screen, and the user would need to get the frog to the top of the screen, without getting run over.
