text.mod/graphviz.mod/graphviz/tclpkg/tclpathplan/demo/pathplan.tcl

#!/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 - [email protected] - 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]
			}
			move - clone {
				if {$id == {}} {
					$c scan dragto $wx $wy 1
				} {
					set gx [expr $grid * int(($x / $grid) + 0.5)]
					set gy [expr $grid * int(($y / $grid) + 0.5)]
					$c move $id [expr $gx - $oldx] [expr $gy - $oldy]
					set oldx $gx
					set oldy $gy
				}
			}
			stretch {
				set gx [expr $grid * int(($x / $grid) + 0.5)]
				set gy [expr $grid * int(($y / $grid) + 0.5)]
				$c dchars $id $index
				$c insert $id $index [list $gx $gy]
			}
			scale {
				set t [lindex [$c gettags $id] 0]
				set dx [expr $x-$oldx]
				set dy [expr $y-$oldy]
				set gain [expr sqrt($dx*$dx+$dy*$dy)/20]
				$c coords $id [$vc scale $t $gain]
			}
			rotate {
				set t [lindex [$c gettags $id] 0]
				set alpha [expr atan2($x-$oldx,$oldy-$y) - $angle0]
				$c coords $id [$vc rotate $t $alpha]
			}
		}
	}
}

proc clearpaths {vc c} {
	catch { $c delete triangles }
	foreach i [$c find all] {
		set t [$c type $i]
		if {$t == "line"} {$c delete $i}
	}
}

proc clearall {vc c} {
	catch { $c delete triangles }
	foreach i [$c find all] {
		if {[$c type $i] == "polygon"} {$vc remove [lindex [$c gettags $i] 0]}
		$c delete $i
	}
}

proc loadpaths {vc c file} {
	if [catch {open $file r} f] {
		error "unable to open file for read: $file"
	}
	clearpaths $vc $c
	while {![eof $f]} {
		set path [gets $f]
		if {$path == {}} {continue}
		if [catch {$vc bpath $path} path] {
			puts $path
		} {
			$c create line $path \
				-smooth spline -fill #ff00c0 -state disabled
		}
	}
	close $f
	$c configure -scrollregion [$c bbox all]
}

proc loadvconfig {vc c file} {
	if [catch {open $file r} f] {
		error "unable to open file for read: $file"
	}
	clearall $vc $c
	while {![eof $f]} {
		set coords [string trim [gets $f]]
		if {$coords == {}} {continue}
		set tag [$vc insert $coords]
		$c create polygon $coords \
			-tag $tag \
			-fill darkgreen \
			-outline yellow \
			-activeoutline #ffc000
	}
	close $f
	$c configure -scrollregion [$c bbox all]
}

proc savepaths {vc c file} {
	if [catch {open $file w} f] {
		error "unable to open file for write: $file"
	}
	foreach i [$c find all] {
		set t [$c type $i]
		if {$t == "line"} {
			set path [$c coords $i]
			set l [llength $path]
			set x1 [lindex $path 0]
			set y1 [lindex $path 1]
			set x2 [lindex $path [incr l -2]]
			set y2 [lindex $path [incr l]]
			puts $f "$x1 $y1 $x2 $y2"
		}
	}
	close $f
}

proc savevconfig {vc c file} {
	if [catch {open $file w} f] {
		error "unable to open file for write: $file"
	}
	foreach id [$vc list] {
		puts $f [$vc coords $id]
	}
	close $f
}

proc nextfile {} {
	global filename
	set filename [file join [file dirname $filename] [file tail $filename]]
	set files [glob [file join [file dirname $filename] *[file extension $filename]]]
	set filename [lindex $files [expr ([lsearch $files $filename] + 1) % [llength $files]]]
}

set vc [vgpane]
set mode draw
set filename "pathplan.tcl.data/unknown.dat"
frame .fl
set a [frame .fl.a]
set b [frame .fl.b]
set c [canvas $a.c \
	-relief sunken \
	-borderwidth 2 \
	-bg lightblue \
	-xscrollcommand "$b.h set" \
	-yscrollcommand "$a.v set"]
scrollbar $b.h -command "$c xview" -orient horiz
scrollbar $a.v -command "$c yview"
frame $b.pad \
	-width [expr [$a.v cget -width] + \
		[$a.v cget -bd]*2 + [$a.v cget -highlightthickness]*2 ] \
	-height [expr [$b.h cget -width] + \
		[$b.h cget -bd]*2 + [.fl.b.h cget -highlightthickness]*2 ]
frame .fr
frame .fr.bpath
pack [radiobutton .fr.bpath.bpath -text "bezier path" -value bpath \
		-highlightthickness 0 -anchor w -variable mode] \
		-side left -anchor w -fill x
pack [scale .fr.grid -orient horizontal -label grid -variable grid \
		-highlightthickness 0 -from 1 -to 100] \
	[radiobutton .fr.draw -text draw -value draw \
		-highlightthickness 0 -anchor w -variable mode] \
	[radiobutton .fr.stretch -text stretch -value stretch \
		-highlightthickness 0 -anchor w -variable mode] \
	[radiobutton .fr.collapse -text collapse -value collapse \
		-highlightthickness 0 -anchor w -variable mode] \
	[radiobutton .fr.clone -text clone -value clone \
		-highlightthickness 0 -anchor w -variable mode] \
	[radiobutton .fr.move -text move -value move \
		-highlightthickness 0 -anchor w -variable mode] \
	[radiobutton .fr.rotate -text rotate -value rotate \
		-highlightthickness 0 -anchor w -variable mode] \
	[radiobutton .fr.scale -text scale -value scale \
		-highlightthickness 0 -anchor w -variable mode] \
	[radiobutton .fr.delete -text delete -value delete \
		-highlightthickness 0 -anchor w -variable mode] \
	[radiobutton .fr.path -text path -value path \
		-highlightthickness 0 -anchor w -variable mode] \
	.fr.bpath \
	[radiobutton .fr.id -text id -value id \
		-highlightthickness 0 -anchor w -variable mode] \
	[radiobutton .fr.triangulate -text triangulate -value triangulate \
		-highlightthickness 0 -anchor w -variable mode] \
		-anchor w -fill x
frame .fr.load
pack [button .fr.load.load -text load \
		 -highlightthickness 0 -command "loadvconfig $vc $c \$filename"] \
	[button .fr.load.paths -text loadpaths \
		 -highlightthickness 0 -command "loadpaths $vc $c \$filename"] \
		 -side left -fill x -expand true
frame .fr.save
pack [button .fr.save.save -text save \
		 -highlightthickness 0 -command "savevconfig $vc $c \$filename"] \
	[button .fr.save.paths -text savepaths \
		 -highlightthickness 0 -command "savepaths $vc $c \$filename"] \
		 -side left -fill x -expand true
frame .fr.clear
pack [button .fr.clear.all -text clear -command "clearall $vc $c" \
		-highlightthickness 0] \
	[button .fr.clear.paths -text clearpaths -command "clearpaths $vc $c" \
		-highlightthickness 0] \
		 -side left -fill x -expand true
frame .fr.file
pack [entry .fr.file.name -textvar filename -highlightthickness 0] \
		 -side left -fill x -expand true
pack [button .fr.file.next -text next \
		 -highlightthickness 0 -command "nextfile"] \
		 -side left
frame .fr.quitdebug
pack [button .fr.quitdebug.debug -text debug \
		 -highlightthickness 0 -command "$vc debug"] \
	[button .fr.quitdebug.quit -text quit \
		 -highlightthickness 0 -command "exit"] \
	-side left -fill x -expand true
pack .fr.quitdebug .fr.clear .fr.save .fr.load .fr.file \
	[label .fr.flabel -anchor w -text "file"] \
	[entry .fr.coordinates -textvar coordinates -highlightthickness 0] \
	[label .fr.clabel -anchor w -text "coordinates"] \
		-side bottom -fill x -expand true
pack $a.v -side right -fill y
pack $c -side left -fill both -expand true
pack $b.h -side left -fill x -expand true
pack $b.pad -side right
pack $b -side bottom -fill x
pack $a -side top -fill both -expand true
pack .fl -side left -fill both -expand true
pack .fr -side left -fill y

bind $c <1> "nextpoint $vc $c %x %y"
bind $c <2> "lastpoint $vc $c"
bind $c <Motion> "motion $vc $c %x %y"

trace variable mode w "lastpoint $vc $c"

bind .fr.file.name <Return> {
	.fr.loadsave.load flash
	loadvconfig $vc $c $filename
}

bind .fr.coordinates <Return> {
	if {$coordinates == {}} {continue}
	set coords [split $coordinates]
	set coordinates {}
	switch $mode {
		draw {
			if [catch {$vc insert $coords} tag] {
				puts $tag
			} {
				$c create polygon $coords \
					-fill darkgreen \
					-outline yellow \
					-activeoutline #ffc000 \
					-tag $tag
			}
		}
		path {
			if [catch {$vc path $coords} coords] {
				puts $coords
			} {
				$c create line $coords -fill #ff00c0 -state disabled
			}
		}
		bpath {
			if [catch {$vc bpath $coords} coords] {
				puts $coords
			} {
				$c create line $coords \
					-smooth spline -fill orange -state disabled
			}
		}
	}
}

proc balloon_help {w msg} {
  bind $w <Enter> "after 1000   \"balloon_help_aux %W [list $msg]\""
  bind $w <Leave> "after cancel \"balloon_help_aux %W [list $msg]\"
	  catch {destroy %W.balloon_help}"
}
 
proc balloon_help_aux {w msg} {
  set t $w.balloon_help
  catch {destroy $t}
  toplevel $t
  wm overrideredirect $t 1
  pack [label $t.l -text $msg -relief groove -bd 1 -bg yellow] -fill both
  wm geometry $t +[expr [winfo rootx $w]+([winfo width $w]/2)]+[expr \
	  [winfo rooty $w]+([winfo height $w]/2)]
}

balloon_help .fr.grid "set grid size for draw operations"
balloon_help .fr.draw "draw a region. B1 foreach vertex except B2 for last"
balloon_help .fr.stretch "B1 to stretch a vertex, next B1 inserts new vertex. B2 to end"
balloon_help .fr.collapse "B1 collapses a vertex"
balloon_help .fr.clone "each B1 creates a new clone of a region, B2 to end"
balloon_help .fr.move "B1 to move, B2 to end"
balloon_help .fr.rotate "B1 to rotate, B2 to end"
balloon_help .fr.scale "B1 to scale, B2 to end"
balloon_help .fr.delete "B1 to delete a region"
balloon_help .fr.path "B1 starts a euclidean shortest path, B2 to end"
balloon_help .fr.bpath.bpath "B1 starts a bezier spline path, B2 to end"
balloon_help .fr.triangulate "B1 to display triangulation of a polygon"
balloon_help .fr.id "print the identifier of a region"
balloon_help .fr.coordinates "text entry of coordinates, alternative to button operations"
balloon_help .fr.file.name "current file name, or enter new name"
balloon_help .fr.file.next "next file with same directory and extension"
balloon_help .fr.save.paths "save paths to file"
balloon_help .fr.load.paths "load paths from file"
balloon_help .fr.save.save "save regions to file"
balloon_help .fr.load.load "load regions from file"
balloon_help .fr.clear.all "clear canvas of all regions and paths"
balloon_help .fr.clear.paths "clear canvas of all paths"
balloon_help .fr.quitdebug.quit "quit this application"
balloon_help .fr.quitdebug.debug "dump the vconfig"