pathplan

Graphviz - Graph Drawing Programs from AT&T Research and Lucent Bell Labs See doc/build.html for

#!/bin/sh
# next line is a comment in tcl \
exec wish "$0" ${1+"$@"}

package require Tkspline
package require Tclpathplan

########################################################################
# shape - a shape drawing tool for testing the spring layout engine
#
# John Ellson - [e-mail] - September 12, 1996

# requires dash patch

# Radio buttons select the drawing mode.
#	"draw"		- draw a closed and filled polygon
#	"stretch"   - move a vertex of a polygon, also
#				  insert additional vertices with subsequent button 1 clicks
#	"collapse"  - delete a vertex of a polygon (except last 2)
#	"move"		- move a complete polygon without altering 
#				  its shape, or move the whole canvas.
#	"rotate"	- rotate a polygon about its center
#	"scale"		- scale a polygon
#	"clone"		- copy an existing shape
#	"delete"	- remove an entire polygon object
#	"path"		- draw a line between two polygons and the 
#				  system will respond with the shortest path
#				  around all the other polygons.
#	"bezier path" - draw a line between two polygons and the 
#				  system will respond with the spline that follows
#				  the shortest path around all the other polygons.
#	"id"		- identify a polygon.  mostly for debugging.

# "draw," "stretch," "move," "path", "bezier path",  and "clone" use 
# button 1 for first though penultimate points, then button 2 to 
# complete the operation.

# "rotate" and "scale" use the button 1 to grab a polygon and
# button 2 to complete the operation.

# "collapse" and "delete" just use button 1 

# "stretch, " "move, " "collapse," and "delete" operations all act on
# a highlighted object

# "grid" constrains the locations of input points to lie on a grid of
# the specified spacing (in pixels).

# Future...
#
# some other possible operations:
#   regularize (arrange points on circle)
#   transformations: skew, distort, scale
#	   label text (inside or relative)
#   fill & outline color
#   fill & outline stipple
#   fill tile image
#   outline dash (mark, space offset)
#   outline width
#   number of peripheries
#
#   group/ungroup
#
#   raise/lower (not required if no overlap)
#
#   constraints:  no overlap
#				 no twist
#
#   resources:	shape library
#				 stipple patterns
#				 tile images
#
########################################################################

set splinecolor orange

set showmouse off

proc nextpoint {vc c wx wy} {
	global id mode oldx oldy gain0 angle0 index grid

	set x [$c canvasx $wx]
	set y [$c canvasy $wy]
	set gx [expr $grid * int(($x / $grid) + 0.5)]
	set gy [expr $grid * int(($y / $grid) + 0.5)]
	switch $mode {
		draw {
			if [info exists id] {
				$c insert $id 0 [list $gx $gy]
			} {
				set id [$c create polygon $gx $gy $gx $gy \
					-fill red -outline #ffc000]
			}
		}
		stretch {
			if [info exists id] {
				$c insert $id $index [list $gx $gy]
			} {
				set id [$c find withtag current]
				if {$id == {}} {
					unset id
				} {
					set index [$c index $id @$x,$y]
					$c dchars $id $index
					$c insert $id $index [list $gx $gy]
				}
			}
		}
		collapse {
			set id [$c find withtag current]
			if {$id != {}} {
				set index [$c index $id @$x,$y]
				if {[llength [$c coords $id]] > 4} {$c dchars $id $index}
				$vc coords [lindex [$c gettags $id] 0] [$c coords $id]
			}
			unset id
		}
		clone {
			if [info exists id] {
				set tag [$vc insert [$c coords $id]]
				$c addtag $tag withtag $id
			}
			set t [$c find withtag current]
			if {$t != {}} {
				set id [$c create [$c type $t] [$c coords $t]]
				foreach config [$c itemconfigure $t] {
					foreach {config . . . val} $config {break}
					if {$config != "-tags"} {
						$c itemconfigure $id $config $val
					}
				}
				set oldx $gx
				set oldy $gy
			}
		}
		move {
			set id [$c find withtag current]
			if {$id == {}} {
				$c scan mark $wx $wy
			} {
				set oldx $gx
				set oldy $gy
			}
		}
		scale {
			set id [$c find withtag current]
			if {$id == {}} {
				unset id
			} {
				foreach {oldx oldy} \
					[$vc center [lindex [$c gettags $id] 0]] {break}
				set dx [expr $oldx-$x]
				set dy [expr $oldy-$y]
				set gain0 [expr sqrt($dx*$dx+$dy*$dy)]
			}
		}
		rotate {
			set id [$c find withtag current]
			if {$id == {}} {
				unset id
			} {
				foreach {oldx oldy} [$vc center [lindex [$c gettags $id] 0]] {
					break
				}
				set angle0 [expr atan2($x-$oldx, $oldy-$y)]
			}
		}
		path {
			if [info exists id] {
				set path [$c coords $id]
				if [catch {$vc path $path} path] {
					puts $path
				} {
					$c coords $id $path
					$c itemconfigure $id -fill red
					set id [$c create line $x $y $x $y \
						-fill red -state disabled]
				}
			} {
				set id [$c create line $gx $gy $gx $gy \
					-fill red -state disabled]
			}
		}
		bpath {
			if [info exists id] {
				set path [$c coords $id]
				if [catch {$vc bpath $path} path] {
					puts $path
				} {
					$c coords $id $path
					$c itemconfigure $id -fill orange
					set id [$c create line $x $y $x $y \
						-smooth spline -fill orange -state disabled]
				}
			} {
				set id [$c create line $gx $gy $gx $gy \
					-smooth spline -fill orange -state disabled]
			}
		}
		delete {
		   $vc remove [lindex [$c gettags current] 0]
		   $c delete current
		}
		triangulate {
			global mode
			if {[$vc bind triangle] == {}} {
				$vc bind triangle {
					if {$mode == "triangulate"} {
						$c create polygon %t -tag triangles \
							-fill {} -outline white -width 2 
					} {
						$c create polygon %t -tag triangles \
							-fill {} -outline white -width 2  -state hidden
					}
				}
			}
			if {$mode == "triangulate"} {
				$c itemconfigure triangles -state normal
			} {
				$c itemconfigure triangles -state hidden
			} 
			set t [$vc find $x $y]
			if {$t != {}} {
				$vc triangulate $t
			}
		}
		id {
		   set t [$vc find $x $y]
		   if {$t == {}} {
			   puts "at: $x $y ....nothing"
		   } {
			   puts "at: $x $y\nid: $t\ncoords: [$vc coords $t]"
		   }
		}
	}
}

proc lastpoint {vc c args} {
	global id mode
	if [info exists id] {
		switch $mode {
			draw {
				$c itemconfigure $id -fill darkgreen \
					-outline yellow -activeoutline #ffc000
				set tag [$vc insert [$c coords $id]]
				$c addtag $tag withtag $id
			}
			clone {
				set tag [$vc insert [$c coords $id]]
				$c addtag $tag withtag $id
			}
			move - stretch - rotate - scale {
				set t [lindex [$c gettags $id] 0]
				if {$t != {} && $t != "current"} {
					$vc coords $t [$c coords $id]
				}
			}
			path {
				set path [$c coords $id]
				if [catch {$vc path $path} path] {
					puts $path
					$c delete $id
				} {
					$c coords $id $path
					$c itemconfigure $id -fill 
				}
			}
			bpath {
				set path [$c coords $id]
				if [catch {$vc bpath $path} path] {
					puts $path
					$c delete $id
				} {
					$c coords $id $path
					$c itemconfigure $id -fill red
				}
			}
		}
		$c configure -scrollregion [$c bbox all]
		unset id
	}
}

proc motion {vc c wx wy} {
	global id mode oldx oldy gain0 angle0 index grid showmouse
	set x [$c canvasx $wx]
	set y [$c canvasy $wy]
		if {$showmouse == "on"} {
			puts -nonewline stderr "\r$x,$y [list [$vc find $x $y]]	 "
		}
	if [info exists id] {
		switch $mode {
			draw {
				set gx [expr $grid * int(($x / $grid) + 0.5)]
				set gy [expr $grid * int(($y / $grid) + 0.5)]
				$c dchars $id 0
				$c insert $id 0 [list $gx $gy]
			}
			path {
				$c dchars $id 0
				$c insert $id 0 [list $x $y]
			}
			bpath {
				$c dchars $id 0
				$c insert $id 0 [list $x $y]