Canvas lasso selection

TS 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.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]
     
 }
 
 test

willdye 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}