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).

Matches are obviously made from two [canvas] items: a longish rectangle and the head (an oval). The "mv" (movable) tag is added to clones of the ''ur''-matches, so movement and rotation have a common bind target. Both of these operations work on item sets, so both the stick and the head are handled. This assumes that the set tag is the second in the list of tags, as it is here.
}
 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 <B1-Motion> {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 item 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]
}