if 0 {[Richard Suchenwirth] 2005-05-07 - Matches (small wooden sticks to light fire) are popular for playing games, too (Martin Gardner devotes chapter 2 in ''Mathematical Circus'' to them, for example). Here's matches emulated in Tcl: [http://mini.net/files/match.gif] At top left you have a matchbox. Left-click on a match to get a duplicate ("clone") which you can drag on the playing field. Right-click on a match to rotate it by 30 degrees. The screenshot shows one of Gardner's simpler challenges (red: move one match to make the equation correct) and the solution (blue). } proc main {} { pack [canvas .c -background darkgreen] -fill both -expand 1 .c create rect 5 5 45 65 -fill white ;# matchbox set red [match .c 15 10 55 red] .c bind $red <1> {clone .c red %x %y} set blue [match .c 30 10 55 blue] .c bind $blue <1> {clone .c blue %x %y} .c bind mv <1> {select .c %x %y} .c bind mv {move .c %x %y} .c bind mv <3> {rotate .c} } #-- Draw a match, return the common ID of its items proc match {w x0 y0 y1 color} { set id [$w create poly \ [+ $x0 1] [+ $y0 1] [+ $x0 5] [+ $y0 1] \ [+ $x0 5] $y1 [+ $x0 1] $y1 -fill bisque -outline black] set head [$w create oval $x0 $y0 [+ $x0 6] [+ $y0 6] \ -fill $color] $w itemconfig $id -tag m$id $w itemconfig $head -tag m$id return m$id } #-- make a duplicate of the current match proc clone {w color x y} { foreach {x0 y0 x1 y1} [$w bbox current] break set id [match $w $x0 $y0 $y1 $color] $w itemconfig $id -tags [list mv mv$id] } #-- Store the current position in two global variables proc select {w x y} {set ::X $x; set ::Y $y} #-- Move the current items set proc move {w x y} { set id [$w find withtag current] set tag [lindex [$w gettags $id] 1] $w move $tag [- $x $::X] [- $y $::Y] set ::X $x; set ::Y $y } #-- rotate the current item set by 30 degrees, clockwise proc rotate w { set id [$w find withtag current] set tag [lindex [$w gettags $id] 1] foreach {x0 y0 x1 y1} [$w bbox $tag] break set xm [expr {($x0+$x1)/2.}] set ym [expr {($y0+$y1)/2.}] foreach item [$w find withtag $tag] { set coords {} foreach {x y} [$w coords $item] { set r [expr {hypot($x-$xm,$y-$ym)}] set a [expr {atan2($y-$ym,$x-$xm) + acos(-1)/6.}] lappend coords [expr {$xm+$r*cos($a)}] \ [expr {$ym+$r*sin($a)}] } $w coords $item $coords } } #-- prefix expr operators make the code shorter... foreach op {+ -} {proc $op {a b} "expr {\$a $op \$b}"} #-- Let's go! main if 0 { ---- [Category Toys] | [Arts and crafts of Tcl-Tk programming] }