Skip to content
Branch: master
Find file Copy path
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
executable file 152 lines (120 sloc) 4.14 KB
# creates digraphs from XML files
# --img: create images (which can be VERY large, so not done by default)
# Changed 8 Aug 2010 to use same coords as conquerclub does -- this
# makes the program much duller, but makes the maps better (hopefully)
# TODO: does NOT include bombards
require "";
# TODO: prevent nodes from getting too close to each other
# TODO: choose edge colors better
# TODO: if two nodes share first 12 chars, find way to differentiate
# TODO: doesn't work foriegn characters
# TODO: this does NOT work w/ multiple files -- loop doesn't to end!
for $file (@ARGV) {
# should end in xml
unless ($file=~/\.xml$/i) {warn "$file doesn't end in .xml";}
# base filename for outfile
$outfile = $file;
# get content
# find/remove all continents (even if we don't want them, the next regex
# match doesn't work unless I do this)
# better way to do below?
while ($all=~s%<continent>(.*?)</continent>%%is) {push(@cont,$1);}
# now all territories (could use loop w/ continent?)
while ($all=~s%<territory>(\s*<name>\s*.*?\s*</name>.*?)</territory>%%is) {push(@terr,$1);}
# for each territory, find name and borders and create connection map
for $i (@terr) {
debug("TERR: $i");
# name (remove quotes)
debug("NAME: $name");
debug("NAME2: $name");
# record for mathematica
# get default position (small map) and push
$x/=72; $y/=72;
# if more than 12 chars, truncate for printing only
$pname = $name;
if (length($name)>=12) {$pname=substr($name,0,11)."...";}
push(@nodes, qq%"$name" [pos="$x,-$y",label="$pname"]%);
# and borders
# connection map
for $j (@bor) {
# TODO: hideously ugly repeat code here
$jclean = unidecode($j);
$EDGE{$name}{$jclean} = 1;
# build up graphviz style graph
for $i (keys %EDGE) {
# set color based on point
while ($hue>1) {$hue--;}
for $j (keys %{$EDGE{$i}}) {
# if birectional, note so + remove other direction
# TODO: code is getting quite redundant -- there's a better way to do this!
if ($EDGE{$j}{$i}) {
delete $EDGE{$j}{$i};
push(@dot,qq%"$i" -- "$j" [dir="both",color="$hue,1,1"]%);
# for mathematica, need both edges
# TODO: mathematica code not working -- nodes must be intergers?
# for networkx need both (and no spaces sigh)
($neti, $netj) = ($i,$j);
push(@netx,"$neti $netj");
push(@netx,"$netj $neti");
} else {
# otherwise straight arrow (or one dir for mathematica)
push(@dot,qq%"$i" -- "$j" [dir="forward",color="$hue,1,1"]%);
($neti, $netj) = ($i,$j);
push(@netx,"$net $netj");
# and print
print A "graph x {\n";
print A join("\n",@nodes),"\n",join("\n",@dot);
print A "\n}\n";
# mathematica version
# $verts = join(",\n",@names);
$edges = join(",\n",@math);
# TODO: using nodes as temp variable below is probably bad
print A << "MARK";
g["$outfile"] = {$edges};
nodes = DeleteDuplicates\@Flatten[g["$outfile"] /. Rule -> List]
g["$outfile"] = {$edges};
Table[numify["$outfile"][nodes[[n]]] = n, {n,1,Length[nodes]}]
Table[namify["$outfile"][n] = nodes[[n]], {n,1,Length[nodes]}]
graph["$outfile"] = FromOrderedPairs[g["$outfile"] /. s_String -> numify["$outfile"][s]]
# networkx
print A join("\n",@netx);
print A "\n";
system("neato -Nheight=0.12 -Nwidth=0.65 -Nfixedsize=true -Nshape=box -Nfontsize=8 -Earrowsize=0.33 -Gnslimit=100 -Gmclimit=100 -Gsplines=true -Tpng $ > $outfile.png");
You can’t perform that action at this time.