Model railroading with Tcl
Richard Suchenwirth - Another weekend fun project, this time it's sheer fun...
I had to "reinvent the wheel" to bring an animated steam loco on a canvas.
Every left mouse click makes it pick up speed, right mouse click stops it immediately.
As all the spokes of all wheels and all driving rods are redrawn on every update, this is quite a CPU hog.
The update interval of 140 ms was enough on my 200MHz box - reduce it if you have a faster CPU.
Notice how the steam is blown away if you ride faster. No warranty, but enjoy!
See also More model railroading - TclTrain
Note
Perhaps you were interested in Robert Heller's Model Railroad System at http://www.deepsoft.com/home/products/modelrailroadsystem
Program
proc wheel {c x y r args} {
global g
array set opt {-color red -spokes 24 -pivot 0 -tag {}}
array set opt $args
set y0 [expr $y-$r]
$c create oval [expr $x-$r] [expr $y0-$r] [expr $x+$r] [expr $y0+$r] \
-outline white
set r1 [expr $r-2]
set col $opt(-color)
set it [$c create oval [expr $x-$r1] [expr $y0-$r1] [expr $x+$r1] [expr $y0+$r1] \
-outline $col -width 2]
lappend g(wheels) $it
set g($it,spokes) $opt(-spokes)
set g($it,r) $r1
set g($it,x) $x
set g($it,y) $y0
set g(alpha) 0.
set g(-color) $opt(-color)
drawSpokes $c $it
if $opt(-pivot) {
set deg2arc [expr {atan(1.0)*8/360.}]
set rp [expr {$r1*$opt(-pivot)}]
set xp [expr {$x-$rp*cos($deg2arc*$::g(alpha))}]
set yp [expr {$y0-$rp*sin($deg2arc*$::g(alpha))}]
set pivot [$c create rect $xp $yp \
[expr {$xp+1}] [expr {$yp+1}] -fill $opt(-color) \
-tag [list $opt(-tag) pivot]]
set g($it,pivot) [list $pivot $opt(-pivot)]
$c create arc [expr {$x-$r1}] [expr {$y0-$r1}]\
[expr {$x+$r1}] [expr {$y0+$r1}] \
-style chord -fill $g(-color) -start 310\
-extent 80 -tag counterweight
}
set rh [expr $r/12.]
$c create oval [expr $x-$rh] [expr $y0-$rh] [expr $x+$rh] [expr $y0+$rh] \
-fill white -tag hub
}
proc turn {c deg} {
global g
set g(alpha) [expr {round($g(alpha)+360-$deg)%360}]
foreach i [$c find withtag counterweight] {
$c itemconfig $i -start [expr 310-$g(alpha)]
}
$c delete spoke
foreach i $g(wheels) {
drawSpokes $c $i
}
$c raise hub
set xp0 [expr {105+15*sin(($g(alpha)-90)*atan(1.0)*8/360)}]
$c delete piston
eval $c coords p0 $xp0 120 [expr {$xp0+2}] 122 ;#CW
$c create line 90 121 $xp0 121 -width 2 -fill white -tag piston ;#CW
drawRod $c p0 p1 p2 p3
$c raise p0
foreach i [$c find withtag smoke] {
if {[lindex [$c bbox $i] 3]<0} {
$c delete $i
} else {
$c move $i [expr {rand()*$::g(speed)/3.}] [expr {rand()*2-2}]
}
}
set t [eval $c create oval [$c bbox chimney] -fill white -outline white -tag smoke]
$c move $t 0 -10
$c lower smoke
}
proc drawSpokes {c item} {
global g
set nspokes $g($item,spokes)
set delta [expr 360./$nspokes]
set alpha $g(alpha)
set r $g($item,r)
set x $g($item,x)
set y $g($item,y)
set deg2arc [expr {atan(1.0)*8/360.}]
for {set i 0} {$i<$nspokes} {incr i} {
set x1 [expr {$x+cos($deg2arc*$alpha)*$r}]
set y1 [expr {$y+sin($deg2arc*$alpha)*$r}]
$c create line $x $y $x1 $y1 -fill $g(-color) -tag spoke
set alpha [expr {$alpha+$delta}]
}
if [info exists g($item,pivot)] {
foreach {item perc} $g($item,pivot) break
set rp [expr {$r*$perc}]
set xp [expr {$x-$rp*cos($deg2arc*$::g(alpha))}]
set yp [expr {$y-$rp*sin($deg2arc*$::g(alpha))}]
$c coords $item [expr {$xp}] [expr {$yp}] [expr {$xp+1}] [expr {$yp+1}]
}
}
proc drawRod {c p0 p1 p2 p3} {
$c delete rod
eval $c create rect [$c bbox $p1 $p3] -fill white -tag rod
eval $c create line [lrange [$c bbox $p0] 0 1] \
[lrange [$c bbox $p2] 0 1] -width 3 -fill white -tag rod
$c raise rod
$c raise pivot
}
set c [canvas .c -width 600 -height 160 -background lightblue]
pack $c
bind $c <1> {incr ::g(speed) 6; speed $c} ;# throttle
bind $c <3> {
foreach i [after info] {after cancel $i}
set g(speed) 0 ;# emergency brake
}
proc speed {c} {
turn $c $::g(speed)
foreach i [after info] {after cancel $i}
after 140 speed $c
}
$c delete all
catch {unset g}
$c create rect 32 115 360 125 -fill black ;# frame
$c create rect 22 118 32 122 -fill grey30 ;# buffer
$c create line 22 115 22 125
$c create poly 60 95 40 115 50 115 70 95 -fill black
$c create rect 60 45 310 95 -fill grey25 ;# boiler
$c create oval 55 50 65 90 -fill black ;# smokebox
$c create rect 70 32 85 50 -fill black -tag chimney
$c create rect 40 52 90 75 -fill black ;# wind diverter
$c create oval 130 36 150 52 -fill black ;# dome
$c create rect 195 35 215 50 -fill black ;# sandbox
$c create oval 260 36 280 52 -fill black ;# dome
$c create rect 65 100 90 135 -fill black ;# cylinder
$c create rect 90 120 92 122 -fill red -tag p0 ;# crossbar
$c create rect 72 87 82 100 -fill black ;# steam tube
$c create rect 310 40 370 115 -fill black ;# cab
$c create rect 310 32 390 42 -fill grey30 ;# cab roof
$c create text 338 82 -text "01 234" -fill gold -font {Times 7}
$c create rect 318 48 333 66 -fill white ;# cab window #1
$c create rect 338 48 355 66 -fill white ;# cab window #2
wheel $c 50 150 13 -spokes 12
wheel $c 105 150 13 -spokes 12
wheel $c 150 150 30 -pivot 0.5 -tag p1
wheel $c 215 150 30 -pivot 0.5 -tag p2
wheel $c 280 150 30 -pivot 0.5 -tag p3
drawRod $c p0 p1 p2 p3
wheel $c 340 150 16 -spokes 12
$c create rect 360 110 380 118 -fill black
$c create rect 380 65 560 125 -fill black -tag tender
$c create rect 560 118 570 122 -fill grey30 ;# buffer
$c create line 571 116 571 125
$c create rect 390 45 525 65 -fill black -tag tender
wheel $c 395 150 13 -spokes 12
wheel $c 440 150 13 -spokes 12
$c create rect 380 132 456 142 -fill red
wheel $c 495 150 13 -spokes 12
wheel $c 540 150 13 -spokes 12
$c create rect 480 132 556 142 -fill red -outline red
$c create rect 0 150 600 160 -fill brown ;# earth
$c create line 0 150 600 150 -fill grey -width 2 ;# rail
set ::g(speed) 4
speed $cDiscussion
2001-03-06: added fixes (#CW) proposed by Christoph Wegehaupt - thank you!
DKF enhanced the script with 3D boiler and random smoke when standing: see http://people.manchester.ac.uk/~zzcgudf/tcl/bitsandpieces/train.tcl
Transcript from the ongoing discussion in the Tcl chatroom:
Iain: Looks a bit European. A standard 4-6-2 Pacific would have a "cow catcher" in North America...
suchenwi: Right you are. We should make it configurable.
Iain: And, of course, you need a bell and a whistle...
suchenwi: For the next iteration, I'm thinking on making it a real train, with passenger cars.
suchenwi: Bells and whistles! Yeah!
Iain: And the engine numbering here is just one integer...:))
suchenwi: The train would of course have to move over the canvas.
Iain: I am running it in the plugin.
Iain: Did someone use snack to add sounds?
suchenwi: Pity that I'm at work here... I'll give it a go tonight.
From: Tadeusz Liszka <[email protected]> Newsgroups: comp.lang.tcl Subject: Re: Model railroading in Tcl Date: Fri, 09 Mar 2001 13:45:06 -0600 Organization: Altair Engineering, Inc. Lines: 38 Message-ID: <[email protected]> References: <[email protected]> I found the model really entertaining, but it had two drawbacks: 1. After the brake, the steam was frozen 2. The only way to break was to stop dead in tracks. Enclosed is the fix to both - middle button now applies brakes but takes some time to stop, and steam raises even after the emergency brake.
Program-Fixes
set g(braking) 0
set c [canvas .c -width 600 -height 160 -background lightblue]
pack $c
bind $c <1> {incr ::g(speed) 6; set ::g(braking) 0; speed $c} ;# throttle
bind $c <2> {
foreach i [after info] {after cancel $i}
set ::g(braking) 1 ;# slow brake to stop
after 10 speed $c
}
bind $c <3> {
foreach i [after info] {after cancel $i}
set ::g(speed) 0 ;# emergency brake to stop
set ::g(braking) 0
after 10 speed $c
}
proc speed {c} {
turn $c $::g(speed)
if { $::g(braking) > 0 } then { incr ::g(speed) -1 }
if { $::g(speed) <= 0 } then { set ::g(braking) 0; set ::g(speed) 0}
foreach i [after info] {after cancel $i}
#was after 140
after 10 speed $c
}and after catch {unset g},
set g(braking) 0 Tadeusz :: The public opinion should be alarmed by its own nonexistence :: (512)467-0618 ext. 526 :: Stanislaw J. Lec, trans. TJL