- 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
package require Tk
proc polydraw {w} {
#-- add bindings for drawing/editing polygons to a canvas
bind $w <Button-1> {polydraw'mark %W %x %y}
bind $w <Double-1> {polydraw'insert %W}
bind $w <B1-Motion> {polydraw'move %W %x %y}
bind $w <Shift-B1-Motion> {polydraw'move %W %x %y 1}
bind $w <Button-2> {polydraw'rotate %W 0.1}
bind $w <Shift-2> {polydraw'rotate %W -0.1}
bind $w <Button-3> {polydraw'delete %W}
bind $w <Shift-3> {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 . <Escape> {exec wish $argv0 &; exit} ;# quick restart
bind . ? {console show} ;# little (? BIG) debugging helper
}
}
if 1 {
#------------------------------------------------ Application2 - Outlining:
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
}
#: Main :
pack [canvas .c -width 320 -height 320 -bg white] -fill both -expand 1
pack [text .t -width 50 -height 9]
polydraw .c
help .t
bind . <F3> { ReadPic .c "" }
bind . <F4> { .c delete img }
bind . <F5> { ShowPoly .c }
bind . <F6> { .c delete user }
bind . <Escape> {exec wish $argv0 &; exit} ;# quick restart
bind . <F1> {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 <Motion> {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.
ttkdraw
