Description edit
See trains2.tcl for the second version with a passenger and a freight train, or trains3.tcl for large scenery with some animationsRichard Suchenwirth - This weekend fun project varies the theme of Model railroading with Tcl and takes a windshield perspective (TclTrain has the engineer's point of view). Imagine you're standing at a railroad crossing, red lights are flashing... and then the train runs by - an armour yellow F7A, boxcars, gondola, trailer on flat car.. and finally, the caboose. That's what the following piece shows on a Tk canvas. You can control train speed with left (faster), middle (emergency stop), and right (slower, or back) mouse buttons.In order to cope with the higher data complexity, some more structure and a rr namespace were introduced. The API, so to speak, is simple:
rr::init $canvas ;# creates and packs a canvas, if not existing rr::create $type $number [$otherdata] ;# make a vehicle (loco or car) rr::train $number $consist ;# vehicles of which a train is made up rr::run $trainnumber ;# guess what that does ;-)See the demo at end for concrete examples.
Changes edit
PYK 2012-10-09: eliminated update[BigL] When running this program I got the following error message
missing close-bracket
missing close-bracket
while executing
"wm title . [.c canvasx 582],["
(command bound to event)2018-04-05: just an error introduced by PYK when adding braces to an expr. Fixed.Code edit
package require Tk
namespace eval rr {
variable data
set data(curx) 700
set data(y) 190
proc init w {
variable data
set data(c) $w
set data(speed) 6
if ![winfo exists $w] {
canvas $w -width 700 -height 220 -bg lightblue
pack $w
}
$w delete all
foreach i [after info] {after cancel $i}
bind . <Shift-1> [list source [info script]]
bind . <1> {incr rr::data(speed) 1}
bind . <2> {set rr::data(speed) 0}
bind . <3> {incr rr::data(speed) -1}
bind .c <Motion> {wm title . [.c canvasx %x],[expr {[.c canvasy %y]-190}]}
$w create poly 0 220 0 77 42 67 99 130 155 63 199 102 255 83 312 126\
380 116 433 105 501 75 600 104 700 100 700 220 -fill green3 -tag bg
$w create rect 0 191 7000 200 -fill brown -outline brown ;# ballast
$w create poly 0 220 100 130 200 220 -fill gray50 ;# road
$w create poly 97 220 100 130 103 220 -outline yellow -fill gray50
$w create line 0 190 7000 190 -fill gray -width 3 ;# rail
crossing 210 215
}
proc define {name def} {
variable data
set data($name) $def
}
proc create {type id args} {
variable data
set c $data(c)
set tag $type:$id
foreach i [split $data($type) \n] {
set cmd [lindex $i 0]
switch $cmd {
bogie {
set x [lindex $i 1]
set diameter 21
$c create oval $x -$diameter [expr {$x+$diameter}] 0\
-fill black -outline white -tag $tag
set x1 [expr {$x+[lindex $i 2]}]
$c create oval $x1 -$diameter [expr {$x1+$diameter}] 0\
-fill black -outline white -tag $tag
$c create rect [expr {$x-5}] [expr {-$diameter/2-5}]\
[expr {$x1+$diameter+5}] [expr {-$diameter/2+5}] -fill gray20 -tag $tag
}
f7abody {
set t [list f7abody $tag]
$c create rect 10 -25 430 -22 -fill black -tag $tag
$c create poly \
17 -9 30 -85 35 -88 58 -90 60 -92 67 -106 70 -108 73 -110 \
425 -110 425 -15 410 -15 400 -25 295 -25 290 -15 165 -15 \
160 -25 45 -25 35 -9 -fill gold -tag $t
$c create rect 30 -81 53 -69 -fill black -tag $t
$c create text 31 -81 -text $id -anchor nw -fill white -tag $t
$c create poly 67 -102 72 -101 76 -97 70 -87 62 -92 \
-fill white -outline black -tag $t
$c create poly 71 -81 80 -94 94 -94 94 -81 -fill white \
-outline black -tag $t
$c create rect 98 -97 114 -52 -outline gold3 -tag $t
$c create rect 101 -94 111 -81 -fill white -tag $t ;# cab door window
$c create rect 118 -97 420 -80 -outline gold3 \
-tag $t ;# cooler grill
for {set i 121} {$i<420} {incr i 3} {
$c create line $i -97 $i -80 -fill gold3 -tag $t
}
$c create rect 140 -110 424 -100 -fill gray75 \
-outline gray75 -tag $t;# roof
$c create line 100 -113 110 -113 -arrow both \
-arrowshape {-5 -5 3} -width 2 -tag $t ;# horns
$c create rect 103 -115 107 -110 -fill black -tag $t
$c create oval 150 -77 165 -62 -fill gray50 -tag $t
$c create oval 300 -77 315 -62 -fill gray50 -tag $t
$c create text 145 -56 -text "U N I O N P A C I F I C" -fill red \
-font {Helvetica 13 bold} -anchor nw -tag $t
$c create text 55 -56 -text $id -fill red -font {Helvetica 13 bold}\
-anchor nw -tag $t
$c create line 55 -37 423 -37 -fill red -width 3 -tag $t
}
boxcarbody {
$c create rect 0 -25 380 -22 -fill black -tag $tag
$c create rect 10 -26 370 -110 -fill [lindex $args 1] -tag $tag
set rgrey grey[expr {round(rand()*40+50)}]
$c create rect 10 -105 370 -110 -fill $rgrey -tag $tag
$c create rect 160 -100 220 -30 -tag $tag
$c create text 100 -70 -text [lindex $args 0] -fill white -tag $tag
$c create text 100 -50 -text $id -fill white -tag $tag
}
caboosebody {
$c create rect 0 -25 300 -22 -fill black -tag $tag
$c create poly 35 -25 35 -110 120 -110 120 -140 190 -140\
190 -110 270 -110 270 -25\
-fill [lindex $args 1] -tag $tag
$c create line 10 -10 10 -100 -tag $tag
$c create line 290 -10 290 -100 -tag $tag
set rgrey grey[expr {round(rand()*40+10)}]
$c create rect 10 -100 120 -110 -fill $rgrey -tag $tag
$c create rect 118 -135 192 -140 -fill $rgrey -tag $tag
$c create rect 190 -100 290 -110 -fill $rgrey -tag $tag
$c create rect 210 -105 215 -140 -fill black -tag $tag
window $tag 130 -130 18 15 2 15
window $tag 50 -80 19 17 2 15
window $tag 200 -80 19 17 2 15
$c create text 150 -90 -text [lindex $args 0] -fill white -tag $tag
$c create text 150 -50 -text $id -fill white -tag $tag
$c create arc 40 -30 85 -85 -style arc -start 180 \
-extent 90 -outline yellow -width 1 -tag $tag
$c create arc 220 -30 265 -85 -style arc -start 270 \
-extent 90 -outline yellow -width 1 -tag $tag
}
flatcarbody {
$c create rect 0 -25 380 -22 -fill black -tag $tag
$c create rect 10 -26 370 -35 -fill [lindex $args 1] -tag $tag
$c create text 80 -29 -text [lindex $args 0] -fill white -tag $tag
$c create text 220 -29 -text $id -fill white -tag $tag
}
gondolabody {
$c create rect 0 -25 380 -22 -fill black -tag $tag
$c create rect 10 -26 370 -90 -fill [lindex $args 1] -tag $tag
$c create text 100 -70 -text [lindex $args 0] -fill white -tag $tag
$c create text 100 -50 -text $id -fill white -tag $tag
}
trailer {
set color [lindex $i 1]
$c create rect 40 -110 340 -50 -fill $color -tag $tag
$c create text 190 -80 -text "ROADWAY" \
-font {Helvetica 40} -fill green4 -tag $tag
$c create line 80 -50 80 -35 -width 3 -tag $tag
$c create oval 240 -50 260 -30 -fill gray50 -tag $tag
$c create oval 280 -50 300 -30 -fill gray50 -tag $tag
$c create oval 245 -45 255 -35 -fill $color -tag $tag
$c create oval 285 -45 295 -35 -fill $color -tag $tag
}
"" continue
default {error "bad definition word $cmd:\n$i"}
}
}
}
proc train {name rstock} {
variable data
set c $data(c)
set newx 0
foreach i $rstock {
$c move $i $data(curx) $data(y)
set data(curx) [lindex [$c bbox $i] 2]
$c addtag $name withtag $i
}
}
proc crossing {x y} {
variable data
set c $data(c)
$c create line [expr {$x-10}] [expr {$y-40}] [expr {$x+15}] [expr {$y-40}]\
-width 3 -tag fg
$c create rect $x $y [expr {$x+5}] [expr {$y-70}] -fill orange -tag fg
$c create line [expr {$x-15}] [expr {$y-80}] [expr {$x+20}] [expr {$y-60}]\
-width 5 -fill white -tag fg
$c create line [expr {$x-15}] [expr {$y-60}] [expr {$x+20}] [expr {$y-80}]\
-width 5 -fill white -tag fg
$c create oval [expr {$x-8}] [expr {$y-45}] [expr {$x-18}] [expr {$y-35}]\
-fill white -tag fg
$c create oval [expr {$x-10}] [expr {$y-43}] [expr {$x-16}] [expr {$y-37}]\
-fill black -tag {fg blink0}
$c create oval [expr {$x+15}] [expr {$y-45}] [expr {$x+25}] [expr {$y-35}]\
-fill white -tag fg
$c create oval [expr {$x+17}] [expr {$y-43}] [expr {$x+23}] [expr {$y-37}]\
-fill black -tag {fg blink1}
set data(blink) 1
flashCrossing 0
}
proc flashCrossing {which} {
variable data
set c $data(c)
if $data(blink) {$c itemconfig blink$which -fill red}
set which [expr {1-$which}]
$c itemconfig blink$which -fill black
after 250 [list rr::flashCrossing $which]
}
proc window {t x y w h {n 1} {space 10}} {
variable data
set c $data(c)
for {set i 0} {$i<$n} {incr i} {
$c create rect $x $y [expr {$x+$w}] [expr {$y+$h}] -fill black -tag $t
$c create rect [expr {$x+3}] [expr {$y+3}] [expr {$x+$w}] [expr {$y+$h}]\
-fill white -tag $t
set x [expr {$x+$w+$space}]
}
}
proc run {train} {
variable data
set c $data(c)
$c move $train -1 0
after 0 [list after idle [list [namespace current]::run2 $train]]
}
proc run2 {train} {
variable data
set c $data(c)
if {[lindex [$c bbox $train] 2] < 0} {
$c move $train 5000 0
set data(blink) 0
} elseif {[lindex [$c bbox $train] 0] < 1500} {
set data(blink) 1
}
after [expr {10-$data(speed)}] [list after idle [list [namespace current]::run $train]]
$c raise fg
}
define F7A {
bogie 55 60
bogie 305 60
f7abody
}
define boxcar {
bogie 40 40
bogie 280 40
boxcarbody
}
define gondola {
bogie 40 40
bogie 280 40
gondolabody
}
define flatcar {
bogie 40 40
bogie 280 40
trailer gray85
flatcarbody
}
define caboose {
bogie 40 40
bogie 190 40
caboosebody
}
}
namespace eval rr {
# Usage examples, and demo:
init .c
create F7A I50I
create boxcar 42135 ATSF brown
create boxcar 42199 C&NW salmon3
create gondola 745219 N.Y.C. salmon4
create caboose 18832 "U N I O N P A C I F I C" red
create flatcar 88402 "BOSTON & MAINE" black
train T1 {F7A:I50I boxcar:42135 gondola:745219 boxcar:42199 flatcar:88402 caboose:18832}
run T1
}
