#!../tkdot -f

# doted - dot graph editor - John.Ellson@att.com
#
# 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/grey.25
}

# 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 dot 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 dot %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 dot"
    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 dot
    $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 == "dot"} {
	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

Written by: John Ellson (John.Ellson@att.com)
       and: Stephen North (Stephen.North@att.com)

DotEd provides for the graphical editing of
directed graphs."

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."

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

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 12 -height 16 \
    -bitmap @$tk_library/demos/images/grey.25 \
    -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 dot"
.m.file.m add command -label "Save As ..." -underline 5 \
    -command "saveFileAs dot"
.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 "HPGL ..." -underline 0 \
    -command "saveFileAs hpgl"
.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
