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

package require Tk
proc main {{numFloors 4} {scale 100}} {
    set halfscale [expr {$scale / 2}]
    set width 200
    set height [expr {$numFloors * $scale + $halfscale + 10}]
    set w .c
    destroy $w
    pack [canvas $w -width $width -height $height] -fill both -expand 1
    set floors {}
    for {set i $numFloors} {$i > 0} {incr i -1} {
        lappend floors $i
    }
    elevator::create $w [expr {$width/2}] \
        [expr {$numFloors * $scale + $halfscale}] \
        [expr {$scale + $halfscale}] $floors
    $w create line 0 $halfscale $width $halfscale -width 5 -fill gray50
    foreach floor $floors {
        set y [expr {($numFloors - $floor + 1) * $scale + $halfscale}]
         $w create line 0 $y $width $y -width 5 -fill gray50
         elevator::door $w [expr {$width / 2}] $y $floor
         $w create text [expr {$width / 2 - 10}] \
             [expr {$y - $halfscale - 10}] -text $floor
    }
}

package require Tk

proc main {{numFloors 4} {scale 100}} {
    set halfscale [expr {$scale / 2}]
    set width 200
    set height [expr {$numFloors * $scale + $halfscale + 10}]
    set w .c
    destroy $w
    pack [canvas $w -width $width -height $height] -fill both -expand 1
    set floors {}
    for {set i $numFloors} {$i > 0} {incr i -1} {
        lappend floors $i
    }
    elevator::create $w [expr {$width/2}] \
        [expr {$numFloors * $scale + $halfscale}] \
        [expr {$scale + $halfscale}] $floors
    $w create line 0 $halfscale $width $halfscale -width 5 -fill gray50
    foreach floor $floors {
        set y [expr {($numFloors - $floor + 1) * $scale + $halfscale}]
         $w create line 0 $y $width $y -width 5 -fill gray50
         elevator::door $w [expr {$width / 2}] $y $floor
         $w create text [expr {$width / 2 - 10}] \
             [expr {$y - $halfscale - 10}] -text $floor
    }
}

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

namespace eval elevator {}

proc elevator::create {w x y topy floors} {
    variable state
    variable car; variable weight
    variable leftwire; variable rightwire
    variable busy {}
    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]
    if {[llength $floors]>5} {  ;# more than 5 buttons must be placed in 2 columns
      set bx [- $bx 6]
      set by [+ $by 7]
    }
    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::behave $w moveto $floor 1]
        incr by 13
        if {$by>$y} {        ;# 2nd button-column
          set bx [+ $bx 15]
          set by [- $y  51]  ;# 58-7
        }
    }
    $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::behave %W moveto $floor 1]
}

proc elevator::moveto {w floor {push 0}} {
    variable busy {}
    variable car; variable doors; variable weight
    variable leftwire; variable rightwire
    variable button; variable current
    if {[info exists current] && $current eq $floor} return
    if $push {
        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}]
        set busy [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
    }
}

proc elevator::openDoors {w floor} {
    variable busy {}
    variable doors
    foreach {left right} $doors(ids,$floor) break

    set coords [$w coords $left]
    set x [lindex $coords 2]

    if {$x<[lindex $coords 0]+4} {
        after 100
        set doors(open) $floor
        bell
    } else {
        $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]]
        set busy [after idle after 5 [list [namespace current]::openDoors $w $floor]]
    }
}

proc elevator::closeDoors w {
    variable busy {}
    variable doors
    if ![info exists doors(open)] return
    foreach {left right} $doors(ids,$doors(open)) break
    set lcoords [$w coords $left]
    set lx [lindex $lcoords 2]
    set rcoords [$w coords $right]
    set rx [lindex $rcoords 0]

    if {$lx-2>=$rx} {
        after 100
    } else {
        $w coords $left  [lreplace $lcoords 2 2 [+ $lx 1]]
        $w coords $right [lreplace $rcoords 0 0 [- $rx 1]]
        set busy [after 5 after idle [list [namespace current]::closeDoors $w]]
    }
}


proc elevator::behave {w behaviour args} {
    variable busy
    if {$busy ne {}} {
        return
    }
    set busy [after idle [list [namespace current]::$behaviour $w {*}$args]]
}

#-- 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! 
#main1   ;# old
main 6  ;# ok: upto 8 floors, default: 4

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