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 } } 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 . {exec wish $argv0 &; exit} bind . {console show} bind . { package require Img [image create photo -data .c] write elevator.gif } if 0 { ---- [Category Toy] - [Arts and crafts of Tcl-Tk programming] }