#!/opt/tcl/bin/sytcl
#/usr/local/tcl74/bin/dbtcl
#
# set tclroot /usr/local/tcl74
set tclroot /opt/share/tcl
loadlibindex $tclroot/lib/ucodb/ucodb.tlib
loadlibindex $tclroot/lib/ucodb/memes.tlib
#
set dbpipe1 [sybOpen keck guest rsvp UCO-ASTRO]
# puts stderr "got dbpipe $dbpipe1"
#
global sybmsg
#set efp [open mebc.log w]
#
set memtbl keck.dbo.Memes
set mcotbl keck.dbo.Mcontexts
set mvatbl keck.dbo.Mvalues
set mebtbl keck.dbo.Mbundles
set mftbl keck.dbo.Mpaths
set agtbl keck.dbo.Agents
set attbl keck.dbo.AgentTypes
set fotbl keck.dbo.Formats
set metbl keck.dbo.Media
set titbl keck.dbo.Timing
set maptbl keck.dbo.Mmaps
set mpitbl keck.dbo.Mpinouts
#
establishRoles
#
#--------------------------------PROCS-------------------------------
#
set init_phase 1
set nesting 100
set minn 100
set ty ""
# trace variable ty w "tellTale"
#
# Global vars for page layout
set Lang ps
set Page A
set Tile 0
set Stretch 0
set Rota 0
set NumPath 0
set Quiet 0
set Describe 0
set Footer 0
#
proc tellTale {n1 n2 op} {
	puts stderr "Got a write to $n1"
}
#
proc makeSub so {

	global fcols agtbl agents ofp et
	global parent children nesting minn peri

	upvar #0 $so $so

	puts stderr "  makeSub $so"
	incr nesting -1
	if {$nesting < $minn} {set minn $nesting}
	puts stderr "make subgraph for owner $so owns\n\t[join [set $so] \n\t]"
	set sqlcmd "select aname from $agtbl where agentid = $so"
	set sqt $agtbl
	doSQL 1
	set on [sybNext 1]
	puts stderr "Set peripheries = $nesting for superagent $so"
	set peri($so) $nesting
	puts $ofp "subgraph cluster$so \{"
	foreach s [set $so] {
		puts stderr "  $so : $s"
		makePath R $s
	}

	if {![info exists children($so)]} {
		puts stderr "no superchildren of $so end of line"
	} else {
		puts stderr "super $so has superchildren, make 'em..."
		foreach c $children($so) {
			puts stderr "  makeSub of child $c of $so"
			makeSub $c
		}
	}

	puts $ofp "fontname=Helvetica\nfontsize=10\nlabel = \"$on\"\n\}"
	incr nesting
}
#
proc makePath {which s} {

	global fcols memtbl agents ofp et dual zip owners owns 
	global parent children inside  nesting init_phase timep
	global NumPath Quiet Describe

#	which is R(egular) or T(iming)
        eval lassign \$s $fcols

	if {$mid == ""} {return}

	set peri ""
	if {$zip} {
		if {[info exists inside($sendr)]} {
			set sendr $inside($sendr)
#			puts stderr "*** set sendr $sendr"
		}
		if {[info exists inside($rcvr)]} {
			set rcvr $inside($rcvr)
#			puts stderr "*** set rcvr $rcvr"
		}
		if {$zip == 2} {
		catch {set sendr $parent($sendr)}
		catch {set rcvr $parent($rcvr)}
		} else {
		if {$init_phase} {
		set sp 0
		set rp 0
		catch {set sp $parent($sendr)}
		catch {set rp $parent($rcvr)}
		if {($sp == $rcvr) || ($rp == $sendr)} {
			set efc \$[join $fcols  " \$"]
			puts stderr "efc is $efc"
			eval eval set ns \\{$efc\\} 
			puts stderr "modified record $ns"
			if {$sp} {
			upvar #0 $sp $sp
			lappend $sp $ns
			puts stderr "lappended new rec to $sp"
			} elseif {$rp != 0} {
			upvar #0 $rp $rp
			lappend $rp $ns
			puts stderr "lappended new rec to $rp"
			}

			return
		}
		}
		}
		if {$sendr == $rcvr} {return}
	}

#	puts stderr "   makePath $which : $s"

        set sqlcmd "select name from $memtbl where mid=$mid"
	set sqt $memtbl
        doSQL 1
        set mn [sybNext 1]

        set err [catch {set to   [keylget agents($rcvr)  NAME]}]
	if {$err} {
		puts stderr "can't find agents(rcvr) rcvr = $rcvr"
	}
        set from [keylget agents($sendr) NAME]
        set who ""
        catch {set who "\\n([keylget agents($ctrlr) NAME])"}

	if {$Quiet} {
		set l1 ""
		set who ""
	} else {
		set l1 "$medid/$formid/${timid}"
		if {$NumPath} {
			set l1 "$l1-$mpid"
		}
		set l1 "$l1\\n"
	}

#	which is R for a regular path, T for dotted ctrl/timing path.
	if {$which == "R"} {
# 	this is the data flow edge
#	et is M for a regular meme flow picture, else a dependency picture

        if {$et == "M"} {

	  if {$timep} {

          puts $ofp "edge \[style=solid\]\n$from -> $to \[label=\"$l1$mn\"$peri\]\;"

	  } else {

#	"who" is the controller, either blank or \\n(ctrlname)

          puts $ofp "edge \[style=solid\]\n$from -> $to \[label=\"$l1$mn$who\"$peri\]\;"

	  }

        } else {

        puts $ofp "edge \[style=solid\]\n$from -> $to \[label=\"$mpid\\n$mn\"\]\;"
        }

	} else {

        if {$who != ""} {
# the timing edge
	if {$zip} {
		if {[info exists inside($ctrlr)]} {return}
	}
	if {$timep} {
        puts $ofp "edge \[style=dotted\]\n$who -> $to \[label=\"$timid\"\]\;"
	}
        }
	}
}
#
proc stuffRef {} {

	global agents formats media timings
	global agtbl attbl fotbl metbl titbl

	set sqlcmd "select * from $attbl"
	doSQL 1
	set cols [sybCols 1]
	puts stderr $cols
	while {1} {
	set line [sybNext 1]
	if {$line == ""} {break}
	eval lassign \$line $cols
	set atypes($atype) $atdesc
	}

	set sqlcmd "select * from $agtbl"
	doSQL 1
	set cols [sybCols 1]
	puts stderr $cols
	while {1} {
	set line [sybNext 1]
	if {$line == ""} {break}
	eval lassign \$line $cols
	keylset agents($agentid) NAME [join $aname _] TYPE $atype DESC $atypes($atype) AUTH $author LANG $lang REV $rev SUMMARY $adesc
	}

	set sqlcmd "select * from $fotbl"
	doSQL 1
	set cols [sybCols 1]
	puts stderr $cols
	while {1} {
	set line [sybNext 1]
	if {$line == ""} {break}
	eval lassign \$line $cols
	set formats($formid) $format 
	}

	set sqlcmd "select * from $metbl"
	doSQL 1
	set cols [sybCols 1]
	puts stderr $cols
	while {1} {
	set line [sybNext 1]
	if {$line == ""} {break}
	eval lassign \$line $cols
	set media($medid) $medium 
	}

	set sqlcmd "select * from $titbl"
	doSQL 1
	set cols [sybCols 1]
	puts stderr $cols
	while {1} {
	set line [sybNext 1]
	if {$line == ""} {break}
	eval lassign \$line $cols
	set timings($timid) $timing 
	}

}
#
#--------------------------------MAIN-------------------------------
# If you give me a meme name, I will draw the dataflow diagram for
# that meme.
# If you call me traceagent instead, I will draw the activities of
# the specified agent(s).
#
set ta 0
set et M
set myname [file tail $argv0]
#
if {$myname == "traceagent"} {
	set ty ta
} elseif {$myname == "tracedep"} {
	set ty td
} elseif {$myname == "tracepaths"} {
	set ty tp
} elseif {$myname == "tracememe"} {
	set ty tm
} else {
	puts stderr "This can't happen:  called as $myname."
	exit 1
}
# puts stderr "set ty to $ty"
#
if {($argv == "") || ($argv == "-h")} {
	case $ty in {
	{ta} {
	puts stderr "\nUsage: traceagent <-Flags> Pcontext ListOfAgents "
	} 
	{td} {
	puts stderr "\nUsage: tracedep <-Flags> ListOfAgents "
	} 
	{tm} {
	puts stderr "\nUsage: tracememe <-Flags> memeName <Context> <Type>"
	}
	{tp} {
	puts stderr "\nUsage: tracepaths <-Flags> PContext"
	}
	}
        puts stderr "\nFlags can be any concatenation of:\n"
        puts stderr "\tC Compress (prohibit tiling)"
        puts stderr "\tT Tile (force tiling) defaults to 11x17 paper unless A"
        puts stderr "\tA A-size (force page to letter size)"
        puts stderr "\tL Landscape (force 90 degree rotate)"
        puts stderr "\tQ Quiet (show only meme name on path)"
        puts stderr "\tD Description (show agent summary as well as name)"
        puts stderr "\tN Number Paths (show Mpaths ID numbers)"
	puts stderr "\tF Print footer (title) on plot"
	exit 1
}
#
# It's actually nontrivial to make the dual of one of these pictures,
# but leave a hopeful hook here to remind ourselves that we'd like to
# do so for grins... someday.
# "zip" is just shorthand for "compress" :-)
set dual 0
set zip 0
set timep 0
set Flags ""
#
if {[cindex $argv 0] == "-"} {
	set flags [crange [lvarpop argv] 1 end]
	foreach flag [split $flags {}] {
	puts stderr "GOT A FLAG: $flag"
	if {$flag == "d"} {
		set dual 1
		puts stderr "DUAL GRAPH"
	} elseif {$flag == "c"} {
		set zip 1
		puts stderr "PARTIAL COMPRESSION"
	} elseif {$flag == "z"} {
		set zip 2
		puts stderr "TOTAL COMPRESSION"
	} elseif {$flag == "t"} {
		set timep 1
		puts stderr "SHOW TIMING PATHS"
	} else {
		append Flags $flag
	}
	}
}
#
puts stderr "zip is $zip, dual is $dual, ty is $ty"
puts stderr "Flags : $Flags"
#
# args are name, context, type
# it's possible to give just a listomids also
set pcn ""
set et M
if {$ty == "td"} {
	set et D
}
# traceagents requires a context string
if {$ty == "ta"} {
	set pc [lvarpop argv]
}
#
if {($ty == "ta") || ($ty == "td")} {
set alist $argv
if {![ctype digit [lindex $alist 0]]} {
	set where [join $alist ',']
	set sqlcmd "select agentid from $agtbl where aname in ('$where')"
	set sqt $agtbl
	set alist ""
	doSQL 1
	while {1} {
		set ai [sybNext 1]
		if {$ai == ""} {break}
		lappend alist $ai
	}
}
} elseif {$ty == "tm"} {

lassign $argv ime ct mt
# puts stderr "got args $argv"
set mlist ""
if {[ctype digit $ime]} {
	puts stderr "ime is a number, set mlist"
	set mlist $argv
}
#
if {[lempty $mlist]} {
# puts stderr "mlist is empty, go get me records by name"
set sqlcmd "select * from $memtbl where name = '$ime' and context like '$ct%' and syty like '$mt%'"
puts stderr "$sqlcmd"
doSQL 1
set sqt $memtbl
set mcols [sybCols 1]
set fc 0
while {1} {
	set line [sybNext 1]
	if {$line == ""} {break}
	lappend found "$line\n"
	incr fc
}
if {[lempty found]} {
	puts stderr "Sorry, no name by that name."
	exit 1
}
if {$fc > 1} {
	puts stderr "Sorry, there are [llength $found] memes called $ime:"
	foreach f $found {
		eval lassign \$f $mcols
		puts stderr "\t $name $context $syty : [crange $semantics 0 30]"
	}
	puts stderr "Either you need to specify a context, or there's an"
	puts stderr "ambiguity in the name database that should be fixed."
	puts stderr "Try again:"
	puts stderr "\ttracememe MWname <Context> <Type>"
	exit 1
}
set line [lvarpop found]
eval lassign \$line $mcols
}
} else {
	set pcn $argv
}
#
#
puts stderr "getting reference data"
stuffRef
puts stderr "ty is $ty after this step"
#
# process all the override flags
processFlags
#
set shapes(D) circle
set shapes(T) house
set shapes(C) diamond
set shapes(P) hexagon
set shapes(H) box
set shapes(M) box
#
set fn [lindex $argv 0]
set ofp [open $fn.dot w]
set tfp [open $et.$fn.txt w]
puts $tfp "Accompanying Document for digraph $argv0 ($et) of $argv\n"
set layout [pgLayout]
puts $ofp "digraph MemeFlow \{"
if {$Footer} {
puts $ofp "label=\"$argv0 ($et) of $argv\""
}
puts $ofp "node \[fontsize=10\]\;"
puts $ofp "edge \[fontname=Helvetica,fontsize=8\]\;"
puts $ofp "$layout"
if {$ta} {
if {$et == "M"} {
puts $ofp "rotate=90\;"
}
}
#
puts stderr "getting paths from flow table... report type $ty"
#
if {$ty == "ta"} {
set sqlcmd "select * from $mftbl where ptype = '$et' and pcontext like '$pc%' and (sendr in ([join $alist ,]) or rcvr in ([join $alist ,]) or ctrlr in ([join $alist ,]) or owner in ([join $alist ,]))"
} elseif {$ty == "td"} {
set sqlcmd "select * from $mftbl where ptype = '$et'"
} elseif {$ty == "tm"} {
if {[lempty $mlist]} {
set sqlcmd "select * from $mftbl where ptype = 'M' and ((mid = $mid) or (mid in (select tmid from $mebtbl where emid = $mid)))"
} else {
set sqlcmd "select * from $mftbl where ptype = 'M' and mid in ([join $mlist ,])"
}
} else {
puts stderr "selecting by pcontext ty is $ty"
set sqlcmd "select * from $mftbl where pcontext like '$pcn%'"
}
#
set sqt $mftbl
puts stderr "Do SQL: $sqlcmd"
doSQL 1
set fcols [sybCols 1]
#
set ags ""
set segs ""
while {1} {
	set line [sybNext 1]
	if {$line == ""} {break}
#	puts stderr "Got line $line"
	eval lassign \$line $fcols
	append ags "$sendr $rcvr $ctrlr "
	lappend segs $line
	append mes "$mid "
}
#
set ags [lrmdups $ags]
set mes [lrmdups $mes]
#
set owners ""
foreach s $segs {
	eval lassign \$s $fcols
	if {$ctrlr > 0} {
		lappend timers $s
	}
	if {$owner > 0} {
		lappend $owner $s
		puts stderr "new owner $owner for seg $s"
		lappend owners $owner
		set inside($sendr) $owner
		set inside($rcvr) $owner
		set peri($owner) 2
		continue
	}
#	puts stderr "make regular edge:"
	lappend normals $s
}
#
set owners [lrmdups $owners]
puts stderr "OWNERS: $owners"
#
# decide whether the owners are themselves owned
#
set parents ""
foreach o $owners {

	set sqlcmd "select owner from $agtbl where agentid = $o"
	set sqt $agtbl
	doSQL 1
	set so [sybNext 1]
	if {$so > 0} {
		set parent($o) $so
		puts stderr "foreach o : parent of $o is $so"
		lappend children($so) $o
		lappend parents $so
	}
}
set parents [lrmdups $parents]
puts stderr "PARENTS: $parents"
#
puts $tfp "Agents Involved:\n"
foreach a $ags {
	set err [catch {set an [keylget agents($a) NAME]}]
	if {$err} {
		puts stderr "No such agent ID $a?"
		continue
	}
	if {$zip} {
		if {[info exists inside($a)]} {continue}
	}
	set at [keylget agents($a) TYPE]
	set ad ""
	set decor ""
	if {($Describe) && ($at == "M")} {
		set ad [strFold [keylget agents($a) SUMMARY] 30]
#		puts stderr "$an : $ad"
		set ad [join $ad "\\n"]
		set decor "*"
		set ad "\\n$ad"
	}
	set aa [keylget agents($a) AUTH]
	set al [keylget agents($a) LANG]
	append anames($a) $an\n
	if {$et == "M"} {
	puts $ofp "$an \[label=\"$decor$an$decor$ad\" shape=$shapes($at)\]\;"
	} else {
	puts $ofp "$an \[label=\"$decor$an$decor$ad\\n$aa ($al)\" shape=$shapes($at)\]\;"
	}
	set str1 [format "Agent %20s type %1s" $an $at]
	set str2 ""
	if {$al != ""} {
		set str2 [format "written by %20s in %5s" $aa $al]
	}
	puts $tfp "$str1 $str2"
}
#
if {$et == "M"} {
puts $tfp "\nMemes Traced:"
	set sqlcmd "select name, units, semantics from $memtbl where mid in ([join $mes ,])"
	doSQL 1
	while {1} {
		set line [sybNext 1]
		if {$line == ""} {break}
		lassign $line me un sem
		set sem [strFold $sem 30]
		set sl [lvarpop sem]
		puts $tfp [format "%16s %10s %30s" $me $un $sl]
		foreach sl $sem {
		puts $tfp [format "%27s %30s" {} $sl]
		}
	}
	
}
foreach n $normals {
	puts stderr "make normal path..."
	makePath R $n
}
#
set init_phase 0
#
# and now the owners... start recursion only at the topmost level, good luck!
#
if {[llength $parents] > 0} {
	puts stderr "There are parents: $parents"
	foreach so [array names children] {
		if {[info exists owner($so)]} {continue}
		puts stderr "Make paths for owner $so : makeSub"
		makeSub $so
	}
} else {
	foreach o $owners {
		makeSub $o
	}
}
#
foreach t $timers {
	makePath T $t
}
#
if {$zip} {
set nd [expr ($nesting - $minn) + 2]
puts stderr "Nesting depth was $nd which is nesting $nesting - minn $minn + 2"
foreach a [lrmdups "$owners $parents"] {
	if {$zip == 2} {
	if {[info exists parent($a)]} {puts stderr "SKIP $a"; continue}
	}
	set err [catch {set an [keylget agents($a) NAME]}]
	if {$err} {
		puts stderr "No such agent ID $a"
		continue
	}
	set ap ""
	catch {set ap [expr $nd - ($nesting - $peri($a))]}
	puts stderr "$nd - ($nesting - $peri($a)) = $ap"
	if {$ap != ""} {
		puts $ofp "$an \[peripheries=$ap\]\;"
	}
}
}
#
puts $ofp "\}"
close $ofp
#
puts $tfp "\nOutput is in $et.$fn.ps"
close $tfp
system "dot -Tps $fn.dot > $et.$fn.ps"
puts stderr "Output is in $et.$fn.ps"
#
