#!/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]