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

package require Tkspline
package require Tcldot

# Maria reachability graph visualizer
# by Marko Mkel (msmakela@tcs.hut.fi)
# based on the DotEd demo and feedback from John Ellson (ellson@lucent.com)

global saveFill tk_library 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 button is pressed over a node, perform a command on it
proc mouse_press {c x y cmd} {
    global g
    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 l [[string range $tag 1 end] showname]
		puts "$cmd $l"
		return
	    }
	}
    }
}

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 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 saveFileByName {w name type} {
    if {[file exists $name]} {
	confirm "File exists.  Shall I overwrite it?" \
		"saveFileByNameDontAsk $w $name $type"
    } {
	saveFileByNameDontAsk $w $name $type
    }
}

proc saveFileByNameDontAsk {w name type} {
    global g
    if {[catch {open $name w} f]} {
	warning "Unable to open file for write:\n$name; return"
    }
    if {$type == "dot"} {
	set type canon
    }
    $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} {
    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
}

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

# lay the graph out
proc layoutgraph {g c} {
    $c delete all
    $g layout
    eval [$g render $c]
    $c configure -scrollregion [$c bbox all]
}

proc parse {ch} {
    global g c
    set line [gets $ch]
    if {[eof $ch]} { exit }
    switch $line {
	"new();"	{
	    if {[catch {dotread $ch} g]} {
		puts stderr "maria-vis: invalid graph"
	    } else {
		layoutgraph $g $c
	    }
	}
	"add();"	{
	    if {[catch {dotread $ch} g2]} {
		puts stderr "maria-vis: invalid graph"
	    } else {
		# merge the nodes
		foreach i [$g2 listnodes] {
		    [$g addnode [$i showname]] setattributes \
			    [$i queryattributevalues [$i listattributes]]
		}
		# merge the edges
		foreach i [$g2 listedges] {
		    foreach {t h} [$i listnodes] {break}
		    [$g addedge [$t showname] [$h showname]] setattributes \
			    [$i queryattributevalues [$i listattributes]]
		}
		layoutgraph $g $c
	    }
	}
	default		{ puts stderr "maria-vis: unrecognized cmd: $line" }
    }
}

set saveFill {}
set g [dotnew digraph]
wm title . "Maria Browser"
wm iconname . "Maria"
wm minsize . 50 100
wm geometry . 400x300
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" \
	-width 0 \
	-height 0 \
	-borderwidth 0]
bind $c <1> "mouse_press $c %x %y visual\\ visual\\ succ"
bind $c <2> "mouse_press $c %x %y visual\\ visual\\ pred"
$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"
menubutton .m.file -text "File" -underline 0 -menu .m.file.m
menu .m.file.m
.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 "PNG ..." -underline 0 \
	-command "saveFileAs png"
.m.file.m.export add command -label "GIF ..." -underline 0 \
	-command "saveFileAs gif"
.m.file.m.export add command -label "SVG ..." -underline 0 \
	-command "saveFileAs svg"
.m.file.m.export add command -label "ISMAP ..." -underline 0 \
	-command "saveFileAs ismap"
.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 "Exit" -underline 0 -command "exit"
pack append .m .m.file {left}
pack append .a $c {left expand fill} .a.v {right filly}
pack append .b .b.h {left expand fillx}
pack append . .m {top fillx} .a {expand fill} .b {bottom fillx}
tk_menuBar .m.file

fileevent stdin readable "parse stdin"