doted

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 Tcldot

# doted - dot graph editor - John Ellson ([e-mail])
#
# Usage: doted <file.dot>
#
# doted displays the graph described in the input file and allows
# the user to add/delete nodes/edges, to modify their attributes,
# and to save the result.

global saveFill tk_library modified fileName printCommand g

# as the mouse moves over an object change its shading
proc mouse_anyenter {c} {
	global tk_library saveFill
	set item [string range [lindex [$c gettags current] 0] 1 end]
	set saveFill [list $item [lindex [$c itemconfigure 1$item -fill] 4]]
	$c itemconfigure 1$item -fill black \
		-stipple @$tk_library/demos/images/gray25.bmp
}

# as the mouse moves out of an object restore its shading
proc mouse_anyleave {c} {
	global saveFill
	$c itemconfigure 1[lindex $saveFill 0] \
		-fill [lindex $saveFill 1] -stipple {}
}

# if b1 is pressed over the brackground then start a node,
# if b1 is pressed over a node then start an edge
proc mouse_b1_press {c x y} {
	global startObj graphtype
	set x [$c canvasx $x]
	set y [$c canvasy $y]
	foreach item [$c find overlapping $x $y $x $y] {
		foreach tag [$c gettags $item] {
			if {[string first "node" $tag] == 1} {
				set item [string range $tag 1 end]
				if {[string equal $graphtype digraph]} {
					set startObj [$c create line $x $y $x $y \
						 -tag $item -fill red -arrow last]
				} {
					set startObj [$c create line $x $y $x $y \
						 -tag $item -fill red]
				}
				return
			}
		}
	}
	set startObj [$c create oval [expr $x - 10] [expr $y - 10] \
		[expr $x + 10] [expr $y + 10] -fill red -outline black]
}

# if node started by b1_press then move it,
# else extend edge
proc mouse_b1_motion {c x y} {
	global startObj
	set pos [$c coords $startObj]
	if {[$c type $startObj] == "line"} {
		$c coords $startObj [lindex $pos 0] [lindex $pos 1] \
			[$c canvasx $x] [$c canvasy $y]
	} {
		$c move $startObj [expr [$c canvasx $x] - [lindex $pos 0] - 10] \
			[expr [$c canvasy $y] - [lindex $pos 1] - 10]
	}
}

# complete node or edge construction.
proc mouse_b1_release {c x y} {
	global startObj modified g
	set x [$c canvasx $x]
	set y [$c canvasy $y]
	set t [$c type $startObj]
	if {$t == "line"} {
		set tail [lindex [$c gettags $startObj] 0]
		foreach item [$c find overlapping $x $y $x $y] {
			foreach tag [$c gettags $item] {
				set head [string range $tag 1 end]
				if {[string first "node" $head] == 0} {
					set e [$tail addedge $head]
					$c dtag $startObj $tail
					$c addtag 1$e withtag $startObj
					$c itemconfigure $startObj -fill black
					set modified 1
					set startObj {}
					return
				}
			}
		}
		# if we get here then edge isn't terminating on a node
		$c delete $startObj
	} {
		set n [$g addnode]
		$c addtag 1$n withtag $startObj
		$c itemconfigure $startObj -fill white
		set modified 1
	}
	set startObj {}
}

proc loadFileByName {c name} {
	global modified
	if {$modified} {
		confirm "Current graph has been modified.  Shall I overwrite it?" \
			"loadFileByNameDontAsk $c $name"
	} {
		loadFileByNameDontAsk $c $name
	}
}

proc loadFileByNameDontAsk {c name} {
	global fileName g
	$g delete
	$c delete all
	set modified 0
        if {[string first / $name] == 0} {
		set fileName $name
	} {
		if {[pwd] == "/"} {
			set fileName /$name
		} {
			set fileName [pwd]/$name
		}
	}
	if {[catch {open $fileName r} f]} {
		warning "Unable to open file: $fileName"
	}
	if {[catch {dotread $f} g]} {
		warning "Invalid dot file: $fileName"
		close $f
	}
	close $f
	$g layout
	eval [$g render]
	$c configure -scrollregion [$c bbox all]
}

proc resize_canvas {c w h} {
	$c configure -scrollregion [$c bbox all]
}

proc update_entry {w x y} {
	$w.entry delete 0 end
	$w.entry insert end [$w.l.list get @$x,$y]
}

# doesn't work well with window managers that position initial window
# on the left because then all popups get obscured
#
#proc positionWindow {w} {
#	set pos [split [wm geometry .] +]
#	set x [expr [lindex $pos 1] - 350]
#	set y [expr [lindex $pos 2] + 20]
#	wm geometry $w +$x+$y
#}

proc loadFile {c} {
	global fileName

	set types {
		{{DOT Graph Files} {.dot}}
		{{All Files} *}
	}
	set fn [tk_getOpenFile \
		-defaultextension .dot \
		-filetypes $types \
		-initialfile $fileName]
	if {[string length $fn]} {
		loadFileByName $c $fn
	}
}

proc saveFile {type} {
	global fileName
	if {$fileName == {}} {
		saveFileAs $type
	} {
		saveFileByName $fileName $type
	}
}

proc saveFileByName {name type} {
	global fileName
	if {$name != $fileName && [file exists $name]} {
		confirm "File exists.  Shall I overwrite it?" \
			"saveFileByNameDontAsk $name $type"
	} {
		saveFileByNameDontAsk $name $type
	}
}

proc saveFileByNameDontAsk {name type} {
	global modified fileName g
	if {[catch {open $name w} f]} {
		warning "Unable to open file for write:\n$name; return"
	}
	if {$type == "dot"} {
		set type canon
		set fileName $name
		set modified 0
	}
	$g write $f $type
	close $f
	message "Graph written to:\n$name"
}

proc saveFileAs {type} {
	global fileName

	set cmap {{{CMAP Image Map Files} {.cmap}} {{All Files} *}}
	set dia {{{DIA Image Files} {.dia}} {{All Files} *}}
	set dot {{{DOT Graph Files} {.dot}} {{All Files} *}}
	set fig {{{FIG Image Files} {.fig}} {{All Files} *}}
	set gif {{{GIF Image Files} {.gif}} {{All Files} *}}
	set hpgl {{{HPGL Image Files} {.hpgl}} {{All Files} *}}
	set jpg {{{JPG Image Files} {.jpg}} {{All Files} *}}
	set mif {{{MIF Image Files} {.mif}} {{All Files} *}}
	set pcl {{{PCL Image Files} {.pcl}} {{All Files} *}}
	set png {{{PNG Image Files} {.png}} {{All Files} *}}
	set ps {{{PostScript Files} {.ps}} {{All Files} *}}
	set svg {{{SVG Image Files} {.png}} {{All Files} *}}

	set fn [tk_getSaveFile \
		-defaultextension .$type \
		-filetypes [set $type] \
		-initialdir [file dirname $fileName] \
		-initialfile [file tail [file rootname $fileName]].$type]
	if {[string length $fn]} {
		saveFileByNameDontAsk $fn $type
	}
}

proc print {} {
	global g printCommand
	if {[catch {open "| $printCommand &" w} f]} {
		warning "Unable to open pipe to printer command:\n$printCommand; return"
	}
	$g write $f ps
	close $f
	message "Graph printed to:\n$printCommand"
}

proc setPrinterCommand {w} {
	global printCommand
	set printCommand [$w.printCommand get]
	message "Printer command changed to:\n$printCommand"
	destroy $w
}

proc printSetup {} {
	global printCommand
	set w .printer
	catch {destroy $w}
	toplevel $w
#	positionWindow $w
	wm title $w "Printer"
	wm iconname $w "Printer"
	label $w.message -text "Printer command:"
	frame $w.spacer -height 3m -width 20
	entry $w.printCommand 
	$w.printCommand insert end $printCommand
	bind $w.printCommand <Return> "setPrinterCommand $w"
	frame $w.buttons
	button $w.buttons.confirm -text OK -command "setPrinterCommand $w"
	button $w.buttons.cancel -text Cancel -command "destroy $w"
	pack $w.buttons.confirm $w.buttons.cancel -side left -expand 1
	pack $w.message $w.spacer $w.printCommand -side top -anchor w
	pack $w.buttons -side bottom -expand y -fill x -pady 2m
}

proc confirm {msg cmd} {
	set w .confirm
	catch {destroy $w}
	toplevel $w
#	positionWindow $w
	wm title $w "Confirm"
	wm iconname $w "Confirm"
	label $w.message -text "\n$msg\n"
	frame $w.spacer -height 3m -width 20
	frame $w.buttons
	button $w.buttons.confirm -text OK -command "$cmd; destroy $w"
	button $w.buttons.cancel -text Cancel -command "destroy $w"
	pack $w.buttons.confirm $w.buttons.cancel -side left -expand 1
	pack $w.message $w.spacer -side top -anchor w
	pack $w.buttons -side bottom -expand y -fill x -pady 2m
}

proc message {m} {
	set w .message
	catch {destroy $w}
	toplevel $w
#	positionWindow $w
	wm title $w "Message"
	wm iconname $w "Message"
	label $w.message -text "\n$m\n"
	pack $w.message -side top -anchor w
	update
	after 2000 "destroy $w"
}

proc warning {m} {
	set w .warning
	catch {destroy $w}
	toplevel $w
#	positionWindow $w
	wm title $w "Warning"
	wm iconname $w "Warning"
	label $w.message -text "\nWarning:\n\n$m"
	pack $w.message -side top -anchor w
	update
	after 2000 "destroy $w"
}

proc setoneattribute {w d a s} {
	set aa [$w.e$a.a get]
	if {$aa == {}} {
		error "no attribute name set"
	} {
		set v [$w.e$a.v get]
		eval $s $aa $v
	}
	if {$a == {}} {
		destroy $w.e
		addEntryPair $w $d $aa $v $s
		addEntryPair $w d {} {} $s
	}
}

proc addEntryPair {w d a v s} {
	pack [frame $w.e$a] -side top
	pack [entry $w.e$a.a] [entry $w.e$a.v] -side left
	if {$a != {}} {
		$w.e$a.a insert end $a
		$w.e$a.a configure -state disabled -relief flat
		$w.e$a.v insert end $v
		if {$d != "d"} {
			$w.e$a.v configure -state disabled -relief flat
		}
	}
	bind $w.e$a.a <Return> "focus $w.e$a.v"