#
#
# "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.9 2006-02-08 07:00:24 jcw Exp $
#
# ts 20050902
#
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
variable polygon_closer_id ; # id of additional canvasline closing the polygon
}
proc ::freehandselection::start {x y} {
variable coords
set coords [list $x $y]
}
proc ::freehandselection::extend {x y} {
variable coords
variable canv
variable lineoptions
variable polygon_closer_id
$canv delete $polygon_closer_id
set n [llength $coords]
eval $canv create line \
[lindex $coords [expr {$n-2}]] [lindex $coords [expr {$n-1}]] \
$x $y $lineoptions
# additional line with closes the drawn polygon
set polygon_closer_id [eval $canv create line \
$x $y [lindex $coords 0] [lindex $coords 1] $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}
]
variable polygon_closer_id 0 ; # not yet available
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_points {canv id} {
set itype [$canv type $id]
if {$itype == "line" || $itype == "polygon"} {
set coords [$canv coords $id]
} else {
set coords [$canv coords $id]
if {[llength $coords] == 2} {
# 2 coords are for text, image, window, bitmap
# use bbox instead
set coords [$canv bbox $id]
}
# 4 coords are for oval, arc, rectangle
lassign $coords x0 y0 x1 y1
# also add bottom left and upper right corner
lappend coords $x0 $y1 $x1 $y0
# also add the center point of the bbox
lappend coords [expr {0.5*($x1+$x0)}] [expr {0.5*($y1+$y0)}]
}
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 if all item check points are inside the polygon
foreach id $ids {
set inside 1
foreach {x y} [get_item_points $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]
}The derived code has a few changes which might be worth porting back to the original. The dervied code highlights items as the lasso is extended (though this might cause problems on very large canvases), it visually shows the connection between the first lasso point and the last point, it doesn't require TclX for lassign, and uses 'end-1' to simplify the usage of lindex. By and large, however, I like the original code better as a basis for a plug-in lasso tool -- if only because the original code utilizes namespaces.TS The inital program is updated:
- all four bbox corners and the center (get_item_points) are now checked against the polygon
- an additional line to close the polygon is added ("polygon_closer")
willdye Here's a variant of the above code, designed to focus entirely on the lasso behavior rather than the selection behavior of text vs. ovals vs. whatever. It's rather sluggish, but it's pretty easy to speed up if necessary, just by limiting the search area to what's been changed, rather than starting from scratch on every motion event.
#!/usr/bin/env wish
# Quick-and-dirty lasso testbed. Note it's way too inefficient,
# but all the user-side behavior should be as intended.
package require Tk
set max 600
destroy .c
pack [canvas .c -width $max -height $max -bg black]
for {set r 0} {$r < $max} {incr r 20} {
for {set c 0} {$c < $max} {incr c 20} {
.c create oval $r $c [expr $r+3] [expr $c+3] -outline gray -width 1}}
bind .c <Button-1> {set lassoPoints "[%W canvasx %x] [%W canvasy %y]"}
bind .c <B1-Motion> {
# Start everything completely from scratch. This is why it's so slow.
.c delete lassoLine
.c itemconfigure all -outline gray -width 1;
lappend lassoPoints [%W canvasx %x] [%W canvasy %y]
set priorX [lindex $lassoPoints end-1]
set priorY [lindex $lassoPoints end]
foreach item [.c find all] {
set newColor yellow
set newWidth 2
set region [.c coords $item]
foreach {regionX regionY} $region {
set inside 0
foreach {lassoX lassoY} $lassoPoints {
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 gray; set newWidth 1; break}}
.c itemconfigure $item -outline $newColor -width $newWidth}
lappend lassoPoints [lindex $lassoPoints 0] [lindex $lassoPoints 1] \
[lindex $lassoPoints 0] [lindex $lassoPoints 1]
.c create line $lassoPoints -fill green -tag lassoLine
set lassoPoints [lrange $lassoPoints 0 end-4]}
bind .c <B1-ButtonRelease> {.c delete lassoLine}