Version 7 of Playing with matches

Updated 2005-05-08 06:31:51 by suchenwi

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> [list rotate .c [expr {acos(-1)/6.}]]
 }

#-- 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} {
    set id [$w find withtag current]
    set tag [lindex [$w gettags $id] 0]
    foreach {x0 y0 x1 y1} [$w bbox $tag] break
    set id [match $w $x0 $y0  $y1 $color]
    $w itemconfig $id -tags [list mv mv$id]
    select $w $x $y
 }

#-- 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

 proc rotate {w angle} {
    set id [$w find withtag current]
    set tag [lindex [$w gettags $id] 1]
    foreach {xm ym} [center $w $tag] break
    foreach item [$w find withtag $tag] {
        if {[$w type $item] eq "oval"} {
            rotate'circle $w $item $xm $ym $angle
        } else {
            set coords {}
            foreach {x y} [$w coords $item] {
                set r [expr {hypot($x-$xm,$y-$ym)}]
                set a [expr {atan2($y-$ym,$x-$xm) + $angle}]
                lappend coords [expr {$xm+$r*cos($a)}] \
                           [expr {$ym+$r*sin($a)}]
            }
            $w coords $item $coords
        }
    }
 }

#-- Rotate a circle (rather, rotate its center, and reconstruct its bbox)

 proc rotate'circle {w tag xm ym angle} {
    foreach {x0 y0 x1 y1} [$w coords $tag] break
    set x2 [expr {($x0+$x1)/2.}]
    set y2 [expr {($y0+$y1)/2.}]
    set rad [- $x2 $x0]
    set r [expr {hypot($x2-$xm,$y2-$ym)}]
    set a [expr {atan2($y2-$ym,$x2-$xm) + $angle}]
    set x [expr {$xm+$r*cos($a)}]
    set y [expr {$ym+$r*sin($a)}]
    $w coords $tag [- $x $rad] [- $y $rad] [+ $x $rad] [+ $y $rad]
 }

#-- Determine the center of a bounding box

 proc center {w tag} {
    foreach {x0 y0 x1 y1} [$w bbox $tag] break
    list [expr {($x0+$x1)/2.}] [expr {($y0+$y1)/2.}]
 }

#-- prefix expr operators make the code shorter...

 foreach op {+ -} {proc $op {a b} "expr {\$a $op \$b}"}

#-- Let's go!

 main

if 0 {

LES: Bug: the heads look awful after rotation. Is that a bug in canvas? - RS: No - a thinko from my side. Heads are initially circles, which I thought should be neutral to rotation. But their coordinates are just two points (x0 y0 x1 y1), which after rotation will describe a non-square bounding box. For this I had to introduce rotate'circle which determines the center and the radius, rotates the center, and reconstructs the bounding box.

Bug: if I click the head of a match in the box, only the head is picked instead of the whole match. - RS: fixed - the clone proc should first retrieve the tag of the item set (head and stick), then compute the bbox. Fixed. Thanks for telling!


Category Toys | Arts and crafts of Tcl-Tk programming }