#!/usr/local/tcl/bin/wish -f
#
# The Interaction network browser.
# 
# This program reads an interaction network stored in a text file (the
# format is described in the comments below).  The interaction network
# is drawn on the screen, with a circle drawn for each node and a line for
# each edge.  The user can zoom in and out and pan around the network.
# Whenever the mouse cursor enters a circle some text describing the 
# event represented by the circle is printed.  Users can reposition
# columns, where each column contains all events that belong to one thread.

###############################################################################
# These procedures assist in display and editing of integers in dialogue boxes.

# displayMessage creates a new top level window and dispays the message
# mess in it.  Then it waits until the message is acknowledged (i.e. the
# Done button is pressed) before returning.

proc displayMessage { mess } {
# Display message
    makeTextBox .mess $mess
    packTextBox .mess

# Wait until it is acknowledged.
    tkwait visibility .mess
    grab .mess
    tkwait window .mess
}


# Create a new top level window to display the text in.  The window 
proc makeTextBox {w message} {
    catch {destroy $w}

# Create a new toplevel and specify its attributes
    toplevel $w -relief raised -borderwidth 2
    wm title $w "Dialog box"
    wm iconname $w "Dialog box"
    wm minsize $w 81 50
    wm geometry $w 500x75
#   wm geometry $w $posn
    wm transient $w .

# The window is to contain a single frame.  In that frame are to be a
# text area containing the message, a horizontal scrollbar, and a Done button
    frame $w.frame -relief ridge -borderwidth 2

    scrollbar $w.frame.yscroll -relief sunken -command \
	"$w.frame.text yview"

    text $w.frame.text -yscroll "$w.frame.yscroll set" -relief sunken \
	-wrap word 
    $w.frame.text insert 0.0 $message
    $w.frame.text configure -state disabled	

    button $w.okbutton -text Done -command "destroy $w"
}


# Pack all widgets used in the message display window

proc packTextBox { w } {
	pack $w.okbutton -in $w -side bottom -fill x

	pack $w.frame -side top -expand yes -fill y
	
	pack $w.frame.yscroll -side right -fill y

	pack $w.frame.text -side left -expand yes -fill both

}


# Implement a dialogue box that allow entry of an integer.  A new top
# level window is created to contain the dialogue box.  It contains:
# a text prompt field, a field ofr entry of the value, and OK and Cancel
# buttons.  Once the window has been set up, we wait for the user to 
# finish using the dialogue box.
	
proc intDialog { prompt initvalue } {
    global finalvalue

    set finalvalue $initvalue

    catch {destroy .intDialog}
    toplevel .intDialog -relief raised -borderwidth 2
 
    wm title .intDialog "Dialog box"
    wm iconname .intDialog "Dialog box"
    wm minsize .intDialog 81 50
    wm transient .intDialog .

    frame .intDialog.field
    label .intDialog.field.label -text $prompt
    entry .intDialog.field.entry -width 10 -relief sunken
    .intDialog.field.entry insert 0 $initvalue 
    pack .intDialog.field.label -in .intDialog.field -side left -expand y
    pack .intDialog.field.entry -in .intDialog.field -side right -expand y
    pack .intDialog.field -in .intDialog -side top

    frame .intDialog.buttons
    button .intDialog.buttons.ok -text "OK" -command "intDOK .intDialog"
    button .intDialog.buttons.cancel -text "Cancel" \
	-command "destroy .intDialog"
    pack .intDialog.buttons.ok -in .intDialog.buttons -expand 1 -fill x \
	-side left
    pack .intDialog.buttons.cancel -in .intDialog.buttons -expand 1 -fill x \
	-side left
    pack .intDialog.buttons -in .intDialog -side bottom -expand 1 -fill x

    tkwait visibility .
    grab .intDialog
    tkwait window .intDialog
    return $finalvalue
}


# The OK button has been pressed on the dialogue box.  If the integer 
# in the dialogue box is a legal one, then use the global final value to
# convey its value back to intDialog, and destry the dialogue box (which
# will reawaken intDialog).  If the value is illegal, give an error message,
# and restore the contents of the dialogue box to their original value.

proc intDOK { w } {
    global finalvalue

    set currvalue [$w.field.entry get]
    if {[scan $currvalue "%d" intvalue] != 1} {
	displayMessage "Illegal integer value"
        $w.field.entry delete 0 end
        $w.field.entry insert 0 $finalvalue 
    } else {
        set finalvalue $intvalue
        destroy $w
    }
}


###################### Currently unused #########################

proc getposn {} {
    return [string trimleft [wm geometry .] "=x0123456789"]
}


proc notImpl { } {
    displayMessage "Not implemented yet"
}


###############################################################################

# The following group of routines relate to handling of coordinates on the
# display.  The coordinates in the input file are scaled independently
# The difference in X coordinates of adjacent columns is quite small
# (often only 1).  To get reasonable separation, X coordinates
# are scalled up by $xfactor.  Scaling of y-coordinates depends on whether
# the interaction network was drawn in time ("T") mode or partial order 
# ("P") mode.  In time mode, y-coordinates are actuall microseconds since
# the beginning of the interaction, so scaling involves dividing by $yfactor
# to ensure that the events aren't too spread out.  In partial order mode,
# however, there is often only a gap of 1 between successive events,
# and in this case scaling involves multiplying by $yfactor.
#
# columnMap is used to record changes in column positions.  It is an array
# indexed by x coordinate.  For every X coordinate used, columnMap(x)
# is initialised to x.  columnMap is updated when a column is moved.

proc xscale {x} {
    global xfactor border columnMap

    return [expr $border + $columnMap($x) * $xfactor]
}


proc yscale {y} {
    global yfactor border displaytype

    if {$displaytype == "T"} {
        return [expr $border + $y / $yfactor]
    } else {
        return [expr $border + $y * $yfactor]
    }
}


# When an interaction network is read, the maximum values for x and y
# are recorded.  Given these (and the space left around an interaction
# network) canvas width and height can be determined.

proc canvasWidth {} {
    global border maxx xfactor

    return [expr $border * 2 + $maxx * $xfactor]
}


proc canvasHeight {} {
    global border maxy

    return [expr $border + [yscale $maxy]]
}


# The next groups of functions are used in computing the top left and
# bottow right points of the circle drawn for some event.

proc topleftx {x radius} {

    return [expr [xscale $x] - $radius]
}


proc toplefty {y radius} {

    return [expr [yscale $y] - $radius]
}


proc bottomrightx {x radius} {

    return [expr [xscale $x] + $radius]
}


proc bottomrighty {y radius} {

    return [expr [yscale $y] + $radius]
}


# Functions implementing the zoom in and zoom out functions.  Perhaps the
# zoom factor should be a parameter.

proc zoomIn {} {
     global scaleFactor

     set scaleFactor [expr $scaleFactor * 1.25]
    .net scale netobj 0 0 1.25 1.25
}

proc zoomOut {} {
     global scaleFactor

     set scaleFactor [expr $scaleFactor * 0.8]
    .net scale netobj 0 0 0.8 0.8
}


###############################################################################

# Function to determine colour (with the colour assiciated with host)
# the onject tag on canvas canv.  

proc colourObj {canv tag type} {
    global colour grey stipple useColour

    if {! $useColour} {
  	$canv itemconfigure $tag -fill $grey(smx)
	if {$stipple(smx) != ""} {
            $canv itemconfigure $tag -stipple $stipple(smx)
	}
    } else {
       	$canv itemconfigure $tag -fill $colour($type)
	if {[string match node* $tag]} {
	   $canv itemconfigure $tag -outline $colour($type)
	}
    }
}


###############################################################################

# Procedure to prompt for and save the visible canvas as a postscript file

proc pscript {} {

    toplevel .save

    label .save.mes -text "Enter filename to save canvas as postscript"
    entry .save.fn -relief ridge
    button .save.ok -text "Save" -command {
	.net postscript -file [.save.fn get]
	destroy .save
    }
    button .save.cancel -text "Cancel Save" -command {destroy .save}

    bind .save.fn <Key-Return> ".save.ok invoke"
    pack .save.mes
    pack .save.fn
    pack .save.ok -side left
    pack .save.cancel -side right
}

###############################################################################

# Two procedures which enable text to be entered directly onto the canvas.
# Delete and linefeed (NOT Return) are the only editing features.
# NOTE: Text cannot be reselected for later editing- so do it right first time!

proc starttext {c x y} {

    set cx [$c canvasx $x]
    set cy [$c canvasy $y]
    set id [$c create text $cx $cy -text "" -justify center]
    $c focus $id
    $c icursor $id 0
    focus $c
    global insert$id
    set insert$id 0
    $c bind $id <Any-Key> "inserttext $c $id %A"
    $c bind $id <Button-3> "$c delete $id"
}

proc inserttext {canv id char} {

    global insert$id
    if {$char == "\x7f"} {
	if {[set insert$id] > 0} {
	    incr insert$id -1
	    $canv dchars $id [set insert$id]
	}
    } else {
	$canv insert $id [set insert$id] $char
	incr insert$id
    }
}
###############################################################################

# Function to setup the frame of the main window of the browser.  Currently
# the window consists of four main frames.  The top one contains a menubar
# (.menu) that runs the whole width of the window.  Under that comes the
# frame upper that contains the canvas the and vertical scroll bar.
# Under that comes the frame lower that contains the horizontal scroll
# bar and a filler frame.  Under that comes the button framce that contains
# the zoom in and zoom out buttons and the colour key.  Under that comes the
# event text window in which text describing the current event is displayed.
# The various widgets are first created, and then packed into the window.

proc setupframe {} {
    global maxx maxy

    wm minsize . 100 100
  
# Menus
    frame .menu
    menubutton .menu.options -text "Options" -menu .menu.options.m -underline 0
    menu .menu.options.m
    .menu.options.m add command -label "X scale" -command adjXscale  \
	-underline 0
    .menu.options.m add command -label "Y scale" -command adjYscale \
	-underline 0
    .menu.options.m add separator
    .menu.options.m add command -label "Save to file" -command "pscript"
    .menu.options.m add separator
    .menu.options.m add command -label "Exit" -command exit -underline 0

# Main canvas
    frame .upper
    frame .lower
    frame .filler 
    canvas .net -width 500 -height 200 -borderwidth 1 -relief raised -bg white
    scrollbar .vscroll -orient vertical -borderwidth 1 -relief raised
    scrollbar .hscroll -orient horizontal -borderwidth 1 -relief raised

    .net config -confine 1 \
	-scrollregion [format "0 0 %f %f" [canvasWidth] [canvasHeight]]
    .net config -yscrollcommand ".vscroll set" -xscrollcommand ".hscroll set"
    .vscroll config -command ".net yview"
    .hscroll config -command ".net xview"
    bind .net <Button-2> "starttext .net %x %y"

# Zoom in and out buttons
    frame .buttons
    button .zoomIn -text "Zoom in" -command zoomIn
    button .zoomOut -text "Zoom out" -command zoomOut

# Colour/shading key canvas
    canvas .key -width 400 -height 20 -borderwidth 2
#    .key create text 40 10 -text "Ralph"
#    .key create oval 5 5 15 15 -tag ralphOval
#    colourObj .key ralphOval ralph
#    .key create text 105 10 -text "Piggy"
#    .key create oval 70 5 80 15 -tag piggyOval
#    colourObj .key piggyOval piggy
#    .key create text 170 10 -text "Scooter"
#    .key create oval 130 5 140 15 -tag scooterOval
#    colourObj .key scooterOval scooter
#    .key create text 235 10 -text "Gonzo"
#    .key create oval 200 5 210 15 -tag gonzoOval
#    colourObj .key gonzoOval gonzo
#    .key create text 300 10 -text "Grover"
#    .key create oval 265 5 275 15 -tag groverOval
#    colourObj .key groverOval grover
#    .key create text 365 10 -text "Bigbird"
#    .key create oval 330 5 340 15 -tag bigbirdOval
#    colourObj .key bigbirdOval bigbird

# Event description display
    frame .eventText -relief ridge -borderwidth 2
    scrollbar .eventText.yscroll -relief sunken \
	-command ".eventText.text yview"
    text .eventText.text -yscroll ".eventText.yscroll set" \
	-relief sunken -wrap word -height 2
    .eventText.text configure -state disabled	

# Now pack everything
    pack .menu -side top -fill x 
    pack .menu.options -in .menu -side left

    pack .eventText -side bottom -fill x
    pack .eventText.yscroll -side right -fill y
    pack .eventText.text -side left -fill x

    pack .buttons -fill x -side bottom
    pack .zoomIn -in .buttons -expand 1 -fill x -side left
    pack .zoomOut -in .buttons -expand 1 -fill x -side right
    pack .key -in .buttons

    pack .upper -fill both -expand 1
    pack .vscroll -in .upper -fill y -side right
    pack .net -in .upper -fill both -expand 1 -side left

    pack .lower -fill x
    pack .hscroll -in .lower -fill x -expand 1 -side left
    pack .filler -in .lower -padx 8

}


###############################################################################

# Now we have the file input functions

proc getline {file} {
    if {[gets $file line] == -1} {
        puts "Error reading from file"
        exit
    }
    return $line
}


# Here's the procedure that reads an interaction network from the file
# name passed as a parameter.  Information from the file is stored in
# various global variables, and is used to initialise the canvas.
#
# The format of an interaction network is
# as follows:
#
# File type line
# Dimensions line
# Node lines
# Edge lines
#
# The file type is either T (time) or P (partial order).  The global
# displaytype is assigned the file type.  displaytype has relevance
# only to the scaling of the Y coordinate.
#
# The variables maxx and maxy are read from the dimensions line. 
# Maxx is one more than the maximum X coordinate of any of the
# vertices, and maxy is one more than the maximum Y coordinate of any
# of the vertices.
#
# Each node line contains the following pieces of information:
#    - a unique node number (= -1 to mark end of node lines).
#    - x and y coordinates
#    - the name of the machine on which the event was recorded.
#    - the process id and the thread id of the thread in which the event
#      occurred (both -1 for message-related events)
#    - the rest of the line is further information about the event that
#      can be displayed to the user on request.
#
# This information is used to:
#    - initialise columnMap for every X coordinate
#    - initialise node list to a list of all node numbers
#    - initialise nodectr to contain the x and y coordinates of all nodes
#    - initialise hostnames to contain the hostname associated with each node
#    - initialise nodedesc to contain the "further information" associated
#      with each node
#    - create the circle that represents the node.
#    - initialise headings to contain the heading (of the form pid/tid)
#      for each X coordinate used
#
# Each edge line contains the unique id of the edge (-1 to mark the end
# of the edge lines) and the node numbers of the source and destination
# nodes.  This information is used to build up a list of edge numbers 
# in linelist, and to record the edge numbers of all edges leaving
# (linefrom) and entering (lineto) each node.

proc readfile {files} {
    global nodedesc nodectr linefrom lineto
    global maxx maxy
    global nodelist linelist headings
    global displaytype yfactor
    global columnMap
    global hostnames
    global headingy
    global pname
    global radius
    global useColour

    set nodelist [list]
    set linelist [list]
    set headings [list]

    set displaytype [getline $files]
    if {$displaytype != "T" && $displaytype != "P"} {
        puts "Invalid display type"
        exit
    }
    if {$displaytype == "T"} {
        set yfactor 500
    } else {
        set yfactor 16
    }

    set line [getline $files]
    scan $line "%d %d" maxx maxy
    setupframe 

# Read in the nodes
    set done 0
    while {$done == 0} {
	set line [getline $files]
        scan $line "%d %d %d %s %d %d%c%\[^#\]" nodenum nodex nodey host \
          pid tid dummy nodestr
	set type [lindex $nodestr 1]
        if {$nodenum == -1} {
            set done 1
        } else {
	    set columnMap($nodex) $nodex
            lappend nodelist $nodenum
            set nodectr(node$nodenum,x) $nodex
            set nodectr(node$nodenum,y) $nodey
	    set nodectr(node$nodenum,r) $radius($type)
	    set hostnames(node$nodenum) $host
	    set nodedesc(node$nodenum) $nodestr

            .net create oval [topleftx $nodex $radius($type)] [toplefty $nodey $radius($type)] \
              [bottomrightx $nodex $radius($type)] [bottomrighty $nodey $radius($type)]  -tag node$nodenum
	    colourObj .net node$nodenum $type
	    .net bind node$nodenum <ButtonPress-1> "startmove node$nodenum %x"
	    .net bind node$nodenum <B1-Motion> "moving %x"
	    .net bind node$nodenum <ButtonRelease-1> "endmove node$nodenum %x"
	    .net bind node$nodenum <Enter> "displaydesc node$nodenum"
	    .net bind node$nodenum <Leave> "blankdesc"

	    if {[lsearch $headings $nodex] == -1} {
		lappend headings $nodex
		if {$tid <= 2} {
		    set head $pname(p$tid)
		} else {
		    set head [format "%d/%d" $pid $tid]
		}
		.net create text [xscale $nodex] $headingy -tag heading$nodex \
		  -text $head
 	    }
        }
    }

# Read in the lines
    set done "0"
    while {$done == "0"} {
        set line [getline $files]
        scan $line "%d %d %d" linenum fromnode tonode
        if {$linenum == -1} {
            set done 1
        } else {
            lappend linelist $linenum
	    set linefrom(line$linenum) $fromnode
	    set lineto(line$linenum) $tonode
            set x1 [xscale $nodectr(node$fromnode,x)]
	    set y1 [yscale $nodectr(node$fromnode,y)]
            set x2 [xscale $nodectr(node$tonode,x)]
	    set y2 [yscale $nodectr(node$tonode,y)]
            .net create line $x1 $y1 $x2 $y2 -tag line$linenum 
	    if {$hostnames(node$tonode) == $hostnames(node$fromnode) && \
                $useColour} {
		colourObj .net line$linenum $hostnames(node$tonode)
            }
            .net lower line$linenum
        }
    }
# Tag used to scale all objects on the canvas
    .net addtag netobj all
}  


###############################################################################

# These functions update the event description text area that is at
# the bottom of the main window.  displaydesc displays a description
# of the specified node in the window, and blankdes removes any
# desctiption that is currently displayed.

proc displaydesc {nodeid} {
    global nodedesc hostnames

    .eventText.text configure -state normal
    .eventText.text insert 0.0 \
      [format "%s %s" $hostnames($nodeid) $nodedesc($nodeid)]
    .eventText.text configure -state disabled
}

proc blankdesc {} {
    .eventText.text configure -state normal
    .eventText.text delete 1.0 end
    .eventText.text configure -state disabled
}


###############################################################################

# This group of functions implement column movement.  Startmove records the
# original X coordinate of the column being moved, and moving x is set
# to its current X coordinate.  It also creates a line that represents the
# position of the column as it is moved.  moving moves the line as the
# user continues to drag the cursor.  endmove deletes the line, updates
# columnMap, and redraws the screen.

proc startmove {nodeid x} {
    global movingcol movingx nodectr

    set movingcol $nodectr($nodeid,x)
    set movingx $x
    .net create line $x 0 $x [canvasHeight] -tag movingline
}

proc moving {x} {
    global movingx

    .net move movingline [expr $x - $movingx] 0
    set movingx $x
}


proc endmove {nodeid x} {
    global movingcol columnMap border xfactor scaleFactor

    .net delete movingline
    set newCol [expr ($x / $scaleFactor - $border) / $xfactor]
    if {$newCol < 0} {set newCol 0}

    if {$newCol != $columnMap($movingcol)} {
	. config -cursor watch
	update
        set columnMap($movingcol) $newCol
        rescale
	. config -cursor left_ptr
    }
}


# rescale recomputes the coordinates of all objects (headings, nodes,
# edges) on the .net canvas, and updates them.

proc rescale {} {
    global nodectr linefrom lineto
    global nodelist linelist headings
    global scaleFactor
    global headingy

    .net config -confine 1 \
	-scrollregion [format "0 0 %f %f" [canvasWidth] [canvasHeight]]

    for {set i 0} {$i < [llength $headings]} {incr i} {
        set colnum [lindex $headings $i]
	.net coords heading$colnum [xscale $colnum] $headingy
    }

    for {set i 0} {$i < [llength $nodelist]} {incr i} {
        set nodenum [lindex $nodelist $i]
	set x $nodectr(node$nodenum,x)
	set y $nodectr(node$nodenum,y)
	set r $nodectr(node$nodenum,r)
	.net coords node$nodenum [topleftx $x $r] [toplefty $y $r] \
	    [bottomrightx $x $r] [bottomrighty $y $r]
    }

    for {set i 0} {$i < [llength $linelist]} {incr i} {
	set linenum [lindex $linelist $i]
	set from $linefrom(line$linenum)
	set to $lineto(line$linenum)
	.net coords line$linenum\
	    [xscale $nodectr(node$from,x)] \
	    [yscale $nodectr(node$from,y)] \
	    [xscale $nodectr(node$to,x)] \
	    [yscale $nodectr(node$to,y)]
    }
    .net scale netobj 0 0 $scaleFactor $scaleFactor
}


###############################################################################

# Routines for prompting the user for new X and Y scaling factors

proc adjYscale {} {
    global yfactor

    set newy [intDialog "Y Scale factor" $yfactor]
    if {$newy != $yfactor} {
        set yfactor $newy
        rescale
    }
}

proc adjXscale {} {
    global xfactor

    set newx [intDialog "X Scale factor" $xfactor]
    if {$newx != $xfactor} {
        set xfactor $newx
        rescale
    }
}

###############################################################################

# Right - now that we have defined all of the procedures, here is the main
# program.

# Should colour be used?

if {[winfo depth .] < 8} {
    set useColour 0
} else {
    set useColour 1
}

# initialise global constants
set scaleFactor 1.0
set xfactor 50
set headingy 10
set std_radius 3
set border 20

# for standard X colour names see /usr/lib/X11/rgb.txt 
set colour(EV_TTY_INPUT,) black
set colour(EV_MSG_BLOCK,) red
set colour(EV_MSG_SEND,) yellow2
set colour(EV_MSG_RECV,) green3
set colour(EV_FORK,) magenta
set colour(EV_EXIT,) magenta
set colour(EV_SINK,) magenta
set colour(EV_NEW_NAME,) magenta
set colour(smx) black

set radius(EV_TTY_INPUT,) 6
set radius(EV_MSG_BLOCK,) 3
set radius(EV_MSG_SEND,) 3
set radius(EV_MSG_RECV,) 3
set radius(EV_FORK,) 6
set radius(EV_EXIT,) 6
set radius(EV_SINK,) 6
set radius(EV_NEW_NAME,) 6

# for info on stiples see GetBitmap(3)
set grey(smx) "black"
set stipple(smx) ""
set grey(ralph) "black"
set stipple(ralph) ""
set grey(piggy) "black"
set stipple(piggy) "gray50"
set grey(scooter) "white"
set stipple(scooter) ""
set grey(gonzo) "black"
set stipple(gonzo) "gray25"
set grey(grover) "black"
set stipple(grover) "question"
set grey(bigbird) "black"
set stipple(bigbird) "warning"

# Standard process names
set pname(p-9) "TTY"
set pname(p-8) "IDLE"
set pname(p-7) "PRINT"
set pname(p-6) "WINCH"
set pname(p-5) "DISK"
set pname(p-4) "MEM"
set pname(p-3) "CLOCK"
set pname(p-2) "SYS"
set pname(p-1) "HWARE"
set pname(p0) "MM"
set pname(p1) "FS"
set pname(p2) "INIT"


# process the command line
if {$argc >= 2} {
    puts [format "Usage: %s \[file\]" $argv0]
    exit
}
if {$argc == 1} {
    if {![file readable $argv]} {
        puts [format "%s: cannot access %s" $argv0 $argv]
        exit
    }
    readfile [open $argv "r"]
} else {
    readfile stdin
}
