There are several solutions to select items in a rectangular area in a canvas Canvas rectangle marking and Canvas item selections. To be able to do a freehand or lasso selection of canvas items by using a polygon of arbitrary shape one cannot rely on "canvas find enclosed" but has to use a polygon interior test.
#
#
# "canvas find enclosed" is limited to a rectangular area
# to be able to do a real freehand selection using a polygon of arbitrary shape
# (the so called lasso selection) use the provided
#
# bind_freehandselection {canv callback}
#
# start drawing the lasso in the canvas by pressing the left mouse button
# if button is released the callback function is execution with a list of enclosed
# canvas item ids
#
# demo code and callback example is provided at end of file
#
# $Id: 14497,v 1.3 2005-07-27 06:00:31 jcw Exp $
#
# ts 20050712
#
package require Tclx ; # only lassign is used
namespace eval ::freehandselection {
namespace export dobind
variable coords ; # coordinates of selection polygon
variable canv ; # canvas to handle
variable lineoptions ; # options for selectionlines
variable callback ; # proc to call if selection is finished
}
proc ::freehandselection::start {x y} {
variable coords
set coords [list $x $y]
}
proc ::freehandselection::extend {x y} {
variable coords
variable canv
variable lineoptions
set n [llength $coords]
eval $canv create line \
[lindex $coords [expr {$n-2}]] [lindex $coords [expr {$n-1}]] \
$x $y $lineoptions
lappend coords $x $y
}
proc ::freehandselection::end {} {
variable coords
variable canv
variable lineoptions
variable callback
# close polygon
#extend [lindex $coords 0] [lindex $coords 1]
$canv delete "freehandselectionline"
if {[llength $coords] >= 6} {
# redraw freehandselectionline (as one item) if required
#set id [eval $canv create line $coords $lineoptions]
set selection [canvas_find_interior $canv $coords]
eval $callback [list $selection]
}
}
#
# do a freehand selection
# and execute callback with list of selected items
#
proc ::freehandselection::dobind {_canv _callback} {
# init namespace variables
variable canv $_canv
variable callback $_callback
variable lineoptions [list \
-fill green \
-tags {freehandselectionline}
]
bind $canv <Button-1> {
::freehandselection::start [%W canvasx %x] [%W canvasy %y]
}
bind $canv <B1-Motion> {
::freehandselection::extend [%W canvasx %x] [%W canvasy %y]
}
bind $canv <B1-ButtonRelease> {
::freehandselection::end
}
}
# http://astronomy.swin.edu.au/~pbourke/geometry/insidepoly/
#
# int pnpoly(int npol, float *xp, float *yp, float x, float y) {
# int i, j, c = 0;
# for (i = 0, j = npol-1; i < npol; j = i++) {
# if ((((yp[i] <= y) && (y < yp[j])) ||
# ((yp[j] <= y) && (y < yp[i]))) &&
# (x < (xp[j] - xp[i]) * (y - yp[i]) / (yp[j] - yp[i]) + xp[i]))
# c = !c;
# }
# return c;
# }
proc ::freehandselection::is_interior {x y polygon} {
set inside 0
set n [llength $polygon]
set jxp [lindex $polygon [expr {$n-2}]] ; # take endpoint
set jyp [lindex $polygon [expr {$n-1}]]
foreach {ixp iyp} $polygon {
if { (($iyp <= $y) && ($y < $jyp)) || (($jyp <= $y) && ($y < $iyp)) } {
set xx [expr {($jxp - $ixp) * ($y - $iyp) / ($jyp - $iyp) + $ixp}]
if { $x < $xx } {
set inside [expr {1-$inside}] ; # inside = not inside
}
}
set jxp $ixp
set jyp $iyp
}
return $inside
}
#
# determine the maximum extension (bbox) of the polygon
#
proc ::freehandselection::get_polygon_extension {polygon} {
set xp_min [lindex $polygon 0]
set yp_min [lindex $polygon 1]
set xp_max $xp_min
set yp_max $yp_min
foreach {xp yp} $polygon {
if {$xp > $xp_max} { set xp_max $xp }
if {$xp < $xp_min} { set xp_min $xp }
if {$yp > $yp_max} { set yp_max $yp }
if {$yp < $yp_min} { set yp_min $yp }
}
return [list $xp_min $yp_min $xp_max $yp_max]
}
#
# returns list of coordinates or
# enclosing rectangle for items positioned only by x and y
#
# circle is handled counterintuitive because whole bbox has to be enclosed
# and not only the visible circle
#
#
proc ::freehandselection::get_item_coords_or_rect {canv id} {
switch [$canv type $id] {
text -
image -
window {
lassign [$canv bbox $id] x0 y0 x1 y1
set coords [list $x0 $y0 $x0 $y1 $x1 $y1 $x1 $y0]
}
default {
set coords [$canv coords $id]
}
}
return $coords
}
#
# returns ids for canvas items enclosed by polygon
#
proc ::freehandselection::canvas_find_interior {canv polygon} {
set selected [list]
# preselect items by using fast find enclosed
lassign [get_polygon_extension $polygon] xp_min yp_min xp_max yp_max
set ids [$canv find enclosed $xp_min $yp_min $xp_max $yp_max]
# test item coords if all are inside the polygon
foreach id $ids {
set inside 1
foreach {x y} [get_item_coords_or_rect $canv $id] {
if {![is_interior $x $y $polygon]} {
set inside 0
break
}
}
if {$inside} {
lappend selected $id
}
}
return $selected
}
#
# main entry
#
proc bind_freehandselection {canv callback} {
::freehandselection::dobind $canv $callback
}
if 0 { Now some test code, to demonstrate the selection behavior }
#########################################################################
#
# test code to demonstrate lasso/freehand selection
#
#
proc handle_selected_items {canv ids} {
puts "selected ids: $ids"
$canv addtag fhsel withtag $ids
foreach id $ids {
circulate_item_color $canv $id
}
}
#
proc circulate_item_color {canv id {colors {red black}}} {
switch [$canv type $id] {
oval -
circle -
rectangle {
set what "-outline"
}
default {
set what "-fill"
}
}
# get current color and circulate to next one
set oldcolor [$canv itemcget $id $what]
set i [lsearch $colors $oldcolor]
incr i
set newcolor [lindex [concat $colors $colors] $i]
$canv itemconfigure $id $what $newcolor
}
proc test {} {
set canv .c
pack [canvas $canv] -expand 1 -fill both
$canv create oval 10 10 10 10
$canv create rectangle 50 50 90 120
$canv create line 25 25 5 5
$canv create rectangle 20 20 60 60 -tags Rectangle
$canv create text 150 250 -text {This is some text} -tags Text
$canv create oval 50 50 80 80 -tags {"Little Circle"}
$canv create oval 50 50 120 120 -tags {"Medium Circle"}
$canv create oval 50 50 200 200 -tags {"Big Circle"}
bind_freehandselection $canv [list handle_selected_items $canv]
# [list $canv addtag fhsel withtag]
}
testwilldye I tried out this code, and it works pretty well, but I had trouble getting used to the bounding region behavior. It seems like one can select a rectangle just by picking the upper left and lower right points. For circles, all I had to do was pick two (invisible) bounding box points, again at the upper left and lower right corners. I think I saw that behavior in the above code, but for what it's worth here's some quick test code that's derived from the original code above:
#!/usr/bin/env wish
destroy .c; pack [canvas .c -width 350 -height 350 -bg "#ffffff"]
.c creat oval 50 40 52 45
.c creat rect 140 90 240 220
.c creat line 165 125 265 25
.c creat rect 70 30 130 60
.c creat oval 90 130 160 140
.c creat oval 90 10 170 80
.c creat oval 30 180 100 250
.c creat text 150 250 -text "Here is some text"
bind .c <B1-ButtonRelease> {.c delete lassoLine}
bind .c <Button-1> {set ::lasso "[%W canvasx %x] [%W canvasy %y]"}
bind .c <B1-Motion> {
lappend ::lasso [%W canvasx %x] [%W canvasy %y]
.c delete lassoLine
foreach item [.c find all] {
set newColor red
set region [.c coords $item]
if {[regexp "(text)|(image)|(window)" [.c type $item]]} {
foreach {x0 y0 x1 y1} [.c bbox $item] {}
set region [list $x0 $y0 $x0 $y1 $x1 $y1 $x1 $y0]
}
foreach {regionX regionY} $region {
set inside 0
set priorX [lindex $::lasso end-1]
set priorY [lindex $::lasso end]
foreach {lassoX lassoY} $::lasso {
if {( ( ($lassoY <= $regionY) && ($regionY < $priorY) ) ||
( ($priorY <= $regionY) && ($regionY < $lassoY) ) ) &&
( ( ($priorX - $lassoX) * ($regionY - $lassoY) /
($priorY - $lassoY) + $lassoX ) >= $regionX ) } {
set inside [expr {! $inside}]
}
set priorX $lassoX
set priorY $lassoY
}
if {! $inside} {
set newColor black
break
}
}
if {[regexp "(oval)|(circle)|(rectangle)" [.c type $item]]
} then {.c itemconf $item "-outline" $newColor
} else {.c itemconf $item "-fill" $newColor}
}
lappend ::lasso [lindex $::lasso 0] [lindex $::lasso 1]
lappend ::lasso [lindex $::lasso end-1] [lindex $::lasso end]
.c create line $::lasso -fill green -tag lassoLine
set ::lasso [lrange $::lasso 0 end-4]
}