** Description **

''See [trains2.tcl] for the second version with a passenger and a freight train, or [trains3.tcl] for large scenery with some animations''
----
[WikiDbImage trains.jpg]
----
[Richard 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 **

[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 **

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

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