proc main {} {
set ::tcl_precision 17 ;#-- to prevent rotation artefacts
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, returning the common ID of its items proc match {w x y y1 color} {
set id [$w create poly \
[+ $x 1] [+ $y 1] [+ $x 5] [+ $y 1] \
[+ $x 5] $y1 [+ $x 1] $y1 -fill bisque -outline black]
$w itemconfig $id -tag m$id
set head [$w create oval $x $y [+ $x 6] [+ $y 6] -fill $color -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'set $w]] break
set id [match $w $x0 $y0 $y1 $color]
$w itemconfig $id -tags [list mv$id mv]
}#-- retrieve the item set tag from the current item proc current'set w {
lindex [$w gettags [$w find withtag current]] 0
}#-- 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} {
$w move [current'set $w] [- $x $::X] [- $y $::Y]
set ::X $x; set ::Y $y
}#-- rotate the current item set proc rotate {w angle} {
set tag [current'set $w]
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 { #-- good for poly and line items
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
}
}
}#-- 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.}]
}#-- 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]
}#-- prefix expr operators make the code shorter... foreach op {+ -} {proc $op {a b} "expr {\$a $op \$b}"}#-- Let's go!mainif 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 (if the rotation center is not the circle's center) 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. It uses coords instead of bbox because the latter delivers only integer coordinates.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. Thanks for telling!
Category Toys | Arts and crafts of Tcl-Tk programming }
