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