Version 5 of TclTrain

Updated 2003-10-21 09:08:23

if 0 {Richard Suchenwirth 2003-10-18 - This weekend fun project is again about model railroading with Tcl, now from the engineer's perspective. The train runs over an endless straight line (curves seeming too difficult for the moment), and what interested me was animation (let objects move somehow life-like) by canvas scaling (remember the cars in trains3.tcl?) I find it most exciting to pass under a bridge, or by a house. Even though the graphics are crude, it is sort of fun to watch.

http://mini.net/files/tcltrain.jpg

The throttle is emulated by the cursor Up/Down keys, current speed is displayed at top left. (As objects are created by timer, you'll get more of them if you go slower - on my home computer, the following settings with speed 50 is barely manageable.) }

 package require Tk
 namespace eval tt {
    variable version 0.1
    variable deltaT  20
    variable speed
 }

if 0 {The UI is a boring landscape, with the ballast and the rails at constant positions:}

 proc tt::ui {w} {
    variable canvas $w speed
    $w create text -160 -50 -anchor nw -font {Helvetica 18} \
        -tag {rail speed}
    trace variable tt::speed w "$w itemconfig speed -text \$tt::speed ;#"
    set speed 50
    $w create rect -200 0 200 250 -fill green4 ;# landscape
    $w config -scrollregion {-200 -50 200 100}
    #-- ballast and rails:
    $w create poly -140 250 140 250 1 0 -1 0 -fill coral4 ;# ballast
    $w create poly -100 250 -90 250 0 0 -fill white -outline white -tag rail
    $w create poly 90 250 100 250 0 0 -fill white -outline white -tag rail
 }

if 0 {The illusion is that the train is moving through the landscape. In reality, the objects which make the landscape a bit interesting appear to move (especially the crossties which should be "seeded" at short intervals, but bring my 200MHz CPU at home down to its knees), by scaling them relative to the perspective point {0 0}. Objects are described by one or more canvas items:}

 proc tt::bridge {} {
    movable {
        {poly {-100 160  -80 120  -80 -30  80 -30 80 120  100 160 100 -60
        -100 -60} -fill gray40}
        {poly {-2000 0 -60 -100 60 -100 2000 0 100 160 100 -50
        -100 -50 -100 160} -fill gray60}
    }
 }
 proc tt::bush1 {} {movable {{oval 400 200 480 250 -fill darkgreen}}}
 proc tt::bush2 {} {movable {{oval -460 200 -490 300 -fill darkgreen}}}

 proc tt::crosstie {} {
    movable {{poly -105 200 -110 210 110 210 105 200 -fill burlywood4}}
 }
 proc tt::field {} {
    set color [lpick {yellow green3 brown bisque black}]
    movable "{poly 170 250 50 50 10000 50 10000 250 -fill $color}"
 }

 proc tt::milestone {} {
    movable {{rect 140 180 150 210 -fill white -outline {}}}
 }

 proc tt::pond {} {movable {{oval -2000 100 -200 300 -fill lightblue}}}

 proc tt::house {} {movable {
    {poly 200 200 200 -200 400 -400 600 -200 600 200 -fill white}
    {poly 200 200 120 100 120 -230 200 -200 -fill bisque}
    {poly 190 -200 100 -230 250 -350 400 -400 -fill brown}
    {rect 250 -160 350 -80 -fill lightblue -outline {}}
    {rect 450 -160 550 -80 -fill lightblue -outline {}}
    {rect 250 30 350 130 -fill lightblue -outline {}}
    {rect 450 30 550 130 -fill lightblue -outline {}}
 }}

 proc tt::road {} {
    movable {
        {rect -20000 45 20000 75 -fill gray -outline gray}
        {rect -20000 59 20000 61 -fill yellow -outline {}}
    }
 }
 proc tt::signal {} {
    movable {
        {rect 150 -50 160 200 -fill black}
        {rect 150 -50 200 -40 -fill red}
    }
 }

if 0 {This generic "constructor" draws an object on the canvas, "moves" it to a far distance, and then starts the animation that lets it come closer to the observer:}

 proc tt::movable items {
    variable speed
    if !$speed return
    variable canvas; set w $canvas
    set initialscale 0.02
    set id [eval $w create [lindex $items 0]]
    set tag t$id
    $w itemconfig $id -tag "$tag mv"
    foreach i [lrange $items 1 end] {eval $w create $i -tag "{$tag mv}"}
    $w scale $tag 0 0 $initialscale $initialscale
    $w lower $tag mv ;# behind previous objects
    $w raise rail ;# so they're not covered by the road
    animate $tag
 }

if 0 {The animation code first checks if the object has already passed the observer - then it is just deleted. Otherwise it is scaled depending on the current "speed", so that it appears to move closer and get bigger: }

 proc tt::animate tag {
    variable canvas; set w $canvas
    variable deltaT; variable speed
    foreach {x0 y0 x1 y1} [$w bbox $tag] break
    if {$y0 > 250 || $y1 > 500} {
        $w delete $tag
        return
    } elseif $speed {
        set scale [expr {1.0 + $speed/2000.}] ;# (1)
        $w scale $tag 0 0 $scale $scale
    }
    after $deltaT [list tt::animate $tag]
 }

#-- Some utilities of general use:

 proc every {ms body} {eval $body; after $ms [info level 0]}
 proc lpick list {lindex $list [expr int(rand()*[llength $list])]}

#-- and off we go:

 pack [canvas .c -bg lightblue]
 tt::ui .c
 every 100   tt::crosstie
 every 20000 tt::milestone
 every 5000 {eval [lpick {
    tt::signal tt::road tt::bush1 tt::bush2 tt::bridge tt::pond
    tt::house tt::field tt::field
 }]}

 bind . <Up>   {incr tt::speed  1}
 bind . <Down> {incr tt::speed -1}

 bind . <Escape> {exec wish $argv0 &; exit}

US Change the line

        set scale [expr {1.0 + $speed/2000.}] ;# (1)

in procedure tt::animate to

        set scale [expr {1.0 + $speed/2000. + $y1/3000.}] ;# (1)

Then it looks more realistic, doesn't it?