Version 0 of Canvas lasso selection

Updated 2005-07-20 13:41:52

#

 # 
 # "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.1 2005-07-21 06:00:40 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

 }

test demo code

 #########################################################################
 #
 # 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