#!/usr/local/bin/wish8.0 option add *selectBorderWidth 0 option add *highThickness 0 option add *foreground #ffff00 option add *background #cc3300 option add *activeBackground #cc3300 option add *highlightBackground #cc3300 option add *highlightColor #cc3300 option add *troughColor #cc3300 set items \ {{ 290 387 301 437 311 402 #ffa500} { 240 400 254 400 248 438 #ffa500} { 307 396 308 344 342 340 #ffff00} { 247 399 235 373 256 345 #0000ff} { 325 340 331 332 322 323 315 333 #0000ff} { 307 327 313 320 305 313 299 319 #ffff00} { 235 366 235 350 240 355 #ffff00} { 240 338 247 349 256 335 249 327 #fe0000} { 255 315 260 322 260 305 #0000ff} { 338 330 303 248 274 279 #fe0000} { 301 242 291 231 301 221 309 230 #0000ff} { 271 267 279 256 270 249 264 259 #0000ff} { 270 229 274 240 290 231 282 223 #fe0000} { 235 338 267 271 235 231 #ffff00} { 263 245 263 229 258 230 #ffffff} { 338 259 338 226 313 195 #00ff00} { 338 259 338 226 347 232 #fe0000} { 272 221 302 215 269 198 #ffff00} { 260 207 266 127 284 123 #ffff00} { 235 140 260 127 262 130 #fe0000} { 272 196 278 164 283 178 #ffff00} { 286 177 302 210 306 152 #ffff00} { 307 198 310 163 321 169 #ffff00} { 241 225 243 209 262 225 #ffa500} { 236 217 238 209 222 202 #0000ff} { 213 239 222 211 216 204 #00ff00} { 212 238 217 205 212 193 #fe0000} { 254 215 247 175 236 180 #ffffff} { 243 206 228 173 207 176 #0000ff} { 207 173 249 167 241 142 #0000ff} { 252 165 245 142 263 135 #0000ff} { 306 149 328 165 346 149 #a52a2a} { 345 172 380 163 358 148 #a52a2a} { 370 176 403 169 386 161 #ffa500} { 397 177 407 174 416 188 #a52a2a} { 409 173 412 178 415 172 #a9a9a9} { 414 180 416 183 419 178 #a9a9a9} { 402 182 406 184 404 187 #a9a9a9} { 409 186 411 187 410 191 #a9a9a9} { 329 168 346 194 335 164 #fe0000} { 316 190 336 192 328 168 #0000ff} { 337 193 350 222 371 201 #0000ff} { 358 186 374 202 390 177 #0000ff} { 296 147 292 138 301 141 #ffa500} { 305 143 308 93 337 108 #ffa500} { 307 85 327 96 327 80 #ffff00} { 336 97 342 105 342 90 #ffff00} { 285 145 290 100 299 97 #00ff00} { 292 96 296 74 298 86 #00ff00} { 298 88 308 80 312 55 #00ff00} { 308 79 320 73 338 52 #00ff00} { 319 75 331 79 350 60 #00ff00} { 330 80 331 99 347 73 #00ff00} { 347 73 344 78 352 85 #00ff00} { 332 120 332 140 339 113 #00ff00}} set help1 "Press to fire up a new jester! Press if you want to break! Move the slider for\ fire speed! Lower values becomes faster, higher values becomes slower." canvas .c -relief sunken -height 480 -width 600 -bg #cc3300 -bd 0 pack .c -in . -side top button .c.bt1 -text Restart -command Draw .c create window 430 80 -width 0 -window .c.bt1 -anchor w button .c.bt2 -text Stop -command Stop .c create window 530 80 -width 0 -window .c.bt2 -anchor w .c create text 450 110 -text $help1 -width 130 -fill #ffff00 -anchor nw -font {Helvetica 10} scale .c.sc1 -from 10 -to 800 -command {} -orient hori -length 150 -bg #cc3300 -fg #ffff00 \ -font fixed -variable loops -label "Speed control:" .c create window 430 30 -width 0 -window .c.sc1 -anchor w button .c.bt3 -text "Puzzle" -command Puzzle label .c.lab -textvariable to_solve tkwait visibility .c update proc Stop {} { global go set go 0 } proc CreateItem {cmd color last} { global count if { "$last" == "true" } { incr count eval $cmd -fill \{\} -outline #000000 -tags \{draw2 p$count-2\} } set id [eval $cmd -fill $color -outline $color -tags \{draw p$count unsolved\}] return $id } proc Draw {} { global items loops go count update set go 1 set count 0 # draw poligons .c delete draw draw2 face help foreach t $items { for {set i $loops} {$i>=0} {incr i -1} { # Stop button pressed if !$go return # determine list length set len [llength $t] incr len -1 set coords {} for {set j 0} {$j<$len} {incr j} { set p [lindex $t $j] lappend coords [expr round($p - double($p) / $loops * $i)] } # draw new item, delete old items set color [lindex $t $len] set id [CreateItem ".c create polygon $coords" $color false] update .c delete $id } CreateItem ".c create polygon $coords" $color true } # draw balls foreach {x y} {212 243 338 262 284 151 333 147} { for {set r 100} {$r>3} {incr r -1} { set x1 [expr $x - $r] set x2 [expr $x + $r] set y1 [expr $y - $r] set y2 [expr $y + $r] set id [CreateItem ".c create oval $x1 $y1 $x2 $y2" #ffffff false] update .c delete $id } CreateItem ".c create oval $x1 $y1 $x2 $y2" #ffffff true } # draw face .c create polygon 309 114 312 116 309 120 -fill #000000 -outline #000000 -tags face .c create polygon 310 112 313 114 313 107 -fill #000000 -outline #000000 -tags face .c create polygon 321 119 324 121 321 125 -fill #000000 -outline #000000 -tags face .c create polygon 322 117 325 119 325 112 -fill #000000 -outline #000000 -tags face .c create window 430 320 -width 0 -window .c.bt3 -anchor nw -tags help .c create text 380 360 -text "Press to start a new game!" -fill #ffff00 \ -anchor nw -font {Helvetica 10} -tags help update } proc Fly {} { global go set dx 100 set x 240 set y 430 .c delete draw2 help while $go { while {$dx > 10} { .c scale draw $x $y 0.95 0.95 .c scale face $x $y 0.95 0.95 update scan [.c bbox withtag draw] "%d %d %d %d" x1 y1 x2 y2 set dx [expr $x2 - $x1] } while {$dx < 250} { .c scale draw $x $y 1.05 1.05 .c scale face $x $y 1.05 1.05 update scan [.c bbox withtag draw] "%d %d %d %d" x1 y1 x2 y2 set dx [expr $x2 - $x1] } } } proc Puzzle {} { global to_solve set to_solve " [llength [.c find withtag unsolved]] pieces are left!" .c delete help .c create text 380 260 -text "Move pieces by dragging it with left mouse button to destination point!" -fill #ffff00 \ -width 120 -anchor nw -font {Helvetica 10} -tags help .c create window 380 310 -window .c.lab -anchor nw -tags help set x 5 set y 5 foreach id [lsort -integer [.c find withtag unsolved]] { scan [.c bbox $id] "%d %d %d %d" x1 y1 x2 y2 .c move $id [expr $x - $x1] [expr $y - $y1] incr y [expr $y2 - $y1] if { $y > 400 } { incr x 30 set y 5 } } } proc MoveFrom {x y} { global piece .c dtag selected .c addtag selected withtag current .c raise current set piece(last_x) $x set piece(last_y) $y } proc MoveTo {x y} { global piece .c move selected [expr $x - $piece(last_x)] [expr $y - $piece(last_y)] set piece(last_x) $x set piece(last_y) $y } proc MoveStop {x y} { global piece to_solve scan [.c bbox selected] "%d %d %d %d" x1 y1 x2 y2 set p [lindex [.c gettags selected] 1] scan [eval .c bbox \$p-2] "%d %d %d %d" x1o y1o x2o y2o set diff [expr abs($x1o-$x1) + abs($x2o-$x2) + abs($y1o-$y1) + abs($y2o-$y2)] if { $diff < 70 } { set dx [expr $x1o-$x1] set dy [expr $y1o-$y1] .c move selected $dx $dy .c dtag selected unsolved } set to_solve " [llength [.c find withtag unsolved]] pieces are left!" .c raise face .c dtag selected if {[llength [.c find withtag unsolved]] == 0} { Fly } } proc AutoSolve {} { global to_solve foreach id [.c find withtag unsolved] { scan [.c bbox $id] "%d %d %d %d" x1 y1 x2 y2 set p [lindex [.c gettags $id] 1] scan [eval .c bbox \$p-2] "%d %d %d %d" x1o y1o x2o y2o set dx [expr $x1o-$x1] set dy [expr $y1o-$y1] .c move $id $dx $dy .c dtag $id unsolved set to_solve " [llength [.c find withtag unsolved]] pieces to solve!" update } .c raise face .c dtag selected Fly } set go 1 Draw bind . AutoSolve .c bind unsolved <1> {MoveFrom %x %y} .c bind unsolved {MoveTo %x %y} .c bind unsolved {MoveStop %x %y}