mingw/lib/tk8.5/demos/goldberg.tcl

   1 ##+#################################################################
   2 #
   3 # TkGoldberg.tcl
   4 # by Keith Vetter, March 13, 2003
   5 #
   6 # "Man will always find a difficult means to perform a simple task"
   7 # Rube Goldberg
   8 #
   9 # Reproduced here with permission.
  10 #
  11 ##+#################################################################
  12 #
  13 # Keith Vetter 2003-03-21: this started out as a simple little program
  14 # but was so much fun that it grew and grew. So I apologize about the
  15 # size but I just couldn't resist sharing it.
  16 #
  17 # This is a whizzlet that does a Rube Goldberg type animation, the
  18 # design of which comes from an New Years e-card from IncrediMail.
  19 # That version had nice sound effects which I eschewed. On the other
  20 # hand, that version was in black and white (actually dark blue and
  21 # light blue) and this one is fully colorized.
  22 #
  23 # One thing I learned from this project is that drawing filled complex
  24 # objects on a canvas is really hard. More often than not I had to
  25 # draw each item twice--once with the desired fill color but no
  26 # outline, and once with no fill but with the outline. Another trick
  27 # is erasing by drawing with the background color. Having a flood fill
  28 # command would have been extremely helpful.
  29 #
  30 # Two wiki pages were extremely helpful: Drawing rounded rectangles
  31 # which I generalized into Drawing rounded polygons, and regular
  32 # polygons which allowed me to convert ovals and arcs into polygons
  33 # which could then be rotated (see Canvas Rotation). I also wrote
  34 # Named Colors to aid in the color selection.
  35 #
  36 # I could comment on the code, but it's just 26 state machines with
  37 # lots of canvas create and move calls.
  38
  39 if {![info exists widgetDemo]} {
  40     error "This script should be run from the \"widget\" demo."
  41 }
  42
  43 package require Tk
  44
  45 set w .goldberg
  46 catch {destroy $w}
  47 toplevel $w
  48 wm title $w "Tk Goldberg (demonstration)"
  49 wm iconname $w "goldberg"
  50 wm resizable $w 0 0
  51 #positionWindow $w
  52
  53 label $w.msg -font {Arial 10} -wraplength 4i -justify left -text "This is a demonstration of just how complex you can make your animations become. Click the ball to start things moving!\n\n\"Man will always find a difficult means to perform a simple task\"\n - Rube Goldberg"
  54 pack $w.msg -side top
  55
  56 if 0 {
  57 ## See Code / Dismiss buttons
  58 set btns [addSeeDismiss $w.buttons $w]
  59 pack $btns -side bottom -fill x
  60 }
  61
  62
  63 # Ensure that this this is an array
  64 array set animationCallbacks {}
  65
  66 ###--- End of Boilerplate ---###
  67
  68 set S(title) "Tk Goldberg"
  69 set S(speed) 5
  70 set S(cnt) 0
  71 set S(message) "\\nWelcome\\nto\\nTcl/Tk"
  72 array set speed {1 10 2 20 3 50 4 80 5 100 6 150 7 200 8 300 9 400 10 500}
  73
  74 set MSTART 0; set MGO 1; set MPAUSE 2; set MSSTEP 3; set MBSTEP 4; set MDONE 5
  75 set S(mode) $::MSTART
  76
  77 # Colors for everything
  78 set C(fg) black
  79 set C(bg) gray75
  80 set C(bg) cornflowerblue
  81
  82 set C(0) white;         set C(1a) darkgreen;   set C(1b) yellow
  83 set C(2) red;           set C(3a) green;       set C(3b) darkblue
  84 set C(4) $C(fg);        set C(5a) brown;       set C(5b) white
  85 set C(6) magenta;       set C(7) green;        set C(8) $C(fg)
  86 set C(9) blue4;         set C(10a) white;      set C(10b) cyan
  87 set C(11a) yellow;      set C(11b) mediumblue; set C(12) tan2
  88 set C(13a) yellow;      set C(13b) red;        set C(14) white
  89 set C(15a) green;       set C(15b) yellow;     set C(16) gray65
  90 set C(17) \#A65353;     set C(18) $C(fg);      set C(19) gray50
  91 set C(20) cyan;         set C(21) gray65;      set C(22) $C(20)
  92 set C(23a) blue;        set C(23b) red;        set C(23c) yellow
  93 set C(24a) red;         set C(24b) white;
  94
  95 proc DoDisplay {} {
  96     global S C w
  97
  98     frame $w.ctrl -relief ridge -bd 2 -padx 5 -pady 5
  99     pack [frame $w.screen -bd 2 -relief raised] -side left -fill both -expand 1
 100
 101     canvas $w.c -width 860 -height 730 -bg $C(bg) -highlightthickness 0
 102     $w.c config -scrollregion {0 0 1000 1000}   ;# Kludge to move everything up
 103     $w.c yview moveto .05
 104     pack $w.c -in $w.screen -side top -fill both -expand 1
 105
 106     bind $w.c <3> [list $w.pause invoke]
 107     bind $w.c <Destroy> {
 108         after cancel $animationCallbacks(goldberg)
 109         unset animationCallbacks(goldberg)
 110     }
 111     DoCtrlFrame
 112     DoDetailFrame
 113     button $w.show -text ">>" -command ShowCtrl -bg $C(bg) -activebackground $C(bg)
 114     place $w.show -in $w.c -relx 1 -rely 0 -anchor ne
 115     update
 116 }
 117 proc DoCtrlFrame {} {
 118     global w
 119     button $w.start -text "Start" -bd 6 -command {DoButton 0}
 120     $w.start configure -font "[font actual [$w.start cget -font]] -weight bold"
 121     set font [$w.start cget -font]
 122     checkbutton $w.pause -text "Pause" -font $font \
 123             -command {DoButton 1} -variable S(pause) -relief raised
 124     button $w.step -text "Single Step"   -font $font -command {DoButton 2}
 125     button $w.bstep -text "Big Step"  -font $font -command {DoButton 4}
 126     button $w.reset -text "Reset" -font $font -command {DoButton 3}
 127     frame $w.details -bd 2 -relief ridge
 128     checkbutton $w.detail -text "Details" -font $font -variable S(details)
 129
 130     entry $w.message -textvariable S(message) -justify center
 131     scale $w.speed -orient h -from 1 -to 10 -font $font \
 132             -variable S(speed) -bd 2 -relief ridge -showvalue 0
 133     button $w.about -text About -command About -font $font
 134
 135     grid $w.start -in $w.ctrl -row 0 -sticky ew
 136     grid rowconfigure $w.ctrl 1 -minsize 10
 137     grid $w.pause -in $w.ctrl -row 2 -sticky ew
 138     grid $w.step  -in $w.ctrl -sticky ew
 139     grid $w.bstep  -in $w.ctrl -sticky ew
 140     grid $w.reset -in $w.ctrl -sticky ew
 141     grid rowconfigure $w.ctrl 10 -minsize 20
 142     grid $w.details -in $w.ctrl -row 11 -sticky ew
 143     grid $w.detail -in $w.details -row 0 -sticky ew
 144     grid rowconfigure $w.ctrl 50 -weight 1
 145     trace variable ::S(mode) w ActiveGUI
 146     trace variable ::S(details) w ActiveGUI
 147     trace variable ::S(speed) w ActiveGUI
 148
 149     grid $w.message -in $w.ctrl -row 98 -sticky ew -pady 5
 150     grid $w.speed -in $w.ctrl -row 99 -sticky ew
 151     grid $w.about -in $w.ctrl -row 100 -sticky ew
 152     bind $w.reset <3> {set S(mode) -1}            ;# Debugging
 153 }
 154 proc DoDetailFrame {} {
 155     global w
 156     set w2 $w.details.f
 157     frame $w2
 158
 159     set bd 2
 160     set rel solid
 161     label $w2.l -textvariable S(cnt) -bd 1 -relief $rel -bg white
 162     grid $w2.l - - - -sticky ew -row 0
 163     for {set i 1} {1} {incr i} {
 164         if {[info procs "Move$i"] == {}} break
 165         label $w2.l$i -text $i -anchor e -width 2 -bd 1 -relief $rel -bg white
 166         label $w2.ll$i -textvariable STEP($i) -width 5 -bd 1 -relief $rel -bg white
 167         set row [expr {($i + 1) / 2}]
 168         set col [expr {(($i + 1) & 1) * 2}]
 169         grid $w2.l$i -sticky ew -row $row -column $col
 170         grid $w2.ll$i -sticky ew -row $row -column [incr col]
 171     }
 172     grid columnconfigure $w2 1 -weight 1
 173 }
 174 # Map or unmap the ctrl window
 175 proc ShowCtrl {} {
 176     global w
 177     if {[winfo ismapped $w.ctrl]} {
 178         pack forget $w.ctrl
 179         $w.show config -text ">>"
 180     } else {
 181         pack $w.ctrl -side right -fill both -ipady 5
 182         $w.show config -text "<<"
 183     }
 184 }
 185 proc DrawAll {} {
 186     global w
 187     ResetStep
 188     $w.c delete all
 189     for {set i 0} {1} {incr i} {
 190         set p "Draw$i"
 191         if {[info procs $p] == {}} break
 192         $p
 193     }
 194 }
 195 proc ActiveGUI {var1 var2 op} {
 196     global S w
 197     array set z {0 disabled 1 normal}
 198
 199     set m $S(mode)
 200     set S(pause) [expr {$m == 2}]
 201     $w.start  config -state $z([expr {$m != $::MGO}])
 202     $w.pause  config -state $z([expr {$m != $::MSTART && $m != $::MDONE}])
 203     $w.step   config -state $z([expr {$m != $::MGO && $m != $::MDONE}])
 204     $w.bstep  config -state $z([expr {$m != $::MGO && $m != $::MDONE}])
 205     $w.reset  config -state $z([expr {$m != $::MSTART}])
 206
 207     if {$S(details)} {
 208         grid $w.details.f -in $w.details -row 2 -sticky ew
 209     } else {
 210         grid forget $w.details.f
 211     }
 212     $w.speed config -label "Speed: $S(speed)"
 213 }
 214 proc Start {} {
 215     global S
 216     set S(mode) $::MGO
 217 }
 218 proc DoButton {what} {
 219     global S
 220
 221     if {$what == 0} {                           ;# Start
 222         if {$S(mode) == $::MDONE} Reset
 223         set S(mode) $::MGO
 224     } elseif {$what == 1} {                     ;# Pause
 225         set S(mode) [expr {$S(pause) ? $::MPAUSE : $::MGO}]
 226     } elseif {$what == 2} {                     ;# Step
 227         set S(mode) $::MSSTEP
 228     } elseif {$what == 3} {                     ;# Reset
 229         Reset
 230     } elseif {$what == 4} {                     ;# Big step
 231         set S(mode) $::MBSTEP
 232     }
 233 }
 234 proc Go {{who {}}} {
 235     global S speed animationCallbacks
 236
 237     set now [clock clicks -milliseconds]
 238     catch {after cancel $animationCallbacks(goldberg)}
 239     if {$who != {}} {                           ;# Start here for debugging
 240         set S(active) $who;
 241         set S(mode) $::MGO
 242     }
 243     if {$S(mode) == -1} return                  ;# Debugging
 244     set n 0
 245     if {$S(mode) != $::MPAUSE} {                ;# Not paused
 246         set n [NextStep]                        ;# Do the next move
 247     }
 248     if {$S(mode) == $::MSSTEP} {set S(mode) $::MPAUSE} ;# Single step
 249     if {$S(mode) == $::MBSTEP && $n} {set S(mode) $::MSSTEP} ;# Big step
 250
 251     set elapsed [expr {[clock click -milliseconds] - $now}]
 252     set delay [expr {$speed($S(speed)) - $elapsed}]
 253     if {$delay <= 0} { set delay 1}
 254     set animationCallbacks(goldberg) [after $delay Go]
 255 }
 256 # NextStep: drives the next step of the animation
 257 proc NextStep {} {
 258     global S
 259     set rval 0                                  ;# Return value
 260
 261     if {$S(mode) != $::MSTART && $S(mode) != $::MDONE} { incr S(cnt) }
 262     set alive {}
 263     foreach {who} $S(active) {
 264         set n ["Move$who"]
 265         if {$n & 1} {                           ;# This guy still alive
 266             lappend alive $who
 267         }
 268         if {$n & 2} {                           ;# Next guy is active
 269             lappend alive [expr {$who + 1}]
 270             set rval 1
 271         }
 272         if {$n & 4} {                           ;# End of puzzle flag
 273             set S(mode) $::MDONE                ;# Done mode
 274             set S(active) {}                    ;# No more animation
 275             return 1
 276         }
 277     }
 278     set S(active) $alive
 279     return $rval
 280 }
 281 proc About {} {
 282     set msg "$::S(title)\nby Keith Vetter, March 2003\n(Reproduced by kind permission of the author)\n\n"
 283     append msg "Man will always find a difficult means to perform a simple task"
 284     append msg "\nRube Goldberg"
 285     tk_messageBox -message $msg -title About
 286 }
 287 ################################################################
 288 #
 289 # All the drawing and moving routines
 290 #
 291
 292 # START HERE! banner
 293 proc Draw0 {} {
 294     global w
 295     set color $::C(0)
 296     set xy {579 119}
 297     $w.c create text $xy -text "START HERE!" -fill $color -anchor w \
 298             -tag I0 -font {{Times Roman} 12 italic bold}
 299     set xy {719 119 763 119}
 300     $w.c create line $xy -tag I0 -fill $color -width 5 -arrow last \
 301             -arrowshape {18 18 5}
 302     $w.c bind I0 <1> Start
 303 }
 304 proc Move0 {{step {}}} {
 305     set step [GetStep 0 $step]
 306
 307     if {$::S(mode) > $::MSTART} {               ;# Start the ball rolling
 308         MoveAbs I0 {-100 -100}                  ;# Hide the banner
 309         return 2
 310     }
 311
 312     set pos {
 313         {673 119} {678 119} {683 119} {688 119}
 314         {693 119} {688 119} {683 119} {678 119}
 315     }
 316     set step [expr {$step % [llength $pos]}]
 317     MoveAbs I0 [lindex $pos $step]
 318     return 1
 319 }
 320 # Dropping ball
 321 proc Draw1 {} {
 322     global w
 323     set color $::C(1a)
 324     set color2 $::C(1b)
 325     set xy {844 133 800 133 800 346 820 346 820 168 844 168 844 133}
 326     $w.c create poly $xy -width 3 -fill $color -outline {}
 327     set xy {771 133 685 133 685 168 751 168 751 346 771 346 771 133}
 328     $w.c create poly $xy -width 3 -fill $color -outline {}
 329
 330     set xy [box 812 122 9]
 331     $w.c create oval $xy -tag I1 -fill $color2 -outline {}
 332     $w.c bind I1 <1> Start
 333 }
 334 proc Move1 {{step {}}} {
 335     set step [GetStep 1 $step]
 336     set pos {
 337         {807 122} {802 122} {797 123} {793 124} {789 129} {785 153}
 338         {785 203} {785 278 x} {785 367} {810 392} {816 438} {821 503}
 339         {824 585 y} {838 587} {848 593} {857 601} {-100 -100}
 340     }
 341     if {$step >= [llength $pos]} {
 342         return 0
 343     }
 344     set where [lindex $pos $step]
 345     MoveAbs I1 $where
 346
 347     if {[lindex $where 2] == "y"} {
 348         Move15a
 349     }
 350     if {[lindex $where 2] == "x"} {
 351         return 3
 352     }
 353     return 1
 354 }
 355 # Lighting the match
 356 proc Draw2 {} {
 357     global w
 358     set color red
 359     set color $::C(2)
 360     set xy  {750 369 740 392 760 392}           ;# Fulcrum
 361     $w.c create poly $xy -fill $::C(fg) -outline $::C(fg)
 362     set xy {628 335 660 383}                    ;# Strike box
 363     $w.c create rect $xy -fill {} -outline $::C(fg)
 364     for {set y 0} {$y < 3} {incr y} {
 365         set yy [expr {335+$y*16}]
 366         $w.c create bitmap 628 $yy -bitmap gray25 -anchor nw -foreground $::C(fg)
 367         $w.c create bitmap 644 $yy -bitmap gray25 -anchor nw -foreground $::C(fg)
 368     }
 369
 370     set xy {702 366 798 366}                    ;# Lever
 371     $w.c create line $xy -fill $::C(fg) -width 6 -tag I2_0
 372     set xy {712 363 712 355}                    ;# R strap
 373     $w.c create line $xy -fill $::C(fg) -width 3 -tag I2_1
 374     set xy {705 363 705 355}                    ;# L strap
 375     $w.c create line $xy -fill $::C(fg) -width 3 -tag I2_2
 376     set xy {679 356 679 360 717 360 717 356 679 356} ;# Match stick
 377     $w.c create line $xy -fill $::C(fg) -tag I2_3
 378
 379     #set xy {662 352 680 365}                   ;# Match head
 380     set xy {
 381         671 352 677.4 353.9 680 358.5 677.4 363.1 671 365 664.6 363.1
 382         662 358.5 664.6 353.9
 383     }
 384     $w.c create poly $xy -fill $color -outline $color -tag I2_4
 385 }
 386 proc Move2 {{step {}}} {
 387     global w
 388     set step [GetStep 2 $step]
 389
 390     set stages {0 0 1 2 0 2 1 0 1 2 0 2 1}
 391     set xy(0) {
 392         686 333 692 323 682 316 674 309 671 295 668 307 662 318 662 328
 393         671 336
 394     }
 395     set xy(1) {687 331 698 322 703 295 680 320 668 297 663 311 661 327 671 335}
 396     set xy(2) {
 397         686 331 704 322 688 300 678 283 678 283 674 298 666 309 660 324
 398         672 336
 399     }
 400
 401     if {$step >= [llength $stages]} {
 402         $w.c delete I2
 403         return 0
 404     }
 405
 406     if {$step == 0} {                           ;# Rotate the match
 407         set beta 20
 408         foreach {Ox Oy} [Anchor I2_0 s] break   ;# Where to pivot
 409         for {set i 0} {[$w.c find withtag I2_$i] != {}} {incr i} {
 410             RotateItem I2_$i $Ox $Oy $beta
 411         }
 412         $w.c create poly -tag I2 -smooth 1 -fill $::C(2) ;# For the flame
 413         return 1
 414     }
 415     $w.c coords I2 $xy([lindex $stages $step])
 416     return [expr {$step == 7 ? 3 : 1}]
 417 }
 418 # Weight and pulleys
 419 proc Draw3 {} {
 420     global w
 421     set color $::C(3a)
 422     set color2 $::C(3b)
 423
 424     set xy {602 296 577 174 518 174}
 425     foreach {x y} $xy {                         ;# 3 Pulleys
 426         $w.c create oval [box $x $y 13] -fill $color -outline $::C(fg) -width 3
 427         $w.c create oval [box $x $y 2] -fill $::C(fg) -outline $::C(fg)
 428     }
 429
 430     set xy {750 309 670 309}                    ;# Wall to flame
 431     $w.c create line $xy -tag I3_s -width 3 -fill $::C(fg) -smooth 1
 432     set xy {670 309 650 309}                    ;# Flame to pulley 1
 433     $w.c create line $xy -tag I3_0 -width 3 -fill $::C(fg)
 434     set xy {650 309 600 309}                    ;# Flame to pulley 1
 435     $w.c create line $xy -tag I3_1 -width 3 -fill $::C(fg)
 436     set xy {589 296 589 235}                    ;# Pulley 1 half way to 2
 437     $w.c create line $xy -tag I3_2 -width 3 -fill $::C(fg)
 438     set xy {589 235 589 174}                    ;# Pulley 1 other half to 2
 439     $w.c create line $xy -width 3 -fill $::C(fg)
 440     set xy {577 161 518 161}                    ;# Across the top
 441     $w.c create line $xy -width 3 -fill $::C(fg)
 442     set xy {505 174 505 205}                    ;# Down to weight
 443     $w.c create line $xy -tag I3_w -width 3 -fill $::C(fg)
 444
 445     # Draw the weight as 2 circles, two rectangles and 1 rounded rectangle
 446     set xy {515 207 495 207}
 447     foreach {x1 y1 x2 y2} $xy {
 448         $w.c create oval [box $x1 $y1 6] -tag I3_ -fill $color2 -outline $color2
 449         $w.c create oval [box $x2 $y2 6] -tag I3_ -fill $color2 -outline $color2
 450         incr y1 -6; incr y2 6
 451         $w.c create rect $x1 $y1 $x2 $y2 -tag I3_ -fill $color2 -outline $color2
 452     }
 453     set xy {492 220 518 263}
 454     set xy [RoundRect $xy 15]
 455     $w.c create poly $xy -smooth 1 -tag I3_ -fill $color2 -outline $color2
 456     set xy {500 217 511 217}
 457     $w.c create line $xy -tag I3_ -fill $color2 -width 10
 458
 459     set xy {502 393 522 393 522 465}            ;# Bottom weight target
 460     $w.c create line $xy -tag I3__ -fill $::C(fg) -join miter -width 10
 461 }
 462 proc Move3 {{step {}}} {
 463     global w
 464     set step [GetStep 3 $step]
 465
 466     set pos {{505 247} {505 297} {505 386.5} {505 386.5}}
 467     set rope(0) {750 309 729 301 711 324 690 300}
 468     set rope(1) {750 309 737 292 736 335 717 315 712 320}
 469     set rope(2) {750 309 737 309 740 343 736 351 725 340}
 470     set rope(3) {750 309 738 321 746 345 742 356}
 471
 472     if {$step >= [llength $pos]} {return 0}
 473
 474     $w.c delete "I3_$step"                        ;# Delete part of the rope
 475     MoveAbs I3_ [lindex $pos $step]             ;# Move weight down
 476     $w.c coords I3_s $rope($step)                 ;# Flapping rope end
 477     $w.c coords I3_w [concat 505 174 [lindex $pos $step]]
 478     if {$step == 2} {
 479         $w.c move I3__ 0 30
 480         return 2
 481     }
 482     return 1
 483 }
 484 # Cage and door
 485 proc Draw4 {} {
 486     global w
 487     set color $::C(4)
 488     set xy {527 356 611 464}
 489     foreach {x0 y0 x1 y1} $xy break
 490
 491     for {set y $y0} {$y <= $y1} {incr y 12} {   ;# Horizontal bars
 492         $w.c create line $x0 $y $x1 $y -fill $color -width 1
 493     }
 494     for {set x $x0} {$x <= $x1} {incr x 12} {   ;# Vertical bars
 495         $w.c create line $x $y0 $x $y1 -fill $color -width 1
 496     }
 497
 498     set xy {518 464 518 428}                    ;# Swing gate
 499     $w.c create line $xy -tag I4 -fill $color -width 3
 500 }
 501 proc Move4 {{step {}}} {
 502     global w
 503     set step [GetStep 4 $step]
 504
 505     set angles {-10 -20 -30 -30}
 506     if {$step >= [llength $angles]} {return 0}
 507     RotateItem I4 518 464 [lindex $angles $step]
 508     $w.c raise I4
 509     return [expr {$step == 3 ? 3 : 1}]
 510 }
 511 # Mouse
 512 proc Draw5 {} {
 513     global w
 514     set color $::C(5a)
 515     set color2 $::C(5b)
 516     set xy {377 248 410 248 410 465 518 465}    ;# Mouse course
 517     lappend xy 518 428 451 428 451 212 377 212
 518     $w.c create poly $xy -fill $color2 -outline $::C(fg) -width 3
 519
 520     set xy {
 521         534.5 445.5 541 440 552 436 560 436 569 440 574 446 575 452 574 454
 522         566 456 554 456 545 456 537 454 530 452
 523     }
 524     $w.c create poly $xy -tag {I5 I5_0} -fill $color
 525     set xy {573 452 592 458 601 460 613 456}    ;# Tail
 526     $w.c create line $xy -tag {I5 I5_1} -fill $color -smooth 1 -width 3
 527     set xy [box 540 446 2]                      ;# Eye
 528     set xy {540 444 541 445 541 447 540 448 538 447 538 445}
 529     #.c create oval $xy -tag {I5 I5_2} -fill $::C(bg) -outline {}
 530     $w.c create poly $xy -tag {I5 I5_2} -fill $::C(bg) -outline {} -smooth 1
 531     set xy {538 454 535 461}                    ;# Front leg
 532     $w.c create line $xy -tag {I5 I5_3} -fill $color -width 2
 533     set xy {566 455 569 462}                    ;# Back leg
 534     $w.c create line $xy -tag {I5 I5_4} -fill $color -width 2
 535     set xy {544 455 545 460}                    ;# 2nd front leg
 536     $w.c create line $xy -tag {I5 I5_5} -fill $color -width 2
 537     set xy {560 455 558 460}                    ;# 2nd back leg
 538     $w.c create line $xy -tag {I5 I5_6}  -fill $color -width 2
 539 }
 540 proc Move5 {{step {}}} {
 541     set step [GetStep 5 $step]
 542
 543     set pos {
 544         {553 452} {533 452} {513 452} {493 452} {473 452}
 545         {463 442 30} {445.5 441.5 30} {425.5 434.5 30} {422 414} {422 394}
 546         {422 374} {422 354} {422 334} {422 314} {422 294}
 547         {422 274 -30} {422 260.5 -30 x} {422.5 248.5 -28} {425 237}
 548     }
 549     if {$step >= [llength $pos]} {
 550         return 0
 551     }
 552
 553     foreach {x y beta next} [lindex $pos $step] break
 554     MoveAbs I5 [list $x $y]
 555     if {$beta != {}} {
 556         foreach {Ox Oy} [Centroid I5_0] break
 557         foreach id {0 1 2 3 4 5 6} {
 558             RotateItem I5_$id $Ox $Oy $beta
 559         }
 560     }
 561     if {$next == "x"} {return 3}
 562     return 1
 563 }
 564 # Dropping gumballs
 565 array set XY6 {
 566     -1 {366 207} -2 {349 204} -3 {359 193} -4 {375 192} -5 {340 190}
 567     -6 {349 177} -7 {366 177} -8 {380 176} -9 {332 172} -10 {342 161}
 568     -11 {357 164} -12 {372 163} -13 {381 149} -14 {364 151} -15 {349 146}
 569     -16 {333 148} 0 {357 219}
 570     1 {359 261} 2 {359 291} 3 {359 318}  4 {361 324}  5 {365 329}  6 {367 334}
 571     7 {367 340} 8 {366 346} 9 {364 350} 10 {361 355} 11 {359 370} 12 {359 391}
 572     13,0 {360 456}  13,1 {376 456}  13,2 {346 456}  13,3 {330 456}
 573     13,4 {353 444}  13,5 {368 443}  13,6 {339 442}  13,7 {359 431}
 574     13,8 {380 437}  13,9 {345 428}  13,10 {328 434} 13,11 {373 424}
 575     13,12 {331 420} 13,13 {360 417} 13,14 {345 412} 13,15 {376 410}
 576     13,16 {360 403}
 577 }
 578
 579 proc Draw6 {} {
 580     global w
 581     set color $::C(6)
 582     set xy {324 130 391 204}                    ;# Ball holder
 583     set xy [RoundRect $xy 10]
 584     $w.c create poly $xy -smooth 1 -outline $::C(fg) -width 3 -fill $color
 585     set xy {339 204 376 253}                    ;# Below the ball holder
 586     $w.c create rect $xy -fill {} -outline $::C(fg) -width 3 -fill $color -tag I6c
 587     set xy [box 346 339 28]
 588     $w.c create oval $xy -fill $color -outline {} ;# Rotor
 589     $w.c create arc $xy -outline $::C(fg) -width 2 -style arc \
 590             -start 80 -extent 205
 591     $w.c create arc $xy -outline $::C(fg) -width 2 -style arc \
 592             -start -41 -extent 85
 593
 594     set xy [box 346 339 15]                     ;# Center of rotor
 595     $w.c create oval $xy -outline $::C(fg) -fill $::C(fg) -tag I6m
 596     set xy {352 312 352 254 368 254 368 322}    ;# Top drop to rotor
 597     $w.c create poly $xy -fill $color -outline {}
 598     $w.c create line $xy -fill $::C(fg) -width 2
 599
 600     set xy {353 240 367 300}                    ;# Poke bottom hole
 601     $w.c create rect $xy -fill $color -outline {}
 602     set xy {341 190 375 210}                    ;# Poke another hole
 603     $w.c create rect $xy -fill $color -outline {}
 604
 605     set xy {368 356 368 403 389 403 389 464 320 464 320 403 352 403 352 366}
 606     $w.c create poly $xy -fill $color -outline {} -width 2 ;# Below rotor
 607     $w.c create line $xy -fill $::C(fg) -width 2
 608     set xy [box 275 342 7]                      ;# On/off rotor
 609     $w.c create oval $xy -outline $::C(fg) -fill $::C(fg)
 610     set xy {276 334 342 325}                    ;# Fan belt top
 611     $w.c create line $xy -fill $::C(fg) -width 3
 612     set xy {276 349 342 353}                    ;# Fan belt bottom
 613     $w.c create line $xy -fill $::C(fg) -width 3
 614
 615     set xy {337 212 337 247}                    ;# What the mouse pushes
 616     $w.c create line $xy -fill $::C(fg) -width 3 -tag I6_
 617     set xy {392 212 392 247}
 618     $w.c create line $xy -fill $::C(fg) -width 3 -tag I6_
 619     set xy {337 230 392 230}
 620     $w.c create line $xy -fill $::C(fg) -width 7 -tag I6_
 621
 622     set who -1                                  ;# All the balls
 623     set colors {red cyan orange green blue darkblue}
 624     eval lappend colors $colors $colors
 625
 626     for {set i 0} {$i < 17} {incr i} {
 627         set loc [expr {-1 * $i}]
 628         set color [lindex $colors $i]
 629         $w.c create oval [eval box $::XY6($loc) 5] -fill $color \
 630                 -outline $color -tag I6_b$i
 631     }
 632     Draw6a 12                                   ;# The wheel
 633 }
 634 proc Draw6a {beta} {
 635     global w
 636     $w.c delete I6_0
 637     foreach {Ox Oy} {346 339} break
 638     for {set i 0} {$i < 4} {incr i} {
 639         set b [expr {$beta + $i * 45}]
 640         foreach {x y} [RotateC 28 0 0 0 $b] break
 641         set xy [list [expr {$Ox+$x}] [expr {$Oy+$y}] \
 642                 [expr {$Ox-$x}] [expr {$Oy-$y}]]
 643         $w.c create line $xy -tag I6_0 -fill $::C(fg) -width 2
 644     }
 645 }
 646 proc Move6 {{step {}}} {
 647     global w
 648     set step [GetStep 6 $step]
 649     if {$step > 62} {return 0}
 650
 651     if {$step < 2} {                            ;# Open gate for balls to drop
 652         $w.c move I6_ -7 0
 653         if {$step == 1} {                       ;# Poke a hole
 654             set xy {348 226 365 240}
 655             $w.c create rect $xy -fill [$w.c itemcget I6c -fill] -outline {}
 656         }
 657         return 1
 658     }
 659
 660     set s [expr {$step - 1}]                    ;# Do the gumball drop dance
 661     for {set i 0} {$i <= int(($s-1) / 3)} {incr i} {
 662         set tag "I6_b$i"
 663         if {[$w.c find withtag $tag] == {}} break
 664         set loc [expr {$s - 3 * $i}]
 665
 666         if {[info exists ::XY6($loc,$i)]} {
 667             MoveAbs $tag $::XY6($loc,$i)
 668         } elseif {[info exists ::XY6($loc)]} {
 669             MoveAbs $tag $::XY6($loc)
 670         }
 671     }
 672     if {($s % 3) == 1} {
 673         set first [expr {($s + 2) / 3}]
 674         for {set i $first} {1} {incr i} {
 675             set tag "I6_b$i"
 676             if {[$w.c find withtag $tag] == {}} break
 677             set loc [expr {$first - $i}]
 678             MoveAbs $tag $::XY6($loc)
 679         }
 680     }
 681     if {$s >= 3} {                              ;# Rotate the motor
 682         set idx [expr {$s % 3}]
 683         #Draw6a [lindex {12 35 64} $idx]
 684         Draw6a [expr {12 + $s * 15}]
 685     }
 686     return [expr {$s == 3 ? 3 : 1}]
 687 }
 688 # On/off switch
 689 proc Draw7 {} {
 690     global w
 691     set color $::C(7)
 692     set xy {198 306 277 374}                    ;# Box
 693     $w.c create rect $xy -outline $::C(fg) -width 2 -fill $color -tag I7z
 694     $w.c lower I7z
 695     set xy {275 343 230 349}
 696     $w.c create line $xy -tag I7 -fill $::C(fg) -arrow last \
 697             -arrowshape {23 23 8} -width 6
 698     set xy {225 324}                            ;# On button
 699     $w.c create oval [eval box $xy 3] -fill $::C(fg) -outline $::C(fg)
 700     set xy {218 323}                            ;# On text
 701     set font {{Times Roman} 8}
 702     $w.c create text $xy -text "on" -anchor e -fill $::C(fg) -font $font
 703     set xy {225 350}                            ;# Off button
 704     $w.c create oval [eval box $xy 3] -fill $::C(fg) -outline $::C(fg)
 705     set xy {218 349}                            ;# Off button
 706     $w.c create text $xy -text "off" -anchor e -fill $::C(fg) -font $font
 707 }
 708 proc Move7 {{step {}}} {
 709     set step [GetStep 7 $step]
 710     set numsteps 30
 711     if {$step > $numsteps} {return 0}
 712     set beta [expr {30.0 / $numsteps}]
 713     RotateItem I7 275 343 $beta
 714
 715     return [expr {$step == $numsteps ? 3 : 1}]
 716 }
 717 # Electricity to the fan
 718 proc Draw8 {} {
 719     Sine 271 248 271 306 5 8 -tag I8_s -fill $::C(8) -width 3
 720 }
 721 proc Move8 {{step {}}} {
 722     global w
 723     set step [GetStep 8 $step]
 724
 725     if {$step > 3} {return 0}
 726     if {$step == 0} {
 727         Sparkle [Anchor I8_s s] I8
 728         return 1
 729
 730     } elseif {$step == 1} {
 731         MoveAbs I8 [Anchor I8_s c]
 732     } elseif {$step == 2} {
 733         MoveAbs I8 [Anchor I8_s n]
 734     } else {
 735         $w.c delete I8
 736     }
 737     return [expr {$step == 2 ? 3 : 1}]
 738 }
 739 # Fan
 740 proc Draw9 {} {
 741     global w
 742     set color $::C(9)
 743     set xy {266 194 310 220}
 744     $w.c create oval $xy -outline $color -fill $color
 745     set xy {280 209 296 248}
 746     $w.c create oval $xy -outline $color -fill $color
 747     set xy {288 249 252 249 260 240 280 234 296 234 316 240 324 249 288 249}
 748     $w.c create poly $xy -fill $color -smooth 1
 749
 750     set xy {248 205 265 214 264 205 265 196}    ;# Spinner
 751     $w.c create poly $xy -fill $color
 752
 753     set xy {255 206 265 234}                    ;# Fan blades
 754     $w.c create oval $xy -fill {} -outline $::C(fg) -width 3 -tag I9_0
 755     set xy {255 176 265 204}
 756     $w.c create oval $xy -fill {} -outline $::C(fg) -width 3 -tag I9_0
 757     set xy {255 206 265 220}
 758     $w.c create oval $xy -fill {} -outline $::C(fg) -width 1 -tag I9_1
 759     set xy {255 190 265 204}
 760     $w.c create oval $xy -fill {} -outline $::C(fg) -width 1 -tag I9_1
 761 }
 762 proc Move9 {{step {}}} {
 763     global w
 764     set step [GetStep 9 $step]
 765
 766     if {$step & 1} {
 767         $w.c itemconfig I9_0 -width 4
 768         $w.c itemconfig I9_1 -width 1
 769         $w.c lower I9_1 I9_0
 770     } else {
 771         $w.c itemconfig I9_0 -width 1
 772         $w.c itemconfig I9_1 -width 4
 773         $w.c lower I9_0 I9_1
 774     }
 775     if {$step == 0} {return 3}
 776     return 1
 777 }
 778 # Boat
 779 proc Draw10 {} {
 780     global w
 781     set color $::C(10a)
 782     set color2 $::C(10b)
 783     set xy {191 230 233 230 233 178 191 178}    ;# Sail
 784     $w.c create poly $xy -fill $color -width 3 -outline $::C(fg) -tag I10
 785     set xy [box 209 204 31]                     ;# Front
 786     $w.c create arc $xy -outline {} -fill $color -style pie \
 787             -start 120 -extent 120 -tag I10
 788     $w.c create arc $xy -outline $::C(fg) -width 3 -style arc \
 789             -start 120 -extent 120 -tag I10
 790     set xy [box 249 204 31]                     ;# Back
 791     $w.c create arc $xy -outline {} -fill $::C(bg) -width 3 -style pie \
 792             -start 120 -extent 120 -tag I10
 793     $w.c create arc $xy -outline $::C(fg) -width 3 -style arc \
 794             -start 120 -extent 120 -tag I10
 795
 796     set xy {200 171 200 249}                    ;# Mast
 797     $w.c create line $xy -fill $::C(fg) -width 3 -tag I10
 798     set xy {159 234 182 234}                    ;# Bow sprit
 799     $w.c create line $xy -fill $::C(fg) -width 3 -tag I10
 800     set xy {180 234 180 251 220 251}            ;# Hull
 801     $w.c create line $xy -fill $::C(fg) -width 6 -tag I10
 802
 803     set xy {92 255 221 255}                     ;# Waves
 804     eval Sine $xy 2 25 -fill $color2 -width 1 -tag I10w
 805
 806     set xy [lrange [$w.c coords I10w] 4 end-4]    ;# Water
 807     set xy [concat $xy 222 266 222 277 99 277]
 808     $w.c create poly $xy -fill $color2 -outline $color2
 809     set xy {222 266 222 277 97 277 97 266}      ;# Water bottom
 810     $w.c create line $xy -fill $::C(fg) -width 3
 811
 812     set xy [box 239 262 17]
 813     $w.c create arc $xy -outline $::C(fg) -width 3 -style arc \
 814             -start 95 -extent 103
 815     set xy [box 76 266 21]
 816     $w.c create arc $xy -outline $::C(fg) -width 3 -style arc -extent 190
 817 }
 818 proc Move10 {{step {}}} {
 819     set step [GetStep 10 $step]
 820     set pos {
 821         {195 212} {193 212} {190 212} {186 212} {181 212} {176 212}
 822         {171 212} {166 212} {161 212} {156 212} {151 212} {147 212} {142 212}
 823         {137 212} {132 212 x} {127 212} {121 212} {116 212} {111 212}
 824     }
 825
 826     if {$step >= [llength $pos]} {return 0}
 827     set where [lindex $pos $step]
 828     MoveAbs I10 $where
 829
 830     if {[lindex $where 2] == "x"} {return 3}
 831     return 1
 832 }
 833 # 2nd ball drop
 834 proc Draw11 {} {
 835     global w
 836     set color $::C(11a)
 837     set color2 $::C(11b)
 838     set xy {23 264 55 591}                      ;# Color the down tube
 839     $w.c create rect $xy -fill $color -outline {}
 840     set xy [box 71 460 48]                      ;# Color the outer loop
 841     $w.c create oval $xy -fill $color -outline {}
 842
 843     set xy {55 264 55 458}                      ;# Top right side
 844     $w.c create line $xy -fill $::C(fg) -width 3
 845     set xy {55 504 55 591}                      ;# Bottom right side
 846     $w.c create line $xy -fill $::C(fg) -width 3
 847     set xy [box 71 460 48]                      ;# Outer loop
 848     $w.c create arc $xy -outline $::C(fg) -width 3 -style arc \
 849             -start 110 -extent -290 -tag I11i
 850     set xy [box 71 460 16]                      ;# Inner loop
 851     $w.c create oval $xy -outline $::C(fg) -fill {} -width 3 -tag I11i
 852     $w.c create oval $xy -outline $::C(fg) -fill $::C(bg) -width 3
 853
 854     set xy {23 264 23 591}                      ;# Left side
 855     $w.c create line $xy -fill $::C(fg) -width 3
 856     set xy [box 1 266 23]                       ;# Top left curve
 857     $w.c create arc $xy -outline $::C(fg) -width 3 -style arc -extent 90
 858
 859     set xy [box 75 235 9]                       ;# The ball
 860     $w.c create oval $xy -fill $color2 -outline {} -width 3 -tag I11
 861 }
 862 proc Move11 {{step {}}} {
 863     set step [GetStep 11 $step]
 864     set pos {
 865         {75 235} {70 235} {65 237} {56 240} {46 247} {38 266} {38 296}
 866         {38 333} {38 399} {38 475} {74 496} {105 472} {100 437} {65 423}
 867         {-100 -100} {38 505} {38 527 x} {38 591}
 868     }
 869
 870     if {$step >= [llength $pos]} {return 0}
 871     set where [lindex $pos $step]
 872     MoveAbs I11 $where
 873     if {[lindex $where 2] == "x"} {return 3}
 874     return 1
 875 }
 876 # Hand
 877 proc Draw12 {} {
 878     global w
 879     set xy {20 637 20 617 20 610 20 590 40 590 40 590 60 590 60 610 60 610}
 880     lappend xy 60 610 65 620 60 631             ;# Thumb
 881     lappend xy 60 631 60 637 60 662 60 669 52 669 56 669 50 669 50 662 50 637
 882
 883     set y0 637                                  ;# Bumps for fingers
 884     set y1 645
 885     for {set x 50} {$x > 20} {incr x -10} {
 886         set x1 [expr {$x - 5}]
 887         set x2 [expr {$x - 10}]
 888         lappend xy $x $y0 $x1 $y1 $x2 $y0
 889     }
 890     $w.c create poly $xy -fill $::C(12) -outline $::C(fg) -smooth 1 -tag I12 \
 891             -width 3
 892 }
 893 proc Move12 {{step {}}} {
 894     set step [GetStep 12 $step]
 895     set pos {{42.5 641 x}}
 896     if {$step >= [llength $pos]} {return 0}
 897
 898     set where [lindex $pos $step]
 899     MoveAbs I12 $where
 900     if {[lindex $where 2] == "x"} {return 3}
 901     return 1
 902 }
 903 # Fax
 904 proc Draw13 {} {
 905     global w
 906     set color $::C(13a)
 907     set xy {86 663 149 663 149 704 50 704 50 681 64 681 86 671}
 908     set xy2 {784 663 721 663 721 704 820 704 820 681 806 681 784 671}
 909     set radii {2 9 9 8 5 5 2}
 910
 911     RoundPoly $w.c $xy $radii -width 3 -outline $::C(fg) -fill $color
 912     RoundPoly $w.c $xy2 $radii -width 3 -outline $::C(fg) -fill $color
 913
 914     set xy {56 677}
 915     $w.c create rect [eval box $xy 4] -fill {} -outline $::C(fg) -width 3 -tag I13
 916     set xy {809 677}
 917     $w.c create rect [eval box $xy 4] -fill {} -outline $::C(fg) -width 3 -tag I13R
 918
 919     set xy {112 687}                            ;# Label
 920     $w.c create text $xy -text "FAX" -fill $::C(fg) -font {{Times Roman} 12 bold}
 921     set xy {762 687}
 922     $w.c create text $xy -text "FAX" -fill $::C(fg) -font {{Times Roman} 12 bold}
 923
 924     set xy {138 663 148 636 178 636}            ;# Paper guide
 925     $w.c create line $xy -smooth 1 -fill $::C(fg) -width 3
 926     set xy {732 663 722 636 692 636}
 927     $w.c create line $xy -smooth 1 -fill $::C(fg) -width 3
 928
 929     Sine 149 688 720 688 5 15 -tag I13_s -fill $::C(fg) -width 3
 930 }
 931 proc Move13 {{step {}}} {
 932     global w
 933     set step [GetStep 13 $step]
 934     set numsteps 7
 935
 936     if {$step == $numsteps+2} {
 937         MoveAbs I13_star {-100 -100}
 938         $w.c itemconfig I13R -fill $::C(13b) -width 2
 939         return 2
 940     }
 941     if {$step == 0} {                           ;# Button down
 942         $w.c delete I13
 943         Sparkle {-100 -100} I13_star            ;# Create off screen
 944         return 1
 945     }
 946     foreach {x0 y0} [Anchor I13_s w] {x1 y1} [Anchor I13_s e] break
 947     set x [expr {$x0 + ($x1-$x0) * ($step - 1) / double($numsteps)}]
 948     MoveAbs I13_star [list $x $y0]
 949     return 1
 950 }
 951 # Paper in fax
 952 proc Draw14 {} {
 953     global w
 954     set color $::C(14)
 955     set xy {102 661 113 632 130 618}            ;# Left paper edge
 956     $w.c create line $xy -smooth 1 -fill $color -width 3 -tag I14L_0
 957     set xy {148 629 125 640 124 662}            ;# Right paper edge
 958     $w.c create line $xy -smooth 1 -fill $color -width 3 -tag I14L_1
 959     Draw14a L
 960
 961     set xy {
 962         768.0 662.5 767.991316225 662.433786215 767.926187912 662.396880171
 963     }
 964     $w.c create line $xy -smooth 1 -fill $color -width 3 -tag I14R_0
 965     $w.c lower I14R_0
 966     # NB. these numbers are VERY sensitive, you must start with final size
 967     # and shrink down to get the values
 968     set xy {
 969         745.947897349 662.428358855 745.997829056 662.452239237 746.0 662.5
 970     }
 971     $w.c create line $xy -smooth 1 -fill $color -width 3 -tag I14R_1
 972     $w.c lower I14R_1
 973 }
 974 proc Draw14a {side} {
 975     global w
 976     set color $::C(14)
 977     set xy [$w.c coords I14${side}_0]
 978     set xy2 [$w.c coords I14${side}_1]
 979     foreach {x0 y0 x1 y1 x2 y2} $xy break
 980     foreach {x3 y3 x4 y4 x5 y5} $xy2 break
 981     set zz [concat \
 982             $x0 $y0 $x0 $y0 $xy $x2 $y2 $x2 $y2 \
 983             $x3 $y3 $x3 $y3 $xy2 $x5 $y5 $x5 $y5]
 984     $w.c delete I14$side
 985     $w.c create poly $zz -tag I14$side -smooth 1 -fill $color -outline $color \
 986             -width 3
 987     $w.c lower I14$side
 988 }
 989 proc Move14 {{step {}}} {
 990     global w
 991     set step [GetStep 14 $step]
 992
 993     # Paper going down
 994     set sc [expr {.9 - .05*$step}]
 995     if {$sc < .3} {
 996         $w.c delete I14L
 997         return 0
 998     }
 999
1000     foreach {Ox Oy} [$w.c coords I14L_0] break
1001     $w.c scale I14L_0 $Ox $Oy $sc $sc
1002     foreach {Ox Oy} [lrange [$w.c coords I14L_1] end-1 end] break
1003     $w.c scale I14L_1 $Ox $Oy $sc $sc
1004     Draw14a L
1005
1006     # Paper going up
1007     set sc [expr {.35 + .05*$step}]
1008     set sc [expr {1 / $sc}]
1009
1010     foreach {Ox Oy} [$w.c coords I14R_0] break
1011     $w.c scale I14R_0 $Ox $Oy $sc $sc
1012     foreach {Ox Oy} [lrange [$w.c coords I14R_1] end-1 end] break
1013     $w.c scale I14R_1 $Ox $Oy $sc $sc
1014     Draw14a R
1015
1016     return [expr {$step == 10 ? 3 : 1}]
1017 }
1018 # Light beam
1019 proc Draw15 {} {
1020     global w
1021     set color $::C(15a)
1022     set xy {824 599 824 585 820 585 829 585}
1023     $w.c create line $xy -fill $::C(fg) -width 3 -tag I15a
1024     set xy {789 599 836 643}
1025     $w.c create rect $xy -fill $color -outline $::C(fg) -width 3
1026     set xy {778 610 788 632}
1027     $w.c create rect $xy -fill $color -outline $::C(fg) -width 3
1028     set xy {766 617 776 625}
1029     $w.c create rect $xy -fill $color -outline $::C(fg) -width 3
1030
1031     set xy {633 600 681 640}
1032     $w.c create rect $xy -fill $color -outline $::C(fg) -width 3
1033     set xy {635 567 657 599}
1034     $w.c create rect $xy -fill $color -outline $::C(fg) -width 2
1035     set xy {765 557 784 583}
1036     $w.c create rect $xy -fill $color -outline $::C(fg) -width 2
1037
1038     Sine 658 580 765 580 3 15 -tag I15_s -fill $::C(fg) -width 3
1039 }
1040 proc Move15a {} {
1041     global w
1042     set color $::C(15b)
1043     $w.c scale I15a 824 599 1 .3                  ;# Button down
1044     set xy {765 621 681 621}
1045     $w.c create line $xy -dash "-" -width 3 -fill $color -tag I15
1046 }
1047 proc Move15 {{step {}}} {
1048     global w
1049     set step [GetStep 15 $step]
1050     set numsteps 6
1051
1052     if {$step == $numsteps+2} {
1053         MoveAbs I15_star {-100 -100}
1054         return 2
1055     }
1056     if {$step == 0} {                           ;# Break the light beam
1057         Sparkle {-100 -100} I15_star
1058         set xy {765 621 745 621}
1059         $w.c coords I15 $xy
1060         return 1
1061     }
1062     foreach {x0 y0} [Anchor I15_s w] {x1 y1} [Anchor I15_s e] break
1063     set x [expr {$x0 + ($x1-$x0) * ($step - 1) / double($numsteps)}]
1064     MoveAbs I15_star [list $x $y0]
1065     return 1
1066 }
1067 # Bell
1068 proc Draw16 {} {
1069     global w
1070     set color $::C(16)
1071     set xy {722 485 791 556}
1072     $w.c create rect $xy -fill {} -outline $::C(fg) -width 3
1073     set xy [box 752 515 25]                     ;# Bell
1074     $w.c create oval $xy -fill $color -outline black -tag I16b -width 2
1075     set xy [box 752 515 5]                      ;# Bell button
1076     $w.c create oval $xy -fill black -outline black -tag I16b
1077
1078     set xy {784 523 764 549}                    ;# Clapper
1079     $w.c create line $xy -width 3 -tag I16c -fill $::C(fg)
1080     set xy [box 784 523 4]
1081     $w.c create oval $xy -fill $::C(fg) -outline $::C(fg) -tag I16d
1082 }
1083 proc Move16 {{step {}}} {
1084     global w
1085     set step [GetStep 16 $step]
1086
1087     # Note: we never stop
1088     foreach {Ox Oy} {760 553} break
1089     if {$step & 1} {
1090         set beta 12
1091         $w.c move I16b 3 0
1092     } else {
1093         set beta -12
1094         $w.c move I16b -3 0
1095     }
1096     RotateItem I16c $Ox $Oy $beta
1097     RotateItem I16d $Ox $Oy $beta
1098
1099     return [expr {$step == 1 ? 3 : 1}]
1100 }
1101 # Cat
1102 proc Draw17 {} {
1103     global w
1104     set color $::C(17)
1105
1106     set xy {584 556 722 556}
1107     $w.c create line $xy -fill $::C(fg) -width 3
1108     set xy {584 485 722 485}
1109     $w.c create line $xy -fill $::C(fg) -width 3
1110
1111     set xy {664 523 717 549}                    ;# Body
1112     $w.c create arc $xy -outline $::C(fg) -fill $color -width 3 \
1113             -style chord -start 128 -extent -260 -tag I17
1114
1115     set xy {709 554 690 543}                    ;# Paw
1116     $w.c create oval $xy -outline $::C(fg) -fill $color -width 3 -tag I17
1117     set xy {657 544 676 555}
1118     $w.c create oval $xy -outline $::C(fg) -fill $color -width 3 -tag I17
1119
1120     set xy [box 660 535 15]                     ;# Lower face
1121     $w.c create arc $xy -outline $::C(fg) -width 3 -style arc \
1122             -start 150 -extent 240 -tag I17_
1123     $w.c create arc $xy -outline {} -fill $color -width 1 -style chord \
1124             -start 150 -extent 240 -tag I17_
1125     set xy {674 529 670 513 662 521 658 521 650 513 647 529} ;# Ears
1126     $w.c create line $xy -fill $::C(fg) -width 3 -tag I17_
1127     $w.c create poly $xy -fill $color -outline {} -width 1 -tag {I17_ I17_c}
1128     set xy {652 542 628 539}                    ;# Whiskers
1129     $w.c create line $xy -fill $::C(fg) -width 3 -tag I17_
1130     set xy {652 543 632 545}
1131     $w.c create line $xy -fill $::C(fg) -width 3 -tag I17_
1132     set xy {652 546 632 552}
1133     $w.c create line $xy -fill $::C(fg) -width 3 -tag I17_
1134
1135     set xy {668 543 687 538}
1136     $w.c create line $xy -fill $::C(fg) -width 3 -tag {I17_ I17w}
1137     set xy {668 544 688 546}
1138     $w.c create line $xy -fill $::C(fg) -width 3 -tag {I17_ I17w}
1139     set xy {668 547 688 553}
1140     $w.c create line $xy -fill $::C(fg) -width 3 -tag {I17_ I17w}
1141
1142     set xy {649 530 654 538 659 530}            ;# Left eye
1143     $w.c create line $xy -fill $::C(fg) -width 2 -smooth 1 -tag I17
1144     set xy {671 530 666 538 661 530}            ;# Right eye
1145     $w.c create line $xy -fill $::C(fg) -width 2 -smooth 1 -tag I17
1146     set xy {655 543 660 551 665 543}            ;# Mouth
1147     $w.c create line $xy -fill $::C(fg) -width 2 -smooth 1 -tag I17
1148 }
1149 proc Move17 {{step {}}} {
1150     global w
1151     set step [GetStep 17 $step]
1152
1153     if {$step == 0} {
1154         $w.c delete I17                           ;# Delete most of the cat
1155         set xy {655 543 660 535 665 543}        ;# Mouth
1156         $w.c create line $xy -fill $::C(fg) -width 3 -smooth 1 -tag I17_
1157         set xy [box 654 530 4]                  ;# Left eye
1158         $w.c create oval $xy -outline $::C(fg) -width 3 -fill {} -tag I17_
1159         set xy [box 666 530 4]                  ;# Right eye
1160         $w.c create oval $xy -outline $::C(fg) -width 3 -fill {} -tag I17_
1161
1162         $w.c move I17_ 0 -20                      ;# Move face up
1163         set xy {652 528 652 554}                ;# Front leg
1164         $w.c create line $xy -fill $::C(fg) -width 3 -tag I17_
1165         set xy {670 528 670 554}                ;# 2nd front leg
1166         $w.c create line $xy -fill $::C(fg) -width 3 -tag I17_
1167
1168         set xy {
1169             675 506 694 489 715 513 715 513 715 513 716 525 716 525 716 525
1170             706 530 695 530 679 535 668 527 668 527 668 527 675 522 676 517
1171             677 512
1172         }                                       ;# Body
1173         $w.c create poly $xy -fill [$w.c itemcget I17_c -fill] \
1174                 -outline $::C(fg) -width 3 -smooth 1 -tag I17_
1175         set xy {716 514 716 554}                ;# Back leg
1176         $w.c create line $xy -fill $::C(fg) -width 3 -tag I17_
1177         set xy {694 532 694 554}                ;# 2nd back leg
1178         $w.c create line $xy -fill $::C(fg) -width 3 -tag I17_
1179         set xy {715 514 718 506 719 495 716 488};# Tail
1180         $w.c create line $xy -fill $::C(fg) -width 3 -smooth 1 -tag I17_
1181
1182         $w.c raise I17w                           ;# Make whiskers visible
1183         $w.c move I17_ -5 0                       ;# Move away from the wall a bit
1184         return 2
1185     }
1186     return 0
1187 }
1188 # Sling shot
1189 proc Draw18 {} {
1190     global w
1191     set color $::C(18)
1192     set xy {721 506 627 506}                    ;# Sling hold
1193     $w.c create line $xy -width 4 -fill $::C(fg) -tag I18
1194
1195     set xy {607 500 628 513}                    ;# Sling rock
1196     $w.c create oval $xy -fill $color -outline {} -tag I18a
1197
1198     set xy {526 513 606 507 494 502}            ;# Sling band
1199     $w.c create line $xy -fill $::C(fg) -width 4 -tag I18b
1200     set xy { 485 490 510 540 510 575 510 540 535 491 } ;# Sling
1201     $w.c create line $xy -fill $::C(fg) -width 6
1202 }
1203 proc Move18 {{step {}}} {
1204     global w
1205     set step [GetStep 18 $step]
1206
1207     set pos {
1208         {587 506} {537 506} {466 506} {376 506} {266 506 x} {136 506}
1209         {16 506} {-100 -100}
1210     }
1211
1212     set b(0) {490 502 719 507 524 512}          ;# Band collapsing
1213     set b(1) {
1214         491 503 524 557 563 505 559 496 546 506 551 525 553 536 538 534
1215         532 519 529 499
1216     }
1217     set b(2) {491 503 508 563 542 533 551 526 561 539 549 550 530 500}
1218     set b(3) {491 503 508 563 530 554 541 562 525 568 519 544 530 501}
1219
1220     if {$step >= [llength $pos]} { return 0}
1221
1222     if {$step == 0} {
1223         $w.c delete I18
1224         $w.c itemconfig I18b -smooth 1
1225     }
1226     if {[info exists b($step)]} {
1227         $w.c coords I18b $b($step)
1228     }
1229
1230     set where [lindex $pos $step]
1231     MoveAbs I18a $where
1232     if {[lindex $where 2] == "x"} {return 3}
1233     return 1
1234 }
1235 # Water pipe
1236 proc Draw19 {} {
1237     global w
1238     set color $::C(19)
1239     set xx {249 181 155 118  86 55 22 0}
1240     foreach {x1 x2} $xx {
1241         $w.c create rect $x1 453 $x2 467 -fill $color -outline {} -tag I19
1242         $w.c create line $x1 453 $x2 453 -fill $::C(fg) -width 1 ;# Pipe top
1243         $w.c create line $x1 467 $x2 467 -fill $::C(fg) -width 1 ;# Pipe bottom
1244     }
1245     $w.c raise I11i
1246
1247     set xy [box 168 460 16]                     ;# Bulge by the joint
1248     $w.c create oval $xy -fill $color -outline {}
1249     $w.c create arc $xy -outline $::C(fg) -width 1 -style arc \
1250             -start 21 -extent 136
1251     $w.c create arc $xy -outline $::C(fg) -width 1 -style arc \
1252             -start -21 -extent -130
1253
1254     set xy {249 447 255 473}                    ;# First joint 26x6
1255     $w.c create rect $xy -fill $color -outline $::C(fg) -width 1
1256
1257     set xy [box 257 433 34]                     ;# Bend up
1258     $w.c create arc $xy -outline {} -fill $color -width 1 \
1259             -style pie -start 0 -extent -91
1260     $w.c create arc $xy -outline $::C(fg) -width 1 \
1261             -style arc -start 0 -extent -90
1262     set xy [box 257 433 20]
1263     $w.c create arc $xy -outline {} -fill $::C(bg) -width 1 \
1264             -style pie -start 0 -extent -92
1265     $w.c create arc $xy -outline $::C(fg) -width 1 \
1266             -style arc -start 0 -extent -90
1267     set xy [box 257 421 34]                     ;# Bend left
1268     $w.c create arc $xy -outline {} -fill $color -width 1 \
1269             -style pie -start 1 -extent 91
1270     $w.c create arc $xy -outline $::C(fg) -width 1 \
1271             -style arc -start 0 -extent 90
1272     set xy [box 257 421 20]
1273     $w.c create arc $xy -outline {} -fill $::C(bg) -width 1 \
1274             -style pie -start 0 -extent 90
1275     $w.c create arc $xy -outline $::C(fg) -width 1 \
1276             -style arc -start 0 -extent 90
1277     set xy [box 243 421 34]                     ;# Bend down
1278     $w.c create arc $xy -outline {} -fill $color -width 1 \
1279             -style pie -start 90 -extent 90
1280     $w.c create arc $xy -outline $::C(fg) -width 1 \
1281             -style arc -start 90 -extent 90
1282     set xy [box 243 421 20]
1283     $w.c create arc $xy -outline {} -fill $::C(bg) -width 1 \
1284             -style pie -start 90 -extent 90
1285     $w.c create arc $xy -outline $::C(fg) -width 1 \
1286             -style arc -start 90 -extent 90
1287
1288     set xy {270 427 296 433}                    ;# 2nd joint bottom
1289     $w.c create rect $xy -fill $color -outline $::C(fg) -width 1
1290     set xy {270 421 296 427}                    ;# 2nd joint top
1291     $w.c create rect $xy -fill $color -outline $::C(fg) -width 1
1292     set xy {249 382 255 408}                    ;# Third joint right
1293     $w.c create rect $xy -fill $color -outline $::C(fg) -width 1
1294     set xy {243 382 249 408}                    ;# Third joint left
1295     $w.c create rect $xy -fill $color -outline $::C(fg) -width 1
1296     set xy {203 420 229 426}                    ;# Last joint
1297     $w.c create rect $xy -fill $color -outline $::C(fg) -width 1
1298
1299     set xy [box 168 460 6]                      ;# Handle joint
1300     $w.c create oval $xy -fill $::C(fg) -outline {} -tag I19a
1301     set xy {168 460 168 512}                    ;# Handle bar
1302     $w.c create line $xy -fill $::C(fg) -width 5 -tag I19b
1303 }
1304 proc Move19 {{step {}}} {
1305     set step [GetStep 19 $step]
1306
1307     set angles {30 30 30}
1308     if {$step == [llength $angles]} {return 2}
1309
1310     foreach {Ox Oy} [Centroid I19a] break
1311     RotateItem I19b $Ox $Oy [lindex $angles $step]
1312
1313     return 1
1314 }
1315 # Water pouring
1316 proc Draw20 {} {
1317 }
1318 proc Move20 {{step {}}} {
1319     global w
1320     set step [GetStep 20 $step]
1321
1322     set pos {451 462 473 484 496 504 513 523 532}
1323     set freq {20 40   40  40  40  40  40  40  40}
1324     set pos {
1325         {451 20} {462 40} {473 40} {484 40} {496 40} {504 40} {513 40}
1326         {523 40} {532 40 x}
1327     }
1328     if {$step >= [llength $pos]} {return 0}
1329
1330     $w.c delete I20
1331     set where [lindex $pos $step]
1332     foreach {y f} $where break
1333     H2O $y $f
1334     if {[lindex $where 2] == "x"} {return 3}
1335     return 1
1336 }
1337 proc H2O {y f} {
1338     global w
1339     set color $::C(20)
1340     $w.c delete I20
1341
1342     Sine 208 428 208 $y 4 $f -tag {I20 I20s} -width 3 -fill $color -smooth 1
1343     $w.c create line [$w.c coords I20s] -width 3 -fill $color -smooth 1 -tag {I20 I20a}
1344     $w.c create line [$w.c coords I20s] -width 3 -fill $color -smooth 1 -tag {I20 I20b}
1345     $w.c move I20a 8 0
1346     $w.c move I20b 16 0
1347 }
1348 # Bucket
1349 proc Draw21 {} {
1350     global w
1351     set color $::C(21)
1352     set xy {217 451 244 490}                    ;# Right handle
1353     $w.c create line $xy -fill $::C(fg) -width 2 -tag I21_a
1354     set xy {201 467 182 490}                    ;# Left handle
1355     $w.c create line $xy -fill $::C(fg) -width 2 -tag I21_a
1356
1357     set xy {245 490 237 535}                    ;# Right side
1358     set xy2 {189 535 181 490}                   ;# Left side
1359     $w.c create poly [concat $xy $xy2] -fill $color -outline {} -tag {I21 I21f}
1360     $w.c create line $xy -fill $::C(fg) -width 2 -tag I21
1361     $w.c create line $xy2 -fill $::C(fg) -width 2 -tag I21
1362
1363     set xy {182 486 244 498}                    ;# Top
1364     $w.c create oval $xy -fill $color -outline {} -width 2 -tag {I21 I21f}
1365     $w.c create oval $xy -fill {} -outline $::C(fg) -width 2 -tag {I21 I21t}
1366     set xy {189 532 237 540}                    ;# Bottom
1367     $w.c create oval $xy -fill $color -outline $::C(fg) -width 2 -tag {I21 I21b}
1368 }
1369 proc Move21 {{step {}}} {
1370     global w
1371     set step [GetStep 21 $step]
1372
1373     set numsteps 30
1374     if {$step  >= $numsteps} {return 0}
1375
1376     foreach {x1 y1 x2 y2} [$w.c coords I21b] break
1377     #foreach {X1 Y1 X2 Y2} [$w.c coords I21t] break
1378     foreach {X1 Y1 X2 Y2} {183 492 243 504} break
1379
1380     set f [expr {$step / double($numsteps)}]
1381     set y2 [expr {$y2 - 3}]
1382     set xx1 [expr {$x1 + ($X1 - $x1) * $f}]
1383     set yy1 [expr {$y1 + ($Y1 - $y1) * $f}]
1384     set xx2 [expr {$x2 + ($X2 - $x2) * $f}]
1385     set yy2 [expr {$y2 + ($Y2 - $y2) * $f}]
1386     #H2O $yy1 40
1387
1388     $w.c itemconfig I21b -fill $::C(20)
1389     $w.c delete I21w
1390     $w.c create poly $x2 $y2 $x1 $y1 $xx1 $yy1 $xx2 $yy1 -tag {I21 I21w} \
1391             -outline {} -fill $::C(20)
1392     $w.c lower I21w I21
1393     $w.c raise I21b
1394     $w.c lower I21f
1395
1396     return [expr {$step == $numsteps-1 ? 3 : 1}]
1397 }
1398 # Bucket drop
1399 proc Draw22 {} {
1400 }
1401 proc Move22 {{step {}}} {
1402     global w
1403     set step [GetStep 22 $step]
1404     set pos {{213 513} {213 523} {213 543 x} {213 583} {213 593}}
1405
1406     if {$step == 0} {$w.c itemconfig I21f -fill $::C(22)}
1407     if {$step >= [llength $pos]} {return 0}
1408     set where [lindex $pos $step]
1409     MoveAbs I21 $where
1410     H2O [lindex $where 1] 40
1411     $w.c delete I21_a                             ;# Delete handles
1412
1413     if {[lindex $where 2] == "x"} {return 3}
1414     return 1
1415 }
1416 # Blow dart
1417 proc Draw23 {} {
1418     global w
1419     set color  $::C(23a)
1420     set color2 $::C(23b)
1421     set color3 $::C(23c)
1422
1423     set xy {185 623 253 650}                    ;# Block
1424     $w.c create rect $xy -fill black -outline $::C(fg) -width 2 -tag I23a
1425     set xy {187 592 241 623}                    ;# Balloon
1426     $w.c create oval $xy -outline {} -fill $color -tag I23b
1427     $w.c create arc $xy -outline $::C(fg) -width 3 -tag I23b \
1428             -style arc -start 12 -extent 336
1429     set xy {239 604  258 589 258 625 239 610}   ;# Balloon nozzle
1430     $w.c create poly $xy -outline {} -fill $color -tag I23b
1431     $w.c create line $xy -fill $::C(fg) -width 3 -tag I23b
1432
1433     set xy {285 611 250 603}                    ;# Dart body
1434     $w.c create oval $xy -fill $color2 -outline $::C(fg) -width 3 -tag I23d
1435     set xy {249 596 249 618 264 607 249 596}    ;# Dart tail
1436     $w.c create poly $xy -fill $color3 -outline $::C(fg) -width 3 -tag I23d
1437     set xy {249 607 268 607}                    ;# Dart detail
1438     $w.c create line $xy -fill $::C(fg) -width 3 -tag I23d
1439     set xy {285 607 305 607}                    ;# Dart needle
1440     $w.c create line $xy -fill $::C(fg) -width 3 -tag I23d
1441 }
1442 proc Move23 {{step {}}} {
1443     global w
1444     set step [GetStep 23 $step]
1445
1446     set pos {
1447         {277 607} {287 607} {307 607 x} {347 607} {407 607} {487 607}
1448         {587 607} {687 607} {787 607} {-100 -100}
1449     }
1450
1451     if {$step >= [llength $pos]} {return 0}
1452     if {$step <= 1} {
1453         eval $w.c scale I23b [Anchor I23a n] .9 .5
1454     }
1455     set where [lindex $pos $step]
1456     MoveAbs I23d $where
1457
1458     if {[lindex $where 2] == "x"} {return 3}
1459     return 1
1460 }
1461 # Balloon
1462 proc Draw24 {} {
1463     global w
1464     set color $::C(24a)
1465     set xy {366 518 462 665}                    ;# Balloon
1466     $w.c create oval $xy -fill $color -outline $::C(fg) -width 3 -tag I24
1467     set xy {414 666 414 729}                    ;# String
1468     $w.c create line $xy -fill $::C(fg) -width 3 -tag I24
1469     set xy {410 666 404 673 422 673 418 666}    ;# Nozzle
1470     $w.c create poly $xy -fill $color -outline $::C(fg) -width 3 -tag I24
1471
1472     set xy {387 567 390 549 404 542}            ;# Reflections
1473     $w.c create line $xy -fill $::C(fg) -smooth 1 -width 2 -tag I24
1474     set xy {395 568 399 554 413 547}
1475     $w.c create line $xy -fill $::C(fg) -smooth 1 -width 2 -tag I24
1476     set xy {403 570 396 555 381 553}
1477     $w.c create line $xy -fill $::C(fg) -smooth 1 -width 2 -tag I24
1478     set xy {408 564 402 547 386 545}
1479     $w.c create line $xy -fill $::C(fg) -smooth 1 -width 2 -tag I24
1480 }
1481 proc Move24 {{step {}}} {
1482     global S w
1483     set step [GetStep 24 $step]
1484
1485     if {$step > 4} {return 0}
1486     if {$step == 4} {return 2}
1487
1488     if {$step == 0} {
1489         $w.c delete I24                           ;# Exploding balloon
1490         set xy {
1491             347 465 361 557 271 503 272 503 342 574 259 594 259 593 362 626
1492             320 737 320 740 398 691 436 738 436 739 476 679 528 701 527 702
1493             494 627 548 613 548 613 480 574 577 473 577 473 474 538 445 508
1494             431 441 431 440 400 502 347 465 347 465
1495         }
1496         $w.c create poly $xy -tag I24 -fill $::C(24b) -outline $::C(24a) \
1497                 -width 10 -smooth 1
1498         set msg [subst $S(message)]
1499         $w.c create text [Centroid I24] -text $msg -tag {I24 I24t} \
1500                 -justify center -font {{Times Roman} 18 bold}
1501         return 1
1502     }
1503
1504     $w.c itemconfig I24t -font [list {Times Roman} [expr {18 + 6*$step}] bold]
1505     $w.c move I24 0 -60
1506     eval $w.c scale I24 [Centroid I24] 1.25 1.25
1507     return 1
1508 }
1509 # Displaying the message
1510 proc Move25 {{step {}}} {
1511     global S
1512     set step [GetStep 25 $step]
1513     if {$step == 0} {
1514         set ::XY(25) [clock clicks -milliseconds]
1515         return 1
1516     }
1517     set elapsed [expr {[clock clicks -milliseconds] - $::XY(25)}]
1518     if {$elapsed < 5000} {return 1}
1519     return 2
1520 }
1521 # Collapsing balloon
1522 proc Move26 {{step {}}} {
1523     global S w
1524     set step [GetStep 26 $step]
1525
1526     if {$step >= 3} {
1527         $w.c delete I24 I26
1528         $w.c create text 430 755 -anchor s -tag I26 \
1529                 -text "click to continue" -font {{Times Roman} 24 bold}
1530         bind $w.c <1> Reset
1531         return 4
1532     }
1533
1534     eval $w.c scale I24 [Centroid I24] .8 .8
1535     $w.c move I24 0 60
1536     $w.c itemconfig I24t -font [list {Times Roman} [expr {30 - 6*$step}] bold]
1537     return 1
1538 }
1539
1540 ################################################################
1541 #
1542 # Helper functions
1543 #
1544 proc box {x y r} {
1545     return [list [expr {$x-$r}] [expr {$y-$r}] [expr {$x+$r}] [expr {$y+$r}]]
1546 }
1547 proc MoveAbs {item xy} {
1548     global w
1549     foreach {x y} $xy break
1550     foreach {Ox Oy} [Centroid $item] break
1551     set dx [expr {$x - $Ox}]
1552     set dy [expr {$y - $Oy}]
1553     $w.c move $item $dx $dy
1554 }
1555 proc RotateItem {item Ox Oy beta} {
1556     global w
1557     set xy [$w.c coords $item]
1558     set xy2 {}
1559     foreach {x y} $xy {
1560         eval lappend xy2 [RotateC $x $y $Ox $Oy $beta]
1561     }
1562     $w.c coords $item $xy2
1563 }
1564 proc RotateC {x y Ox Oy beta} {
1565     # rotates vector (Ox,Oy)->(x,y) by beta degrees clockwise
1566
1567     set x [expr {$x - $Ox}]                     ;# Shift to origin
1568     set y [expr {$y - $Oy}]
1569
1570     set beta [expr {$beta * atan(1) * 4 / 180.0}] ;# Radians
1571     set xx [expr {$x * cos($beta) - $y * sin($beta)}] ;# Rotate
1572     set yy [expr {$x * sin($beta) + $y * cos($beta)}]
1573
1574     set xx [expr {$xx + $Ox}]                   ;# Shift back
1575     set yy [expr {$yy + $Oy}]
1576
1577     return [list $xx $yy]
1578 }
1579
1580 proc Reset {} {
1581     global S w
1582     DrawAll
1583     bind $w.c <1> {}
1584     set S(mode) $::MSTART
1585     set S(active) 0
1586 }
1587 # Each Move## keeps its state info in STEP, this retrieves and increments it
1588 proc GetStep {who step} {
1589     global STEP
1590     if {$step != {}} {
1591         set STEP($who) $step
1592     } else {
1593         if {! [info exists STEP($who)] || $STEP($who) == ""} {
1594             set STEP($who) 0
1595         } else {
1596             incr STEP($who)
1597         }
1598     }
1599     return $STEP($who)
1600 }
1601 proc ResetStep {} {
1602     global STEP
1603     set ::S(cnt) 0
1604     foreach a [array names STEP] { set STEP($a) ""}
1605 }
1606 proc Sine {x0 y0 x1 y1 amp freq args} {
1607     global w
1608     set PI [expr {4 * atan(1)}]
1609     set step 2
1610     set xy {}
1611     if {$y0 == $y1} {                           ;# Horizontal
1612         for {set x $x0} {$x <= $x1} {incr x $step} {
1613             set beta [expr {($x - $x0) * 2 * $PI / $freq}]
1614             set y [expr {$y0 + $amp * sin($beta)}]
1615             lappend xy $x $y
1616         }
1617     } else {
1618         for {set y $y0} {$y <= $y1} {incr y $step} {
1619             set beta [expr {($y - $y0) * 2 * $PI / $freq}]
1620             set x [expr {$x0 + $amp * sin($beta)}]
1621             lappend xy $x $y
1622         }
1623     }
1624     return [eval $w.c create line $xy $args]
1625 }
1626 proc RoundRect {xy radius args} {
1627     global w
1628     foreach {x0 y0 x3 y3} $xy break
1629     set r [winfo pixels $w.c $radius]
1630     set d [expr {2 * $r}]
1631
1632     # Make sure that the radius of the curve is less than 3/8 size of the box!
1633     set maxr 0.75
1634     if {$d > $maxr * ($x3 - $x0) } {
1635         set d [expr { $maxr * ($x3 - $x0)}]
1636     }
1637     if {$d > $maxr * ($y3 - $y0) } {
1638         set d [expr { $maxr * ($y3 - $y0) }]
1639     }
1640
1641     set x1 [expr { $x0 + $d }]
1642     set x2 [expr { $x3 - $d }]
1643     set y1 [expr { $y0 + $d }]
1644     set y2 [expr { $y3 - $d }]
1645
1646     set xy [list $x0 $y0 $x1 $y0 $x2 $y0 $x3 $y0 $x3 $y1 $x3 $y2]
1647     lappend xy $x3 $y3 $x2 $y3 $x1 $y3 $x0 $y3 $x0 $y2 $x0 $y1
1648     return $xy
1649 }
1650 proc RoundPoly {canv xy radii args} {
1651     set lenXY [llength $xy]
1652     set lenR [llength $radii]
1653     if {$lenXY != 2*$lenR} {
1654         error "wrong number of vertices and radii"
1655     }
1656
1657     set knots {}
1658     foreach {x0 y0} [lrange $xy end-1 end] break
1659     foreach {x1 y1} $xy break
1660     eval lappend xy [lrange $xy 0 1]
1661
1662     for {set i 0} {$i < $lenXY} {incr i 2} {
1663         set radius [lindex $radii [expr {$i/2}]]
1664         set r [winfo pixels $canv $radius]
1665
1666         foreach {x2 y2} [lrange $xy [expr {$i + 2}] [expr {$i + 3}]] break
1667         set z [_RoundPoly2 $x0 $y0 $x1 $y1 $x2 $y2 $r]
1668         eval lappend knots $z
1669
1670         foreach {x0 y0} [list $x1 $y1] break
1671         foreach {x1 y1} [list $x2 $y2] break
1672     }
1673     set n [eval $canv create polygon $knots -smooth 1 $args]
1674     return $n
1675 }
1676 proc _RoundPoly2 {x0 y0 x1 y1 x2 y2 radius} {
1677     set d [expr { 2 * $radius }]
1678     set maxr 0.75
1679
1680     set v1x [expr {$x0 - $x1}]
1681     set v1y [expr {$y0 - $y1}]
1682     set v2x [expr {$x2 - $x1}]
1683     set v2y [expr {$y2 - $y1}]
1684
1685     set vlen1 [expr {sqrt($v1x*$v1x + $v1y*$v1y)}]
1686     set vlen2 [expr {sqrt($v2x*$v2x + $v2y*$v2y)}]
1687     if {$d > $maxr * $vlen1} {
1688         set d [expr {$maxr * $vlen1}]
1689     }
1690     if {$d > $maxr * $vlen2} {
1691         set d [expr {$maxr * $vlen2}]
1692     }
1693
1694     lappend xy [expr {$x1 + $d * $v1x/$vlen1}] [expr {$y1 + $d * $v1y/$vlen1}]
1695     lappend xy $x1 $y1
1696     lappend xy [expr {$x1 + $d * $v2x/$vlen2}] [expr {$y1 + $d * $v2y/$vlen2}]
1697
1698     return $xy
1699 }
1700 proc Sparkle {Oxy tag} {
1701     global w
1702     set xy {299 283 298 302 295 314 271 331 239 310 242 292 256 274 281 273}
1703     foreach {x y} $xy {
1704         $w.c create line 271 304 $x $y -fill white -width 3 -tag $tag
1705     }
1706     MoveAbs $tag $Oxy
1707 }
1708 proc Centroid {item} {
1709     return [Anchor $item c]
1710 }
1711 proc Anchor {item where} {
1712     global w
1713     foreach {x1 y1 x2 y2} [$w.c bbox $item] break
1714     if {[string first "n" $where] > -1} {
1715         set y $y1
1716     } elseif {[string first "s" $where] > -1} {
1717         set y $y2
1718     } else {
1719         set y [expr {($y1 + $y2) / 2.0}]
1720     }
1721     if {[string first "w" $where] > -1} {
1722         set x $x1
1723     } elseif {[string first "e" $where] > -1} {
1724         set x $x2
1725     } else {
1726         set x [expr {($x1 + $x2) / 2.0}]
1727     }
1728     return [list $x $y]
1729 }
1730
1731 DoDisplay
1732 Reset
1733 Go                                              ;# Start everything going