Version 0 of Playing with matches

Updated 2005-05-07 22:37:37 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:

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) 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 <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]
    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 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!


if 0 {

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