#!/opt0/tcl/bin/sytcl
#/usr/local/tcl74/bin/dbtcl
#
# set tclroot /usr/local/tcl74
set tclroot /opt0/share/tcl
set ucodb $tclroot/lib/ucodb
loadlibindex $ucodb/ucodb.tlib
loadlibindex $ucodb/memes.tlib
# loadlibindex ../memes.tlib
#
set dbpipe1 [sybOpen keck guest rsvp UCO-ASTRO]
# puts stderr "got dbpipe $dbpipe1"
#
global sybmsg
set efp [open mes.log w]
#
set memtbl keck.dbo.Memes
set mebtbl keck.dbo.Mbundles
set mcotbl keck.dbo.Mcontexts
set maptbl keck.dbo.Mmaps
#
#
proc drawMeme m {

	global collected elements parentage ofp elinfo shapes CTR

	set err [catch {set mn [keylget collected($m) name]}]
	if {$err} {
		puts stderr "No bundle ID $m was collected OOPS"
		continue
	}
	lappend mnames $mn
	set mc [keylget collected($m) context]
	set mt [keylget collected($m) syty]
	set isa [keylget collected($m) isa_mid]
	set map [keylget collected($m) map_mid]
	set rpt [keylget collected($m) rpt_mid]
	set ctr [keylget collected($m) ctrl_mid]
	if {$isa == ""} {set isa 0}
	if {$map == ""} {set map 0}
	if {$ctr == ""} {set ctr 0}
	if {$rpt == ""} {set rpt 0}

	case $mt in {
	{header} {set mty "hdr "}
	{table}	 {set mty "tbl "}
	{tuple}  {set mty "tpl "}
	{map}  {set mty "map "}
	{schema}  {set mty "sch "}
	{file}  {set mty "fil "}
	{default} {set mty ""}
	}

	puts stderr "Got Meme $mn $m ($mt) make a node"
	set mo ""
	set mp ""
	if {[info exists parentage($m)]} {
		lassign $parentage($m) mp mo
		set mo "($mo)"
		set pn "[keylget collected($mp) name]:"
	}

	set shape "box"
	catch {set shape $shapes($mt)}
	if {[lsearch $CTR $m] >= 0} {
		set shape $shapes(ctr)
	}
	if {$mp != ""} {
	puts $ofp "N$m \[label=\"$mty$mn $mo\" shape=$shape\]\;"
	puts $ofp "edge \[style=solid\]\nN$mp -> N$m\;"
	} else {
	puts $ofp "N$m \[label=\"$mty$mn\" shape=$shape\]\;"
	}

	if {$isa} {
	puts stderr "N$m $mn ISA $isa, draw a line to N$isa"
	puts $ofp "edge \[style=dotted\]\nN$m -> N$isa \[label=\"ISA \"\]\;"
	}
	if {$map} {
	puts stderr "N$m $mn MAP $map, draw a line to N$map"
	puts $ofp "edge \[style=dotted\]\nN$m -> N$map \[label=\"MAP \"\]\;"
	}
	if {$rpt} {
	if {!$isa} {
		puts stderr "ERROR rpt without isa in N$m"
	} else {
		puts stderr "N$m $mn RPT $rpt, draw a line to N$rpt"
		puts $ofp "edge \[style=dotted\]\nN$rpt -> N$isa \[label=\"RPT \"\]\;"
	}
	}
	if {$ctr != 0} {
	puts stderr "N$m $mn MAP $ctr, draw a line to N$ctr"
	foreach c $ctr {
	puts $ofp "edge \[style=dotted\]\nN$c -> N$m \[label=\"CTR \"\]\;"
	}
	}

#	I think this is obsolete now... but don't toss it yet
	set contents ""
	if {[info exists elements($m)]} {
	foreach e $elements($m) {
		set em [keylget elinfo($e) emid]
		set eo [keylget elinfo($e) ordr]
		set en [keylget collected($em) name]
		set eis [keylget collected($em) isa_mid]
		set ema [keylget collected($em) map_mid]
		set in ""
		catch {set in [keylget collected($eis) name]}
		set mmn ""
		catch {set mmn [keylget collected($ema) name]}
		append contents "$en ($eo) "
		if {$isa} {
		append contents "ISA $in "
		} 
		if {$map} {
		append contents "MAP $mmn "
		}
		append contents "\\n"
#
#		drawMeme $e
	}
	}

#	if {$contents != ""} {
#	puts $ofp "N${m}_Contents \[label=\"$contents\" shape=box\]\;"
#	puts $ofp "edge \[style=solid\]\nN$m -> N${m}_Contents \[label=\"$en\"\]\;"
#	}
}
#--------------------------------MAIN-------------------------------
# If you give me a meme name, I will draw the structure diagram for
# that meme, be it header or whatever...
#
if {[llength $argv] == 0} {
	puts stderr "Usage: memestruct memeName ?Context? ?Type?"
	exit 0
}
lassign $argv ime ct ty
#
if {[ctype digit $ime]} {
set sqlcmd "select * from $memtbl where mid = $ime"
} else {
if {$ct != ""} {
set sqlcmd "select * from $memtbl where name = '$ime' and context = '$ct' and syty like '$ty%'"
} else {
set sqlcmd "select * from $memtbl where name = '$ime' and syty like '$ty%'"
}
}
doSQL 1
set sqt $memtbl
set mcols [sybCols 1]
set fc 0
set found ""
while {1} {
	set line [sybNext 1]
	if {$line == ""} {break}
	lappend found "$line\n"
	incr fc
}
if {!$fc} {
	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 "\tmemestruct MWname <Context> <Type>"
	exit 1
}
set line [lvarpop found]
eval lassign \$line $mcols
set master $mid
#
set BundTypes ""
set BTcodes ""
set sqlcmd "select distinct syty from $memtbl where mid in (select distinct tmid from $mebtbl)"
set sqt "$memtbl $mebtbl"
doSQL 1
while {1} {
        set t [sybNext 1]
        if {$t == ""} {break}
        lappend BundTypes $t
        lappend BTcodes [string toupper [crange $t 0 3]]
}
#
puts stderr "Found tuple types $BundTypes"
puts stderr "Therefore BTcodes is $BTcodes"
#
set shapes(header) house
set shapes(file) house
set shapes(table) box
set shapes(schema) box
set shapes(tuple) hexagon
set shapes(ctr) circle
set shapes(map) diamond
set shapes(other) box
#
set fn [lindex $argv 0]
set ofp [open $fn.dot w]
puts $ofp "digraph MemeStruct \{"
puts $ofp "size=\"7.5,10\""
puts $ofp "ratio=compress"
# puts $ofp "rotate=90"
puts $ofp "label=\"$argv0 of $argv\""
puts $ofp "node \[fontsize=10\]\;"
puts $ofp "edge \[fontname=Helvetica,fontsize=8\]\;"
#
puts stderr "getting memes..."
#
set mlist "$mid"
#
collectMemes $mlist
puts stderr "CTRs: $CTR"
#
set bundles [array names elements]
foreach m $bundles {
	foreach e $elements($m) {
		set em [keylget elinfo($e) emid]
		set eo [keylget elinfo($e) ordr]
		set parentage($em) "$m $eo"
		puts stderr "$em is element $eo of meme $m"
	}
}
set mnames ""
set ms [lrmdups [array names collected]]
foreach m $ms {
drawMeme $m
}
#
puts $ofp "\}"
close $ofp
#
system "dot -Tps $fn.dot > $fn.ps"
puts stderr "Output is in $fn.ps"
#
close $efp
