Version 2 of Elevator simulation

Updated 2004-09-21 22:46:47

if 0 {Richard Suchenwirth 2004-09-21 - Tcl and Tk make programming almost everything very easy - so after less fascinating coding at work, I decided to do another fun project at home: an elevator model. This may also serve as educational toy for kids.

http://mini.net/files/elevator.gif

We have the elevator car and a counterweight, connected by a strong wire that runs over a wheel on top of the building. (The wheel is turned by a motor, which is not shown). If you click a "diamond" button on a floor, the elevator comes there. When doors are open, you can click which floor you want to go to. (All in all, this project came out more complex than I eventually expected - but still it was worth the while :). }

 proc main {} {
    pack [canvas .c -width 200 -height 460]
    set floors {4 3 2 1}
    elevator::create .c 100 450 150 $floors
    .c create line 0 50 200 50 -width 5 -fill gray50
    foreach y {150 250 350 450} floor $floors {
        .c create line 0 $y 200 $y -width 5 -fill gray50
        elevator::door   .c 100 $y $floor
        .c create text 90 [- $y 60] -text $floor 
    }
 }

#-- By popular demand of tclguy, here's a 5-floor variant:

 proc main5 {} {
    pack [canvas .c -width 200 -height 560]
    set floors {5 4 3 2 1}
    elevator::create .c 100 550 150 $floors
    .c create line 0 50 200 50 -width 5 -fill gray50
    foreach y {150 250 350 450 550} floor $floors {
        .c create line 0 $y 200 $y -width 5 -fill gray50
        elevator::door   .c 100 $y $floor
        .c create text 90 [- $y 60] -text $floor
    }
 }

if 0 {While coding, I noticed that the complexity grew, so I decided to place elevator-specific stuff in a namespace. This code is not exactly OO, but at least I tried to encapsulate some of the gorey details in that namespace.}

 namespace eval elevator {variable moving 0}

if 0 {The "constructor" creates the car, the counterweight, the wheel and the wires:}

 proc elevator::create {w x y topy floors} {
    variable car; variable weight
    variable leftwire; variable rightwire
    set item [$w create rect $x [+ $y 5] [+ $x 50] [- $y 70] -fill beige]
    set car t$item
    $w addtag $car withtag $item
    $w create line [+ $x 5] [- $y 70] [+ $x 25] [- $y 90] \
        [+ $x 45] [- $y 70] -tag $car -width 2
    set bx [+ $x 25]
    set by [- $y 58]
    foreach floor $floors {
        set f [$w create text $bx $by -text $floor -tag $car]
        $w addtag t$f withtag $f
        set bb [$w bbox $f]
        $w create rect $bb -fill yellow -outline {} -tag [list $car t$f]
        $w raise $f
        $w bind t$f <1> [list elevator::moveto $w $floor 1]
        incr by 13
    }
    $w create oval [+ $x 25] [- $topy 138] [+ $x 58] [- $topy 105] \
        -fill OliveDrab3
    set xm [+ $x 42]
    set ym [- $topy 121]
    $w create line [+ $x 25] $ym [+ $x 58] $ym -tag spoke
    $w create line $xm [- $topy 138] $xm [- $topy 105]  -tag spoke
    set leftwire [$w create line [+ $x 25] $ym \
        [+ $x 25] [- $y 90] -width 2]
    set rightwire [$w create line [+ $x 59] $ym \
        [+ $x 59] [- $topy 100] -width 2]
    $w create line [+ $x 25] [- $topy 100] $xm $ym \
        [+ $x 58] [- $topy 100] -fill OliveDrab4 -width 3 
    set weight [$w create rect [+ $x 55] $topy \
        [+ $x 61] [- $topy 100] -fill brown]
 }
 proc elevator::door {w x y floor} {
    variable doors
    set doors(y,$floor) $y
    $w create rect [+ $x 5] [- $y 2] [+ $x 45] [- $y 65] -fill {}
    arrowbuttons $w [- $x 15] $y $floor
    set xm [+ $x 25]
    set l [$w create rect [+ $x 5] [- $y 2] $xm [- $y 65] -fill white]
    set r [$w create rect $xm [- $y 2] [+ $x 45] [- $y 65] -fill white]
    set doors(ids,$floor) [list $l $r]
 }
 proc elevator::arrowbuttons {w x y floor} {
    $w create rect $x [- $y 32] [+ $x 10] [- $y 50] -fill white
    set id [$w create poly [+ $x 1] [- $y 41] [+ $x 5] [- $y 48] \
        [+ $x 9] [- $y 41] [+ $x 5] [- $y 34] \
        -fill gray -outline black]
    $w bind $id <1> [list elevator::moveto %W $floor 1]
 }
 proc elevator::moveto {w floor {push 0}} {
    variable car; variable doors; variable weight
    variable leftwire; variable rightwire
    variable button; variable current
    variable moving
    if {[info exists current] && $current eq $floor} return
    if $push {
        if $moving return
        set moving 1
        set button [$w find withtag current]
        if {[$w type $button] eq "polygon"} {
            $w itemconfig $button -fill yellow
        }
        closeDoors $w
    }
    set currentY [lindex [$w bbox $car] 3]
    set targetY  [+ $doors(y,$floor) 5]
    set dy [- $targetY $currentY]
    if {$dy} {
        set sdy [sgn $dy]
        $w move $car 0 $sdy
        $w move $weight 0 [- 0 $sdy]
        set coords [$w coords $leftwire]
        set topy [lindex $coords 3]
        $w coords $leftwire [lreplace $coords 3 3 [+ $topy $sdy]]
        set coords [$w coords $rightwire]
        set topy [lindex $coords 3]
        $w coords $rightwire [lreplace $coords 3 3 [- $topy $sdy]]
        rotate $w spoke [expr {$sdy*-0.05}]
        after 10 [list ::elevator::moveto $w $floor]
    } else {
        if {[$w type $button] eq "polygon"} {
            $w itemconfig $button -fill gray
        }
        openDoors $w $floor
        set current  $floor
        set moving 0
    }
 }
 proc elevator::openDoors {w floor} {
    variable doors
    foreach {left right} $doors(ids,$floor) break
    while 1 {
        set coords [$w coords $left]
        set x [lindex $coords 2]
        if {$x<[lindex $coords 0]+4} break
        $w coords $left [lreplace $coords 2 2 [- $x 1]]
        set coords [$w coords $right]
        set x [lindex $coords 0]
        $w coords $right [lreplace $coords 0 0 [+ $x 1]]
        after 5
        update idletasks
    }
    after 100
    set doors(open) $floor
 }
 proc elevator::closeDoors w {
    variable doors
    if ![info exists doors(open)] return
    foreach {left right} $doors(ids,$doors(open)) break
    while 1 {
        set lcoords [$w coords $left]
        set lx [lindex $lcoords 2]
        set rcoords [$w coords $right]
        set rx [lindex $rcoords 0]
        if {$lx-2>=$rx} break
        $w coords $left [lreplace $lcoords 2 2 [+ $lx 1]]
        $w coords $right [lreplace $rcoords 0 0 [- $rx 1]]
        after 5
        update idletasks
    }
    after 100
 }

#-- Arithmetic shortcuts

 proc + {a b} {expr {$a+$b}}
 proc - {a b} {expr {$a-$b}}
 proc sgn x   {expr {($x>0)-($x<0)}}

#-- Generally useful canvas routines

 proc center {w id} {
    set xsum 0.; set ysum 0; set n 0
    foreach {x y} [$w coords $id] {
        set xsum [+ $xsum $x]
        set ysum [+ $ysum $y]
        incr n
    }
    list [expr {$xsum/$n}] [expr {$ysum/$n}]
 }
 proc rotate {w tag angle} {
    foreach item [$w find withtag $tag] {
        set cs {}
        foreach {xm ym} [center $w $item] break
        foreach {x y} [$w coords $item] {
            set r [expr {hypot($ym-$y,$xm-$x)}]
            set a [expr {atan2($ym-$y,$xm-$x)+$angle}]
            lappend cs [expr {$xm+cos($a)*$r}] [expr {$ym+sin($a)*$r}]
        }
        $w coords $item $cs
    }
 }

#-- Let's go!

 main

#-- Dev helpers

 bind . <Escape> {exec wish $argv0 &; exit}
 bind . <F1> {console show}
 bind . <F2> {
    package require Img
    [image create photo -data .c] write elevator.gif
 }

if 0 {


Category Toys - Arts and crafts of Tcl-Tk programming }