#!/usr/bin/env wish8.4

package require Tcldot

# doted - dot graph editor - John Ellson (ellson@graphviz.org)
#
# Usage: doted <file.gv>
#
# 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
	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]
				set startObj [$c create line $x $y $x $y -tag $item \
					-fill red -arrow last]
				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 loadDirectory {w type} {
	if {$type != ""} {set type .$type}
	$w.d.entry delete 0 end
	$w.d.entry insert end [pwd]
	$w.d.l.list delete 0 end
	if {[pwd] != "/"} {
		$w.d.l.list insert end ".."
	}
	foreach i [lsort [glob -nocomplain *]] {
		if {[file isdirectory $i]} {
			$w.d.l.list insert end [file tail $i]
		}
	}
	$w.f.l.list delete 0 end
	foreach i [lsort [glob -nocomplain *$type]] {
		if {! [file isdirectory $i]} {
			$w.f.l.list insert end [file tail $i]
		}
	}
}

proc loadDirectory_list {w type x y} {
	cd [$w.d.l.list get @$x,$y]
	loadDirectory $w $type
}

proc loadDirectory_entry {w type} {
	cd [$w.d.entry get]
	loadDirectory $w $type
}

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

proc loadFileByName_list {w c x y} {
	loadFileByName $w $c [$w.f.l.list get @$x,$y]
}

proc loadFileByName_entry {w c} {
	loadFileByName $w $c [$w.f.entry get]
}

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

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

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 w .load
	catch {destroy $w}
	toplevel $w
	positionWindow $w
	wm title $w "Load Dot File"
	wm iconname $w "Load"

	frame $w.d
	label $w.d.label -text "Directory:"
	frame $w.d.l
	listbox $w.d.l.list -width 30 -height 10 -yscrollcommand "$w.d.l.scroll set"
	bind $w.d.l.list <Double-1> "loadDirectory_list $w gv %x %y; break"
	bind $w.d.l.list <1> "update_entry $w.d %x %y"
	scrollbar $w.d.l.scroll -command "$w.d.l.list yview"
	pack $w.d.l.list $w.d.l.scroll -side left -fill y -expand 1
	frame $w.d.space1 -height 3m -width 20
	entry $w.d.entry -width 30
	frame $w.d.space2 -height 3m -width 20
	button $w.d.cancel -text Cancel -command "destroy $w"
	bind $w.d.entry <Return> "loadDirectory_entry $w gv"
	pack $w.d.label $w.d.l $w.d.space1 $w.d.entry $w.d.space2 -side top -anchor w
	pack $w.d.cancel -side top

	frame $w.space -height 3m -width 3m

	frame $w.f
	label $w.f.label -text "File:"
	frame $w.f.l
	listbox $w.f.l.list -width 30 -height 10 -yscrollcommand "$w.f.l.scroll set"
	bind $w.f.l.list <Double-1> "loadFileByName_list $w $c %x %y; break"
	bind $w.f.l.list <1> "update_entry $w.f %x %y"
	scrollbar $w.f.l.scroll -command "$w.f.l.list yview"
	pack $w.f.l.list $w.f.l.scroll -side left -fill y -expand 1
	frame $w.f.space1 -height 3m -width 20
	entry $w.f.entry -width 30
	frame $w.f.space2 -height 3m -width 20
	button $w.f.load -text Load -command "loadFileByName_entry $w $c"
	bind $w.f.entry <Return> "loadFileByName_entry $w $c; break"
	pack $w.f.label $w.f.l $w.f.space1 $w.f.entry $w.f.space2 -side top -anchor w
	pack $w.f.load -side top

	pack $w.d $w.space $w.f -side left -fill y -expand true

	loadDirectory $w gv
	$w.f.entry insert end [file tail $fileName]
}

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

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

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

proc saveFileByName_list {w x y type} {
	set dirName [$w.d.entry get]
	if {[catch {cd $dirName}]} {
		warning "No such directory:\n$dirName; return"
	}
	if {$dirName == "/"} {set dirName ""}
	saveFileByName $w $dirName/[$w.f.l.list get @$x,$y] $type
}

proc saveFileByName_entry {w type} {
	set dirName [$w.d.entry get]
	if {[catch {cd $dirName}]} {
		warning "No such directory:\n$dirName; return"
	}
	if {$dirName == "/"} {set dirName ""}
	saveFileByName $w $dirName/[$w.f.entry get] $type
}

proc saveFileAs {type} {
	global fileName
	set w .save
	catch {destroy $w}
	toplevel $w
	positionWindow $w
	wm title $w "Save Dot File"
	wm iconname $w "Save"

	frame $w.d
	label $w.d.label -text "Directory:"
	frame $w.d.l
	listbox $w.d.l.list -width 30 -height 10 -yscrollcommand "$w.d.l.scroll set"
	bind $w.d.l.list <Double-1> "loadDirectory_list $w $type %x %y; break"
	bind $w.d.l.list <1> "update_entry $w.d %x %y"
	scrollbar $w.d.l.scroll -command "$w.d.l.list yview"
	pack $w.d.l.list $w.d.l.scroll -side left -fill y -expand 1
	frame $w.d.space1 -height 3m -width 20
	entry $w.d.entry -width 30
	frame $w.d.space2 -height 3m -width 20
	button $w.d.cancel -text Cancel -command "destroy $w"
	bind $w.d.entry <Return> "loadDirectory_entry $w $type"
	pack $w.d.label $w.d.l $w.d.space1 $w.d.entry $w.d.space2 -side top -anchor w
	pack $w.d.cancel -side top

	frame $w.space -height 3m -width 3m

	frame $w.f
	label $w.f.label -text "File:"
	frame $w.f.l
	listbox $w.f.l.list -width 30 -height 10 -yscrollcommand "$w.f.l.scroll set"
	bind $w.f.l.list <Double-1> "saveFileByName_list $w %x %y $type; break"
	bind $w.f.l.list <1> "update_entry $w.f %x %y"
	scrollbar $w.f.l.scroll -command "$w.f.l.list yview"
	pack $w.f.l.list $w.f.l.scroll -side left -fill y -expand 1
	frame $w.f.space1 -height 3m -width 20
	entry $w.f.entry -width 30
	frame $w.f.space2 -height 3m -width 20
	button $w.f.load -text Save -command "saveFileByName_entry $w $type"
	bind $w.f.entry <Return> "saveFileByName_entry $w $type; break"
	pack $w.f.label $w.f.l $w.f.space1 $w.f.entry $w.f.space2 -side top -anchor w
	pack $w.f.load -side top

	pack $w.d $w.space $w.f -side left -fill y -expand true

	loadDirectory $w $type
	$w.f.entry insert end [file rootname [file tail $fileName]].$type
}

proc saveFile {type} {
	global fileName
	if {$fileName == {}} {
		saveFileAs $type
	} {
		saveFileByName {} $fileName $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"
	bind $w.e$a.v <Return> [list setoneattribute $w $d $a $s]
	pack $w.e$a -side top 
	focus $w.e$a.a
}

proc deleteobj {c o} {
	if {[string first "node" $o] == 0} {
		foreach e [$o listedges] {
			$c delete 1$e
			$c delete 0$e
			$e delete
		}
	}
	$c delete 1$o
	$c delete 0$o
	$o delete
}

proc setAttributesWidget {c o d l q s} {
	set w .attributes
	catch {destroy $w}
	toplevel $w
	positionWindow $w
	wm title $w "$o Attributes"
	wm iconname $w "Attributes"
	foreach a [eval $l] {
		if {[catch {eval $q $a} v]} {set v {}}
		addEntryPair $w $d $a $v $s
	}
	addEntryPair $w d {} {} $s
	frame $w.spacer -height 3m -width 20
	frame $w.buttons
	if {$d == "d"} {
		 button $w.buttons.delete -text Delete -command "deleteobj $c $o; destroy $w"
		 pack $w.buttons.delete -side left -expand 1
	}
	button $w.buttons.dismiss -text Dismiss -command "destroy $w"
	pack $w.buttons.dismiss -side left -expand 1
	pack $w.buttons -side bottom -expand y -fill x -pady 2m
}

proc setAttributes {c obj} {
	global g
	if {$obj == {}} {
		set obj [string range [lindex [$c gettags current] 0] 1 end]
	}
	set type [string range $obj 0 3]
	if {$type == "node" || $type == "edge"} {
		if {[string length $obj] > 4} {
			setAttributesWidget $c $obj d \
				"$obj listattributes" \
				"$obj queryattributes" \
				"$obj setattributes"
		} {
			setAttributesWidget $c $obj {} \
				"$g list[set type]attributes" \
				"$g query[set type]attributes" \
				"$g set[set type]attributes"
		}
	} {
		setAttributesWidget $c $g {} \
			"$g listattributes" \
			"$g queryattributes" \
			"$g setattributes"
	}
}

proc newGraph {c} {
	global modified g
	if {$modified} {
		puts "graph was modified"
	}
	$g delete
	set g [dotnew digraph]
	$c delete all
	set modified 0
}

proc layout {c hs vs} {
	global g
	$c delete all
	$g layout
	eval [$g render]
	$c configure -scrollregion [$c bbox all]
}

proc help {msg} {
	set w .help
	catch {destroy $w}
	toplevel $w
	positionWindow $w
	wm title $w "DotEd Help"
	wm iconname $w "DotEd"
	frame $w.menu -relief raised -bd 2
	pack $w.menu -side top -fill x
	label $w.msg \
		-font -Adobe-helvetica-medium-r-normal--*-140-*-*-*-*-*-* \
		-wraplength 4i -justify left -text $msg
	pack $w.msg -side top
	frame $w.buttons
	pack  $w.buttons -side bottom -expand y -fill x -pady 2m
	button $w.buttons.dismiss -text Dismiss -command "destroy $w"
	pack $w.buttons.dismiss -side left -expand 1
}

#--------------------------------------------------------------------------
set help_about "DotEd - Dot Graph Editor
Copyright (C) 1995 AT&T Bell Labs
		  (C) 1996 Lucent Technologies

Written by: John Ellson (ellson@graphviz.org)
	   and: Stephen North (north@research.att.com)

DotEd provides for the graphical editing of
directed graphs. Once a graph has been manually
entered then the dot layout algorithm can be applied 
by clicking on the button in the lower right corner
of the window."

set help_mouse "Button-1: When the cursor is over the
  background Button-1-Press will start a node, 
  Button-1-Motion (dragging the mouse with Button-1
  still down) will move it and  Button-1-Release
  will complete the node insertion into the graph.
 
  When the cursor is over an existing node then
  Button-1-Press will start an edge from that node.
  Button-1-Motion will extend the edge and
  Button-1-Release over a different node will
  complete the edge.

Button-2: Button-2-Motion (click and drag) will
  reposition the canvas under the window.

Button-3: When Button-3 is
  clicked over a node or edge the attribute editor
  will be opened on that object.

Once a graph has been manually entered then the dot 
layout algorithm can be applied by clicking on the 
button in the lower right corner of the window."

#--------------------------------------------------------------------------

set startObj {}
set saveFill {}
set modified 0
set fileName {no_name}
set printCommand {lpr}
set g [dotnew digraph]
wm title . "DotEd"
wm iconname . "DotEd"
frame .m -relief raised -borderwidth 1
frame .a
frame .b
set c [canvas .a.c -cursor crosshair \
	-xscrollcommand ".b.h set" \
	-yscrollcommand ".a.v set" \
	-borderwidth 0]
bind $c <ButtonPress-1> "mouse_b1_press $c %x %y"
bind $c <B1-Motion> "mouse_b1_motion $c %x %y"
bind $c <ButtonRelease-1> "mouse_b1_release $c %x %y"
bind $c <2> "$c scan mark %x %y"
bind $c <B2-Motion> "$c scan dragto %x %y"
bind $c <3> "setAttributes $c {}"
$c bind all <Any-Enter> "mouse_anyenter $c"
$c bind all <Any-Leave> "mouse_anyleave $c"
scrollbar .b.h -orient horiz -relief sunken -command "$c xview"
scrollbar .a.v -relief sunken -command "$c yview"
button .b.layout -width [.a.v cget -width] -height [.b.h cget -width]\
	-bitmap @$tk_library/demos/images/gray25.bmp \
	-command "layout $c .b.h .a.v"
menubutton .m.file -text "File" -underline 0 -menu .m.file.m
menu .m.file.m
.m.file.m add command -label "Load ..." -underline 0 \
	-command "loadFile $c"
.m.file.m add command -label "New" -underline 0 \
	-command "newGraph $c"
.m.file.m add command -label "Save" -underline 0 \
	-command "saveFile gv"
.m.file.m add command -label "Save As ..." -underline 5 \
	-command "saveFileAs gv"
.m.file.m add separator
.m.file.m add cascade -label "Export" -underline 1 \
	-menu .m.file.m.export
menu .m.file.m.export
.m.file.m.export add command -label "GIF ..." -underline 0 \
	-command "saveFileAs gif"
.m.file.m.export add command -label "ISMAP ..." -underline 0 \
	-command "saveFileAs ismap"
.m.file.m.export add command -label "MIF ..." -underline 0 \
	-command "saveFileAs mif"
.m.file.m.export add command -label "PCL ..." -underline 1 \
	-command "saveFileAs pcl"
.m.file.m.export add command -label "PostScript ..." -underline 0 \
	-command "saveFileAs ps"
.m.file.m add separator
.m.file.m add command -label "Print Setup ..." -underline 0 \
	-command "printSetup"
.m.file.m add command -label "Print" -underline 0 \
	-command "print"
.m.file.m add separator
.m.file.m add command -label "Exit" -underline 0 -command "exit"
menubutton .m.graph -text "Graph" -underline 0 -menu .m.graph.m
menu .m.graph.m
.m.graph.m add command -label "Graph Attributes" -underline 0 \
	-command "setAttributes $c graph"
.m.graph.m add command -label "Node Attributes" -underline 0 \
	-command "setAttributes $c node"
.m.graph.m add command -label "Edge Attributes" -underline 0 \
	-command "setAttributes $c edge"
menubutton .m.help -text "Help" -underline 0 -menu .m.help.m
menu .m.help.m
.m.help.m add command -label "About DotEd" -underline 0 \
	-command {help $help_about}
.m.help.m add command -label "Mouse Operations" -underline 0 \
	-command {help $help_mouse}
pack append .m .m.file {left} .m.graph {left} .m.help {right}
pack append .a $c {left expand fill} .a.v {right filly}
pack append .b .b.h {left expand fillx} .b.layout {right}
pack append . .m {top fillx} .a {expand fill} .b {bottom fillx}
tk_menuBar .m.file .m.graph .m.help
