[Richard Suchenwirth] 2002-03-28 - [Canvas] widgets allow convenient display of polygons under program control. Here's a set of routines for interactive drawing and editing of polygons. Drawing is done with left-clicking at node positions, which first produces a line object; the polygon is completed when clicking on (or near) the first node a second time. For editing a polygon, each node is marked with a little square; you can: * move a node by dragging it (with left button down); * move the whole polygon by Shift-left-dragging a node; * insert a new neighboring node by double-left-clicking a node; * rotate counterclockwise by middle-clicking a node; * rotate clockwise by Shift-middle-clicking a node; * delete a node (or unfinished polygon) with right-click; * delete a polygon with Shift-right; * delete all node marks with ''$c delete node'' * retrieve the numeric IDs of the drawn polygons with ''$c find withtag poly'' The only "public" API is the ''polydraw'' command which assigns bindings to the specified canvas; the rest is internal works (but feel free to look ;-). For usage examples, see the little demo at end, which runs when this script is executed. See also [Affine transforms on a canvas] for theory of movement and rotation, and [Car racing in Tcl] for enhanced rotation procs that handle groups of canvas items identified by a tag). } package require Tk proc polydraw {w} { #-- add bindings for drawing/editing polygons to a canvas bind $w {polydraw'mark %W %x %y} bind $w {polydraw'insert %W} bind $w {polydraw'move %W %x %y} bind $w {polydraw'move %W %x %y 1} bind $w {polydraw'rotate %W 0.1} bind $w {polydraw'rotate %W -0.1} bind $w {polydraw'delete %W} bind $w {polydraw'delete %W 1} interp alias {} tags$w {} $w itemcget current -tags } proc polydraw'add {w x y} { #-- start or extend a line, turn it into a polygon if closed global polydraw if {![info exists polydraw(item$w)]} { set coords [list [expr {$x-1}] [expr {$y-1}] $x $y] set polydraw(item$w) [$w create line $coords -fill red -tag poly0] } else { set item $polydraw(item$w) foreach {x0 y0} [$w coords $item] break if {hypot($x-$x0,$y-$y0) < 5} { set coo [lrange [$w coords $item] 2 end] $w delete $item unset polydraw(item$w) set new [$w create poly $coo -fill {} -tag poly -outline black] polydraw'markNodes $w $new } else { $w coords $item [concat [$w coords $item] $x $y] } } } proc polydraw'delete {w {all 0}} { #-- delete a node of, or a whole polygon set tags [tags$w] if {[regexp {of:([^ ]+)} $tags -> poly]} { if {$all} { $w delete $poly of:$poly } else { regexp {at:([^ ]+)} $tags -> pos $w coords $poly [lreplace [$w coords $poly] $pos [incr pos]] polydraw'markNodes $w $poly } } $w delete poly0 ;# possibly clean up unfinished polygon catch {unset ::polydraw(item$w)} } proc polydraw'insert {w} { #-- create a new node halfway to the previous node set tags [tags$w] if {[has $tags node]} { regexp {of:([^ ]+)} $tags -> poly regexp {at:([^ ]+)} $tags -> pos set coords [$w coords $poly] set pos2 [expr {$pos==0? [llength $coords]-2 : $pos-2}] foreach {x0 y0} [lrange $coords $pos end] break foreach {x1 y1} [lrange $coords $pos2 end] break set x [expr {($x0 + $x1) / 2}] set y [expr {($y0 + $y1) / 2}] $w coords $poly [linsert $coords $pos $x $y] polydraw'markNodes $w $poly } } proc polydraw'mark {w x y} { #-- extend a line, or prepare a node for moving set x [$w canvasx $x]; set y [$w canvasy $y] catch {unset ::polydraw(current$w)} if {[has [tags$w] node]} { set ::polydraw(current$w) [$w find withtag current] set ::polydraw(x$w) $x set ::polydraw(y$w) $y } else { polydraw'add $w $x $y } } proc polydraw'markNodes {w item} { #-- decorate a polygon with square marks at its nodes $w delete of:$item set pos 0 foreach {x y} [$w coords $item] { set coo [list [expr $x-2] [expr $y-2] [expr $x+2] [expr $y+2]] $w create rect $coo -fill blue -tag "node of:$item at:$pos" incr pos 2 } } proc polydraw'move {w x y {all 0}} { #-- move a node of, or a whole polygon set x [$w canvasx $x]; set y [$w canvasy $y] if {[info exists ::polydraw(current$w)]} { set dx [expr {$x - $::polydraw(x$w)}] set dy [expr {$y - $::polydraw(y$w)}] set ::polydraw(x$w) $x set ::polydraw(y$w) $y if {!$all} { polydraw'redraw $w $dx $dy $w move $::polydraw(current$w) $dx $dy } elseif [regexp {of:([^ ]+)} [tags$w] -> poly] { $w move $poly $dx $dy $w move of:$poly $dx $dy } } } proc polydraw'redraw {w dx dy} { #-- update a polygon when one node was moved set tags [tags$w] if [regexp {of:([^ ]+)} $tags -> poly] { regexp {at:([^ ]+)} $tags -> from set coords [$w coords $poly] set to [expr {$from + 1}] set x [expr {[lindex $coords $from] + $dx}] set y [expr {[lindex $coords $to] + $dy}] $w coords $poly [lreplace $coords $from $to $x $y] } } proc polydraw'rotate {w angle} { if [regexp {of:([^ ]+)} [tags$w] -> item] { canvas'rotate $w $item $angle polydraw'markNodes $w $item } } #--------------------------------------- more general routines proc canvas'center {w item} { foreach {x0 y0 x1 y1} [$w bbox $item] break list [expr {($x0 + $x1) / 2.}] [expr {($y0 + $y1) / 2.}] } proc canvas'rotate {w item angle} { # This little code took me hours... but the Welch book saved me! foreach {xm ym} [canvas'center $w $item] break set coords {} foreach {x y} [$w coords $item] { set rad [expr {hypot($x-$xm, $y-$ym)}] set th [expr {atan2($y-$ym, $x-$xm)}] lappend coords [expr {$xm + $rad * cos($th - $angle)}] lappend coords [expr {$ym + $rad * sin($th - $angle)}] } $w coords $item $coords } proc has {list element} {expr {[lsearch $list $element]>=0}} if 0 { #------------------------------------------------ demo and test code... if {[file tail [info script]]==[file tail $argv0]} { pack [canvas .c] [canvas .d -bg white] -fill both -expand 1 polydraw .c; polydraw .d ;# test: are they independent? bind . {exec wish $argv0 &; exit} ;# quick restart bind . ? {console show} ;# little (? BIG) debugging helper } } if 1 { #------------------------------------------------ Test2: proc help {w} { #: Show usage info set msg "Help:\n" append msg "Left-click : Create point. To close polygon, click on first point.\n" append msg "Drag blue marks to edit polygon.\n" append msg "Double-click on mark: insert new mark in adjacent line.\n" append msg "Shift / Right-click : Delete mark/line/polygon\n" append msg "Shift / Middle-click on mark: Rotate polygon\n" append msg "F1: Show console\n" append msg "F3: Load Picture \t F4: Delete Picture\n" append msg "F5: Show User-polygon \t F6: Delete User-polygon\n" $w insert end "$msg\n" } proc ReadPic {w fn} { #: Read imagefile, put image on canvas if { $fn == "" } { set fn [tk_getOpenFile -filetypes {{{GIF Files} {*.gif}} {{All Files} {*.*}}}] if { $fn == "" } {return} } set width [winfo reqwidth $w] set height [winfo reqheight $w] set x [expr { $width / 2 }] set y [expr { $height / 2 }] catch {image delete $img1} set img1 [image create photo -file $fn] $w create image $x $y -image $img1 -tag "img" } proc ShowPoly {w} { #: !! Paste user-made polygon here: !! $w create poly \ 117.0 206.0 117.0 60.0 264.0 60.0 264.0 206.0 \ -fill {} -tag user -outline blue } ### Test: pack [canvas .c -bg white] -fill both -expand 1 pack [text .t -height 9] polydraw .c help .t bind . { ReadPic .c "" } bind . { .c delete img } bind . { ShowPoly .c } bind . { .c delete user } bind . {exec wish $argv0 &; exit} ;# quick restart bind . {console show} ;# debugging helper puts "Try:" puts "puts \[.c find withtag poly]" puts "puts \[.c coords \[.c find withtag poly] ]" puts "foreach p \[.c find withtag poly] \{puts \"\$p: \[.c coords \$p ]\\n\"\}" proc int x { expr int($x) } bind .c {wm title . [int [%W canvasx %x]],[int [%W canvasy %y]]} #ReadPic .c "mypic.gif" #ShowPoly .c focus -force . } ---- [HJG] The second testcase shows how this can be used for drawing a polygon from a picture: the image is loaded into the canvas as a background-picture, and the lines are drawn above it. The coordinates can then be queried in the console, and pasted to proc ShowPoly or transfered to another script via cut&paste. ---- [Category Graphics] | [Category Polygon]