#!/usr/bin/wish8.5 # This code is in the public domain. Use, enjoy. pack [canvas .c] # Draw a decoration on a vertex # All of them have the tag "deco" proc dot {x y} { .c create polygon [expr {$x + 3}] $y $x [expr {$y - 3}] \ [expr {$x - 3}] $y $x [expr {$y + 3}] \ -fill orange -outline blue -tags deco } # Find point on segment (p--q) nearest to (xp,yp). # Return (xxp yyp, d) where (xxp, yyp) are the coords of this # nearest point and d is the distance to the segment. proc prox-seg {px py qx qy rx ry} { set ux [expr { $qx - $px }] set uy [expr { $qy - $py }] set vx [expr { $rx - $px }] set vy [expr { $ry - $py }] set u [expr { hypot($ux, $uy) }] set v [expr { hypot($vx, $vy) }] # c is the relative position of this point on the segment # (0 --> p, 1 --> q, i.e. c < 0 or c > 1 means point is # outisde the segment) set c [expr {($ux * $vx + $uy * $vy) / ($u * $u)}] # if we clamp it to [0,1] we'll never lie outside the segment: set c [expr {$c<0 ? 0 : $c>1 ? 1 : $c}] set wx [expr { $ux * $c }] set wy [expr { $uy * $c }] set d [expr { hypot($vx - $wx, $vy - $wy) }] return [list [expr {$px + $wx}] [expr {$py + $wy}] $c $d] } # Find the point on (multi-)line nearest to given x y # Return coords of point, segment number (0..n-1), relative pos # whithin that segment and distance to that segment # Note that this gets inaccurate when the nearest point is near # the beginning or end of the line: we don't mind, because we # just trigger "near" the line proc prox-line {line x y} { set nseg -1 foreach {qx qy} [.c coords $line] { if {[info locals px] != ""} { # else we are first time here # Current segment is p--q set thisseg [prox-seg $px $py $qx $qy $x $y] set dist [lindex $thisseg 3] if { [info locals mindist] == "" || ( $dist < $mindist && [lindex $thisseg 2] >=0 && [lindex $thisseg 2] <=1 ) } { set minseg $thisseg set mindist $dist set minnseg $nseg } } set px $qx set py $qy incr nseg } return [list [lindex $minseg 0] [lindex $minseg 1] $minnseg [lindex $minseg 2] [lindex $minseg 3]] } # return no [0..n] of line's vertex next to x y proc findvertex {line x y} { set n 0 foreach {vx vy} [.c coords $line] { set d [expr {hypot($x - $vx, $y - $vy)}] if {[info locals dmin] == "" || $d < $dmin} { set dmin $d set nmin $n } incr n } return $nmin } # Add a vertex to zigzag nearest to x y proc zig {wx wy} { # NOTE receives window coords -- thanks [MLai]! set x [.c canvasx $wx] set y [.c canvasy $wy] global zigzag set pos [prox-line $zigzag $x $y] .c insert $zigzag [expr {2 * (1 + [lindex $pos 2])}] [list $x $y] dot $x $y drag-start $x $y } # Dragging vertices (ripped off Tk demo). Three procs manage the dragging proc drag-start {wx wy} { # NOTE receives window coords -- thanks [MLai]! set x [.c canvasx $wx] set y [.c canvasy $wy] global lastx lasty puts [.c find withtag deco] # Find out which decoration item(s) to drag set deco {} foreach it [.c find closest $x $y] { puts "$it: [.c gettags $it]" if {[lsearch -all -exact -inline [.c gettags $it] deco] ne ""} {lappend deco $it} } puts $deco bind .c <B1-Motion> [list dragging $deco %x %y] bind .c <ButtonRelease-1> [list drag-end %x %y] set lastx $x set lasty $y } proc dragging {it x y} { global lastx lasty zigzag .c move $it [expr $x - $lastx] [expr $y - $lasty] set v [expr {2 * [findvertex $zigzag $lastx $lasty]}] # insert before v, delete after newly inserted: .c insert $zigzag $v [list $x $y] .c dchars $zigzag [expr {$v + 2}] [expr {$v + 3}] set lastx $x set lasty $y } proc drag-end {x y} { bind .c <ButtonRelease-1> {} bind .c <B1-Motion> {} } # Draw initial line, decorate, set up bindings set zigzag [.c create line 10 10 60 250 300 150 -fill blue] foreach {x y} [.c coords $zigzag] {dot $x $y} .c bind $zigzag <ButtonPress-1> [list zig %x %y] .c bind deco <ButtonPress-1> [list drag-start %x %y]

See also: Drawing and editing polygons[MLai] 2013-10-10Very useful! I adapt your code in my program and then notice sometimes the dot (polygon) is not right on the line. I add the following lines to your routines to make this "offset" problem go away:

set x [.c canvasx $x] set y [.c canvasy $y]Not sure if the offset problem is something specific in my application.tomas 2013-12-25Thanks for the good catch, MLai!I corrected it in the code: both

**[zig]**and

**[drag-start]**receive mouse coordinates, which are relative to the canvas's viewport origin and not to the canvas's origin: when they are not the same (e.g. when the canvas is scrolled, but perhaps on some platforms), bad things happen.