----
[Model-railroading_loco]

[Richard Suchenwirth] - Another weekend fun project, this time it's sheer fun... <<br>>
I had to "reinvent the wheel" to bring an animated steam loco on a canvas. <<br>>
Every left mouse click makes it pick up speed, right mouse click stops it immediately. <<br>>
As all the spokes of all wheels and all driving rods are redrawn on every update, this is quite a CPU hog. <<br>>
The update interval of 140 ms was enough on my 200MHz box - reduce it if you have a faster CPU. <<br>>
Notice how the steam is blown away if you ride faster. 
No warranty, but enjoy! 

See also [More model railroading] - [TclTrain] 
----
External link: "Model Railroad System" at http://www.deepsoft.com/cgi-bin/deepwoods.cgi/MRRSystem?Frame=Main

[HJG] 2014-01-01 The above link gives an error. <<br>>
Maybe it moved to http://www.deepsoft.com/home/products/modelrailroadsystem :
"Current Release (Nov 12, 2014): Version 2.1.34"

----
**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 $c
======

----
**Discussion**
2001-03-06: added fixes (#CW) proposed by Christoph Wegehaupt - thank you! <<br>>
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 <tad@comco.com>
 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: <3AA932C2.FB6620C7@comco.com>
 References: <3AA359EE.369F8BCC@kst.siemens.de>

 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
======


<<categories>> Tk examples | Animation | Toys | Arts and crafts of Tcl-Tk programming