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 edit
Perhaps you were interested in Robert Heller's Model Railroad System at http://www.deepsoft.com/home/products/modelrailroadsystemProgram edit
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 $c
Discussion edit
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 edit
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