yarrg/yppedia-chart-parser

   1 #!/usr/bin/perl
   2
   3 use strict (qw(vars));
   4 use warnings;
   5
   6 use Graph::Undirected;
   7 use Commods;
   8 use CommodsDatabase;
   9
  10 my $ocean= 'Midnight';
  11
  12
  13 my $widists= Graph::Undirected->new();
  14 my $wiarchs= Graph::Undirected->new();
  15 my $wispr;
  16 my $dbspr;
  17 my @wiarchlabels;
  18 my %wiisland2node;
  19 my %winode2island;
  20 my %winode2lines;
  21 my %wiccix2arch;
  22 my $wialldists;
  23
  24 my $dbdists= Graph::Undirected->new();
  25 my %dbisland2arch;
  26
  27 my %msgs;
  28 sub pmsg ($$) { push @{ $msgs{$_[0]} }, "$_[0]: $_[1]\n"; }
  29 sub warning ($) { pmsg("warning",$_[0]); }
  30 sub error   ($) { pmsg("error",  $_[0]); }
  31 sub change  ($) { pmsg("change", $_[0]); }
  32 sub print_messages () {
  33     foreach my $k (qw(change warning error)) {
  34         my $m= $msgs{$k};
  35         next unless $m;
  36         print sort @$m or die $!;
  37     }
  38 }
  39
  40 if (@ARGV && $ARGV[0] eq '--debug') {
  41     shift @ARGV;
  42     open DEBUG, ">&STDOUT" or die $!;
  43     select(DEBUG); $|=1;
  44 } else {
  45     open DEBUG, ">/dev/null" or die $!;
  46 }
  47 select(STDOUT); $|=1;
  48
  49 my $parity;
  50 sub nn_xy ($$) {
  51     my ($x,$y) = @_;
  52     my $tp= (0+$x ^ 0+$y) & 1;
  53     defined $parity or $parity=$tp;
  54     $tp==$parity or warning("line $.: parity error $x,$y is $tp not $parity");
  55     my $n= "$_[0],$_[1]";
  56     $winode2lines{$n}{$.}++;
  57     return $n;
  58 }
  59
  60 sub yppedia_chart_parse () {
  61     # We don't even bother with tag soup; instead we do line-oriented parsing.
  62
  63     while (<>) {
  64         s/\<--.*--\>//g;
  65         s/^\s*//; chomp; s/\s+$//; s/\s+/ /g;
  66         s/\<\/?(?:b|em)\>//g;
  67         s/\{\{Chart\ style\|[^{}]*\}\}//g;
  68         next unless m/\{\{/; # only interested in chart template stuff
  69
  70         my ($x,$y, $arch,$island,$solid,$dirn);
  71         my $nn= sub { return nn_xy($x,$y) };
  72
  73         if (($x,$y,$arch) =
  74             m/^\{\{ chart\ label \|(\d+)\|(\d+)\| .*
  75                     \'\[\[ [^][\']* \| (\S+)\ archipelago \]\]\'*\}\}$/xi) {
  76             printf DEBUG "%2d,%-2d arch %s\n", $x,$y,$arch;
  77             push @wiarchlabels, [ $x,$y,$arch ];
  78         } elsif (($x,$y,$island) =
  79             m/^\{\{ chart\ island\ icon \|(\d+)\|(\d+)\|
  80                     ([^| ][^|]*[^| ]) \| .*\}\}$/xi) {
  81             my $n= $nn->();
  82             $wiisland2node{$island}= $n;
  83             $winode2island{$n}= $island;
  84             $widists->add_vertex($n);
  85             $wiarchs->add_vertex($n);
  86             printf DEBUG "%2d,%-2d island %s\n", $x,$y,$island;
  87         } elsif (($solid,$x,$y,$dirn) =
  88             m/^\{\{ chart\ league((?:\ solid)?) \|(\d+)\|(\d+)\|
  89                     ([-\/\\o]) \| .*\}\}$/xi) {
  90             next if $dirn eq 'o';
  91
  92             my ($bx,$by) = ($x,$y);
  93             if ($dirn eq '-') { $bx+=2; }
  94             elsif ($dirn eq '\\') { $bx++; $by++; }
  95             elsif ($dirn eq '/') { $x++; $by++; }
  96             else { die; }
  97
  98             my $nb= nn_xy($bx,$by);
  99             $widists->add_weighted_edge($nn->(), $nb, 1);
 100             $wiarchs->add_edge($nn->(), $nb) if $solid;
 101             $wiarchs->add_edge($nn->(), $nb) if $solid;
 102
 103             printf DEBUG "%2d,%-2d league %-6s %s %s\n", $x,$y,
 104                 $solid?'solid':'dotted', $dirn, $nb;
 105         } elsif (
 106             m/^\{\{ chart\ head \}\}$/xi
 107                  ) {
 108             next;
 109         } else {
 110             warning("line $.: ignoring incomprehensible: $_");
 111         }
 112     }
 113 }
 114
 115 sub database_fetch_ocean () {
 116     my ($row,$sth);
 117     $sth= $dbh->prepare('SELECT islandname, archipelago FROM islands');
 118     $sth->execute();
 119     while ($row= $sth->fetchrow_hashref) {
 120         print DEBUG "database-island $row->{'islandname'}".
 121                      " $row->{'archipelago'}\n";
 122         $dbisland2arch{$row->{'islandname'}}= $row->{'archipelago'};
 123     }
 124     $sth= $dbh->prepare('SELECT dist, a.islandname a, b.islandname b
 125                                 FROM dists
 126                                 JOIN islands AS a ON dists.aiid==a.islandid
 127                                 JOIN islands AS b ON dists.biid==b.islandid');
 128     $sth->execute();
 129     while ($row= $sth->fetchrow_hashref) {
 130         $dbdists->add_weighted_edge($row->{'a'}, $row->{'b'}, $row->{'dist'});
 131     }
 132 }
 133
 134 sub database_graph_spr () {
 135     $dbspr= shortest_path_reduction('db',$dbdists);
 136 }
 137
 138 sub yppedia_graphs_add_shortcuts () {
 139     # We add edges between LPs we know about, as you can chart
 140     # between them.  Yppedia often lacks these edges.
 141     #
 142     foreach my $p ($widists->vertices) {
 143         my ($ax,$ay) = $p =~ m/^(\d+)\,(\d+)$/ or die;
 144         my $add_shortcut= sub {
 145             my $q= sprintf "%d,%d", $ax+$_[0], $ay+$_[1];
 146             return unless $widists->has_vertex($q);
 147             return if $widists->has_edge($p,$q);
 148             printf DEBUG "%-5s league-shortcut %-5s\n", $p, $q;
 149             $widists->add_weighted_edge($p,$q,1);
 150         };
 151         $add_shortcut->( 2,0);
 152         $add_shortcut->(+1,1);
 153         $add_shortcut->(-1,1);
 154     }
 155 }
 156
 157 sub yppedia_graphs_prune_boring () {
 158     # Prune the LP database by eliminating boring intermediate vertices
 159     foreach my $delete ($widists->vertices()) {
 160         next if exists $winode2island{$delete};
 161         my @neigh= $widists->neighbours($delete);
 162         next unless @neigh==2;
 163         my $weight= 0;
 164         map { $weight += $widists->get_edge_weight($delete, $_) } @neigh;
 165         $widists->add_weighted_edge(@neigh, $weight);
 166         $widists->delete_vertex($delete);
 167         printf DEBUG "%-5s elide %5s %-5s %2d\n", $delete, @neigh, $weight;
 168     }
 169 }
 170
 171 sub yppedia_graphs_check () {
 172     # Check that it's connected.
 173     foreach my $cc ($widists->connected_components()) {
 174         next if 2*@$cc > $widists->vertices();
 175         my $m= "disconnected league point(s):";
 176         foreach my $n (@$cc) {
 177             $m .= "\n    LP $n, def. yppedia line(s): ".
 178                 join(',', sort keys %{ $winode2lines{$n} });
 179         }
 180         warning($m);
 181     }
 182 }
 183
 184 sub yppedia_archs_sourceinfo () {
 185     # Assign archipelagoes according to the source-info file
 186     foreach my $arch (sort keys %{ $oceans{$ocean} }) {
 187         foreach my $islename (sort keys %{ $oceans{$ocean}{$arch} }) {
 188             my $islenode= $wiisland2node{$islename};
 189             defined $islenode or
 190                 error("island $islename in source-info but not in WP map");
 191             my $ccix= $wiarchs->connected_component_by_vertex($islenode);
 192             my $oldarch= $wiccix2arch{$ccix};
 193             error("island $islename in $arch in source-info".
 194                   " connected to $oldarch as well")
 195                 if defined $oldarch && $oldarch ne $arch;
 196             printf DEBUG "%-5s force-island-arch cc%-2d %-10s %s\n",
 197                 $islenode, $ccix, $arch, $islename;
 198             $wiccix2arch{$ccix}= $arch;
 199         }
 200     }
 201 }
 202
 203 sub yppedia_archs_chart_labels () {
 204     # Assign archipelago labels to groups of islands
 205     #
 206     foreach my $label (@wiarchlabels) {
 207         my ($ax,$ay,$arch) = @$label;
 208         my $best_ccmulti= -1;
 209         my $best_d2= 0;
 210         my $best_n;
 211 #       print DEBUG "$ax,$ay arch-island-search $arch\n";
 212         $ay += 1;  $ax += 2;  # coords are rather to the top left of label
 213         foreach my $vertex ($wiarchs->vertices()) {
 214             next unless exists $winode2island{$vertex};
 215             my $ccix= $wiarchs->connected_component_by_vertex($vertex);
 216             my @cc= $wiarchs->connected_component_by_index($ccix);
 217             my $ccmulti= @cc > 1;
 218             my ($vx,$vy) = split /,/, $vertex;
 219             my $d2= ($vx-$ax)*($vx-$ax) + ($vy-$ay)*($vy-$ay);
 220             my $cmp= $ccmulti <=> $best_ccmulti
 221                 ||   $best_d2 <=> $d2;
 222             printf DEBUG "%2d,%-2d arch-island-search %5s d2=%4d cc%-2d".
 223                          " #cc=%2d ccmulti=%d cmp=%2d %s\n",
 224                 $ax,$ay, $vertex, $d2, $ccix, scalar(@cc), $ccmulti, $cmp,
 225                 $winode2island{$vertex};
 226             next unless $cmp > 0;
 227             $best_n=       $vertex;
 228             $best_d2=      $d2;
 229             $best_ccmulti= $ccmulti;
 230         }
 231         die 'no island vertices?!' unless defined $best_n;
 232         my $ccix= $wiarchs->connected_component_by_vertex($best_n);
 233         printf DEBUG
 234             "%2d,%-2d arch-island-select %-5s d2=%4d cc%-2d     %-10s %s\n",
 235             $ax,$ay, $best_n, $ccix, $best_d2, $arch, $winode2island{$best_n};
 236         my $desc= join "\n", map {
 237             my $in= $winode2island{$_};
 238             "    LP $_". (defined $in ? ", $in" : "");
 239         } sort $wiarchs->connected_component_by_index($ccix);
 240
 241         if (exists $wiccix2arch{$ccix} and $wiccix2arch{$ccix} ne $arch) {
 242             error("archipelago determination failed, wrongly merged:\n".
 243                   "    archipelago $arch\n".
 244                   "    archipelago $wiccix2arch{$ccix}\n".
 245                   $desc);
 246             next;
 247         }
 248         $wiccix2arch{$ccix}= $arch;
 249 #       print "$ccix $arch ::\n$desc\n";
 250     }
 251 }
 252
 253 sub yppedia_archs_fillbynearest() {
 254     # Assign islands not labelled above to archipelagoes.
 255     #
 256     # We do this by, for each connected component (set of islands
 257     # linked by purchaseable charts), searching for the nearest other
 258     # connected component which has already been assigned an arch.
 259     # `Nearest' means shortest distance of unpurchaseable charts, in
 260     # leagues.
 261     #
 262     # we need only consider vertices which weren't `boring intermediate
 263     # vertices' (removed during optimisation as being of order 2)
 264     my @ccs_useful= map {
 265         [ grep { $widists->has_vertex($_) } @$_ ]
 266     } $wiarchs->connected_components();
 267
 268     my @assignments;
 269
 270     foreach my $sourceccix (0..$#ccs_useful) {
 271         next if defined $wiccix2arch{$sourceccix};
 272         next unless $ccs_useful[$sourceccix];
 273
 274         my @sourcecc= $wiarchs->connected_component_by_index($sourceccix);
 275         my @islandnodes= grep { $winode2island{$_} } @sourcecc;
 276         next unless @islandnodes; # don't care, then
 277
 278         foreach my $islandnode (@islandnodes) {
 279             printf DEBUG "%-5s arch-join-need cc%-2d             %s\n",
 280                 $islandnode, $sourceccix, $winode2island{$islandnode};
 281         }
 282         my $best_dist= 9999999;
 283         my ($best_target, $best_targetccix, $best_source);
 284         foreach my $targetccix (0..$#ccs_useful) {
 285             next unless defined $wiccix2arch{$targetccix}; # not helpful
 286             next unless $ccs_useful[$targetccix];
 287             foreach my $target ($wiarchs->
 288                          connected_component_by_index($targetccix)) {
 289                 next unless $widists->has_vertex($target);
 290                 foreach my $source (@sourcecc) {
 291                     my $target_dist= widist($target,$source);
 292                     next unless defined $target_dist;
 293                     next if $target_dist >= $best_dist;
 294                     $best_dist= $target_dist;
 295                     $best_source= $source;
 296                     $best_target= $target;
 297                     $best_targetccix= $targetccix;
 298                 }
 299             }
 300         }
 301         die "no possible target ?!" unless defined $best_target;
 302
 303         my $arch= $wiccix2arch{$best_targetccix};
 304         my $best_island= $winode2island{$best_target};
 305         printf DEBUG "%-5s arch-join-to %-5s dist=%2d cc%-2d  %-10s %s\n",
 306             $best_source, $best_target, $best_dist,
 307             $best_targetccix, $arch,
 308             defined($best_island) ? $best_island : "-";
 309
 310         push @assignments, [ $sourceccix, $arch ];
 311     }
 312     foreach my $assign (@assignments) {
 313         $wiccix2arch{$assign->[0]}= $assign->[1];
 314     }
 315 }
 316
 317 sub yppedia_graph_shortest_paths () {
 318     $wialldists= $widists->APSP_Floyd_Warshall();
 319 }
 320
 321 sub widist ($$) {
 322     my ($p,$q) = @_;
 323     my $pl= $wialldists->path_length($p,$q);
 324 #    die "$p $q" unless defined $pl;
 325 #    my @pv= $wialldists->path_vertices($p,$q);
 326 #    if (@pv == $pl) { return $pl; }
 327 #   printf DEBUG "%-5s PATHLENGTH %-5s pl=%s pv=%s\n", $p,$q,$pl,join('|',@pv);
 328     return $pl;
 329 }
 330
 331 sub winode2arch ($) {
 332     my ($node) = @_;
 333     my $ccix= $wiarchs->connected_component_by_vertex($node);
 334     return $wiccix2arch{$ccix};
 335 }
 336 sub wiisland2arch ($) {
 337     my ($island) = @_;
 338     my $node= $wiisland2node{$island};
 339     die "$island ?" unless defined $node;
 340     return winode2arch($node);
 341 }
 342
 343 sub compare_island_lists () {
 344     foreach my $island (sort keys %dbisland2arch) {
 345         my $node= $wiisland2node{$island};
 346         if (!defined $node) {
 347             error("would delete island: $island");
 348             next;
 349         }
 350         my $wiarch= winode2arch($node);
 351         if (!defined $wiarch) {
 352             error("island has no arch: $island");
 353             next;
 354         }
 355         my $dbarch= $dbisland2arch{$island};
 356         if ($wiarch ne $dbarch) {
 357             change("change archipelago from $dbarch to $wiarch".
 358                    " for island $island");
 359         }
 360     }
 361     foreach my $island (sort keys %wiisland2node) {
 362         my $dbarch= $dbisland2arch{$island};
 363         if (!defined $dbarch) {
 364             my $wiarch= wiisland2arch($island);
 365             if (!defined $wiarch) {
 366                 error("new island has no arch: $island");
 367                 next;
 368                 # We check arches of non-new islands above
 369             }
 370             change("new island in $wiarch: $island");
 371         }
 372     }
 373 }
 374
 375 sub shortest_path_reduction ($$) {
 376     my ($what,$base) = @_;
 377     printf DEBUG "spr %s before %d\n", $what, scalar($base->edges());
 378
 379     my $result= Graph::Undirected->new();
 380     foreach my $edge_ac ($base->edges()) {
 381         my $edgename_ac= join '..', @$edge_ac;
 382         printf DEBUG "spr %s edge %s\n", $what, $edgename_ac;
 383         my $w_ac= $base->get_edge_weight(@$edge_ac);
 384         my $needed= 1;
 385         foreach my $vertex_b ($base->vertices()) {
 386             next if grep { $_ eq $vertex_b } @$edge_ac;
 387             my $w_ab= $base->get_edge_weight($edge_ac->[0], $vertex_b);
 388             next unless defined $w_ab;
 389             next if $w_ab >= $w_ac;
 390             my $w_bc= $base->get_edge_weight($vertex_b, $edge_ac->[1]);
 391             next unless defined $w_ac;
 392             next if $w_ab + $w_bc > $w_ac;
 393             # found path
 394             printf DEBUG "spr %s edge %s unnecessary %s\n",
 395                 $what, $edgename_ac, $vertex_b;
 396             $needed= 0;
 397             last;
 398         }
 399         if ($needed) {
 400             printf DEBUG "spr %s edge %s essential\n", $what, $edgename_ac;
 401             $result->add_weighted_edge(@$edge_ac,$w_ac);
 402         }
 403     }
 404     printf DEBUG "spr %s result %d\n", $what, scalar($result->edges());
 405
 406     my $apsp= $result->APSP_Floyd_Warshall();
 407     foreach my $ia (sort $base->vertices()) {
 408         foreach my $ib (sort $base->vertices()) {
 409             my $din= $base->get_edge_weight($ia,$ib);
 410             my $dout= $apsp->path_length($ia,$ib);
 411             $din= defined($din) ? $din : 'infinity';
 412             $dout= defined($dout) ? $dout : 'infinity';
 413             error("$what spr apsp discrepancy in=$din out=$dout for $ia..$ib")
 414                 if $din != $dout;
 415         }
 416     }
 417     return $result;
 418 }
 419
 420 sub yppedia_graph_spr () {
 421     my $base= Graph::Undirected->new();
 422     foreach my $na (sort keys %winode2island) {
 423         my $ia= $winode2island{$na};
 424         foreach my $nb (sort keys %winode2island) {
 425             my $ib= $winode2island{$nb};
 426             $base->add_weighted_edge($ia,$ib, widist($na,$nb));
 427         }
 428     }
 429     $wispr= shortest_path_reduction('wi',$base);
 430 }
 431
 432 sub compare_distances () {
 433     foreach my $ia (sort keys %dbisland2arch) {
 434         my $na= $wiisland2node{$ia};
 435         next unless defined $na;
 436         foreach my $ib (sort keys %dbisland2arch) {
 437             next unless $ia le $ib; # do every pair only once
 438             my $dbdist= $dbspr->get_edge_weight($ia,$ib);
 439             my $widist= $wispr->get_edge_weight($ia,$ib);
 440             next unless defined $dbdist || defined $widist;
 441
 442             if (!defined $widist) {
 443                 warning(sprintf "route delete %2d for %s..%s",
 444                         $dbdist, $ia,$ib);
 445             } elsif (!defined $dbdist) {
 446                 change(sprintf "route create %2d for %s..%s",
 447                        $widist, $ia,$ib);
 448             } elsif ($dbdist != $widist) {
 449                 change(sprintf "route change %2d to %2d for %s..%s",
 450                        $dbdist, $widist, $ia,$ib);
 451             }
 452         }
 453     }
 454 }
 455
 456 parse_info_serverside();
 457
 458 print "reading database\n";
 459
 460 db_setocean($ocean);
 461 db_connect();
 462 database_fetch_ocean();
 463
 464 print "computing database spr\n";         database_graph_spr();
 465
 466 print "reading yppedia chart\n";          yppedia_chart_parse();
 467 print "adding shortcuts\n";               yppedia_graphs_add_shortcuts();
 468 print "pruning boring vertices\n";        yppedia_graphs_prune_boring();
 469 print "checking yppedia graphs\n";        yppedia_graphs_check();
 470 print "setting archs from source-info\n"; yppedia_archs_sourceinfo();
 471 print "computing shortest paths\n";       yppedia_graph_shortest_paths();
 472 print "setting archs from labels\n";      yppedia_archs_chart_labels();
 473 print "setting archs from nearby\n";      yppedia_archs_fillbynearest();
 474 print "computing yppedia spr\n";          yppedia_graph_spr();
 475
 476 print "comparing\n";
 477
 478 compare_island_lists();
 479 compare_distances();
 480
 481 print_messages();