Canvas rectangle marking

Summary

Richard Suchenwirth 2002-02-26: I needed to mark an axis-parallel rectangle on a [canvas] by drawing it with the mouse pointer. This is a simplified task compared to Canvas item selections, but the solution could also be done simpler, with a single [bind] proc (which dispatches according to event type), and no global variable required.

Description

In the binding for the <ButtonRelease-1> registration, you specify a "callback": a command name or prefix, to which will be appended a list consisting of the coordinates of the marked rectangle {x0 y0 x1 y1}, and which will then be executed in global scope, as is necessary for bindings:

proc canvas'rect {w x y type {cmd ""}} {
    set x [$w canvasx $x]
    set y [$w canvasy $y]
    switch -- $type {
        press {
            $w delete rect
            $w create rect $x $y $x $y -tag rect
        }
        motion {
            set item [$w find withtag rect]
            foreach {x0 y0 x1 y1} [$w coords $item] break
            $w coords $item $x0 $y0 $x $y
        }
        release {
            uplevel \#0 [lappend cmd [$w coords [$w find withtag rect]]]
        }
        default {error "bad type $type: use press, motion, or release"}
    }
}
# Usage example and demo:

if {[file tail [info script]] == [file tail $argv0]} {
    pack [canvas .c]
    bind .c <1>               {canvas'rect %W %x %y press}
    bind .c <B1-Motion>       {canvas'rect %W %x %y motion}
    bind .c <ButtonRelease-1> {canvas'rect %W %x %y release "diag %W"}

    proc diag {w coords} {
        foreach {x0 y0 x1 y1} $coords break
        $w create line $x0 $y0 $x1 $y1 -fill green -width 3
        $w create line $x1 $y0 $x0 $y1 -fill red -width 3
    }
}

MGS: Here's a slightly modified version that allows you to draw rectangles in any direction:

proc canvas'rect {w x y type {cmd ""}} {

    upvar #0 $w _

    set x [$w canvasx $x]
    set y [$w canvasy $y]

    switch -- $type {
        motion {
            if { $x < $_(x) } {
                set x1 $x ; set x2 $_(x)
            } else {
                set x1 $_(x) ; set x2 $x
            }
            if { $y < $_(y) } {
                set y1 $y ; set y2 $_(y)
            } else {
                set y1 $_(y) ; set y2 $y
            }
            $w coords rect $x1 $y1 $x2 $y2
        }
        press {
            set _(x) $x
            set _(y) $y
            $w delete rect
            $w create rect $x $y $x $y -tag rect
        }
        release {
            unset _(x)
            unset _(y)
            uplevel #0 [concat $cmd [$w coords rect]]
            $w delete rect
        }
        default {
            error "bad type \"$type\": must be motion, press, or release"
        }
    }

}

# Usage example and demo:

 if { [info exists argv0] && [string equal [info script] $argv0] } {
        pack [canvas .c]
        bind .c <ButtonPress-1>   {canvas'rect %W %x %y press}
        bind .c <B1-Motion>       {canvas'rect %W %x %y motion}
        bind .c <ButtonRelease-1> {canvas'rect %W %x %y release "diag %W"}

        proc diag {c x1 y1 x2 y2} {
            $c create rect $x1 $y1 $x2 $y2
            $c create line $x1 $y1 $x2 $y2 -fill green -width 3
            $c create line $x2 $y1 $x1 $y2 -fill red   -width 3
        }
 }

sheila: 2004-10-27: I was playing around with this on my PC and on my mac. I added a stipple effect to grey out the portion of the image I had added to the canvas. Here is how I changed the code to do this.

        release {
            # done, remove the saved coords
            unset _(x)
            unset _(y)
            set r [eval $w create rect [$w coords rect]\
                -tag exclude -fill gray25 -stipple gray25]
            $w delete rect
        }

aside: I was curious about why you guys used the separate proc instead of just putting it in the release branch, so I put it in the release branch to see how it would work.

Anyway, this works like I thought it would on my PC, but on my mac the stipple looks solid. Everything seems slower on my mac as well. I was wondering what I did wrong? My mac is running panther, and I have the latest TkAquaBI on it (I updated it last night just to be sure).


gold added pix and some categories.

Ref. links Canvas,Canvas lasso selection

Canvas rectangle marking screenshot png