if 0 {Richard Suchenwirth 2004-08-24 - Another fun project, which may be interesting for children: an animated highway, on which cars and trucks go east or west. Initially, all stand still (so the cars can be inspected) - you can increase speed with <Up>, or decrease with <Down>. That's all so far - comments welcome, as always!
}
array unset g set g(#) 0 set g(dx) 0
#-- convenience wrapper for car definitions:
proc define {name code} {set ::g($name) $code}if 0 {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. Here's a few car types (feel free to make them better):}
define Sedan {
poly 1 4 0 -17 34 -22 47 -37 95 -37 105 -22 130 -16 130 4 -fill pink
poly 34 -22 45 -35 48 -33 40 -22 -fill white
poly 52 -34 43 -20 70 -20 70 -34 -fill white -outline black
poly 73 -20 73 -34 91 -33 95 -20 -fill white -outline black
line 38 3 38 -21 40 -21
line 71 3 71 -20
line 94 -10 96 -20
oval 10 -10 30 10 -fill white -outline black -width 6
oval 93 -10 113 10 -fill white -outline black -width 6
}
define Police {
poly 1 4 0 -17 34 -22 47 -37 95 -37 105 -22 130 -16 130 4 -fill white
poly 34 -22 45 -35 48 -33 40 -22 -fill lightblue
poly 52 -34 43 -20 70 -20 70 -34 -fill lightblue -outline black
poly 73 -20 73 -34 91 -33 95 -20 -fill lightblue -outline black
poly 38 3 38 -21 96 -20 90 3 -fill black
rect 60 -44 66 -37 -fill red
oval 10 -10 30 10 -fill white -outline black -width 6
oval 93 -10 113 10 -fill white -outline black -width 6
}
define Station {
poly 1 4 0 -17 34 -22 47 -37 118 -37 130 -16 130 4 -fill pink
poly 34 -22 45 -35 48 -33 40 -22 -fill white
poly 52 -34 43 -20 70 -20 70 -34 -fill white -outline black
poly 73 -20 73 -34 91 -34 95 -20 -fill white -outline black
poly 98 -20 94 -34 114 -34 120 -20 -fill white -outline black
line 38 3 38 -21 40 -21
line 71 3 71 -20
oval 10 -10 30 10 -fill white -outline black -width 6
oval 93 -10 113 10 -fill white -outline black -width 6
}
define Convertible {
poly 1 4 0 -17 34 -22 47 -37 50 -37 47 -22 110 -22 130 -16 130 4 -fill pink
poly 34 -22 45 -35 48 -33 40 -22 -fill white
poly 80 -20 80 -25 105 -27 105 -20 -fill black
oval 55 -32 65 -22 -fill orange
line 38 3 38 -21 40 -21
line 71 3 71 -20
oval 10 -10 30 10 -fill white -outline black -width 6
oval 93 -10 113 10 -fill white -outline black -width 6
}
define Truck {
rect 0 2 120 -8 -fill black
rect 0 -45 40 -2 -fill pink
rect 0 -40 5 -25 -fill white
rect 7 -40 25 -25 -fill white
rect 50 -60 265 -13 -fill pink
text 150 -33 -text "Tcl & Tk Deliver!" -font {Helvetica 18}
oval 10 -10 30 10 -fill darkgrey -outline black -width 6
oval 65 -10 85 10 -fill darkgrey -outline black -width 6
oval 95 -10 115 10 -fill darkgrey -outline black -width 6
rect 180 -11 260 2 -fill black
oval 190 -10 210 10 -fill darkgrey -outline black -width 6
oval 225 -10 245 10 -fill darkgrey -outline black -width 6
}if 0 {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(#)]
if [info exists g($what)] {
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
}
} else {
eval $w create $what $x $y $args -tag $tag
}
if [in $args east] {
lappend g(east) $tag
$w scale $tag $x $y -1 1
} else {
lappend g(west) $tag
}
}if 0 {This procedure is called 20 times a second. It moves the cars by a random amount, limited by the speed set by the user:}
proc animate w {
global g
foreach car $g(west) {
$w move $car [expr {$g(dx)*rand()}] 0
if {[lindex [$w bbox $car] 2]<0} {$w move $car 2000 0}
}
foreach car $g(east) {
$w move $car [expr {-$g(dx)*rand()}] 0
if {[lindex [$w bbox $car] 0]>1000} {$w move $car -2000 0}
}
}#-- General utilities:
proc every {ms body} {eval $body; after $ms [info level 0]}
proc in {list element} {expr {[lsearch -exact $list $element]>=0}}if 0 {For rapid turnaround, the main part was coded so the script can be repeatedly sourced - 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 come the cars!
add .c 100 70 Truck lightblue
add .c 1500 85 Sedan orange
add .c 500 100 Police -
add .c 100 150 Station magenta east
add .c 500 170 Convertible red east
add .c 1500 190 Truck bisque east
bind . <Up> {incr g(dx) -10}
bind . <Down> {if {$g(dx)} {incr g(dx) 10}}
every 50 {animate .c}#-- Debugging helpers:
bind . <Escape> {source $argv0}
bind . <F1> {console show}