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 sub progress ($) { print "($_[0])\n"; }
  40
  41 if (@ARGV && $ARGV[0] eq '--debug') {
  42     shift @ARGV;
  43     open DEBUG, ">&STDOUT" or die $!;
  44     select(DEBUG); $|=1;
  45 } else {
  46     open DEBUG, ">/dev/null" or die $!;
  47 }
  48 select(STDOUT); $|=1;
  49
  50 my $parity;
  51 sub nn_xy ($$) {
  52     my ($x,$y) = @_;
  53     my $tp= (0+$x ^ 0+$y) & 1;
  54     defined $parity or $parity=$tp;
  55     $tp==$parity or warning("line $.: parity error $x,$y is $tp not $parity");
  56     my $n= "$_[0],$_[1]";
  57     $winode2lines{$n}{$.}++;
  58     return $n;
  59 }
  60
  61 sub yppedia_chart_parse () {
  62     # We don't even bother with tag soup; instead we do line-oriented parsing.
  63
  64     while (<>) {
  65         s/\<--.*--\>//g;
  66         s/^\s*//; chomp; s/\s+$//; s/\s+/ /g;
  67         s/\<\/?(?:b|em)\>//g;
  68         s/\{\{Chart\ style\|[^{}]*\}\}//g;
  69         next unless m/\{\{/; # only interested in chart template stuff
  70
  71         my ($x,$y, $arch,$island,$solid,$dirn);
  72         my $nn= sub { return nn_xy($x,$y) };
  73
  74         if (($x,$y,$arch) =
  75             m/^\{\{ chart\ label \|(\d+)\|(\d+)\| .*
  76                     \'\[\[ [^][\']* \| (\S+)\ archipelago \]\]\'*\}\}$/xi) {
  77             printf DEBUG "%2d,%-2d arch %s\n", $x,$y,$arch;
  78             push @wiarchlabels, [ $x,$y,$arch ];
  79         } elsif (($x,$y,$island) =
  80             m/^\{\{ chart\ island\ icon \|(\d+)\|(\d+)\|
  81                     ([^| ][^|]*[^| ]) \| .*\}\}$/xi) {
  82             my $n= $nn->();
  83             $wiisland2node{$island}= $n;
  84             $winode2island{$n}= $island;
  85             $widists->add_vertex($n);
  86             $wiarchs->add_vertex($n);
  87             printf DEBUG "%2d,%-2d island %s\n", $x,$y,$island;
  88         } elsif (($solid,$x,$y,$dirn) =
  89             m/^\{\{ chart\ league((?:\ solid)?) \|(\d+)\|(\d+)\|
  90                     ([-\/\\o]) \| .*\}\}$/xi) {
  91             next if $dirn eq 'o';
  92
  93             my ($bx,$by) = ($x,$y);
  94             if ($dirn eq '-') { $bx+=2; }
  95             elsif ($dirn eq '\\') { $bx++; $by++; }
  96             elsif ($dirn eq '/') { $x++; $by++; }
  97             else { die; }
  98
  99             my $nb= nn_xy($bx,$by);
 100             $widists->add_weighted_edge($nn->(), $nb, 1);
 101             $wiarchs->add_edge($nn->(), $nb) if $solid;
 102             $wiarchs->add_edge($nn->(), $nb) if $solid;
 103
 104             printf DEBUG "%2d,%-2d league %-6s %s %s\n", $x,$y,
 105                 $solid?'solid':'dotted', $dirn, $nb;
 106         } elsif (
 107             m/^\{\{ chart\ head \}\}$/xi
 108                  ) {
 109             next;
 110         } else {
 111             warning("line $.: ignoring incomprehensible: $_");
 112         }
 113     }
 114 }
 115
 116 sub database_fetch_ocean () {
 117     my ($row,$sth);
 118     $sth= $dbh->prepare('SELECT islandname, archipelago FROM islands');
 119     $sth->execute();
 120     while ($row= $sth->fetchrow_hashref) {
 121         print DEBUG "database-island $row->{'islandname'}".
 122                      " $row->{'archipelago'}\n";
 123         $dbisland2arch{$row->{'islandname'}}= $row->{'archipelago'};
 124     }
 125     $sth= $dbh->prepare('SELECT dist, a.islandname a, b.islandname b
 126                                 FROM dists
 127                                 JOIN islands AS a ON dists.aiid==a.islandid
 128                                 JOIN islands AS b ON dists.biid==b.islandid');
 129     $sth->execute();
 130     while ($row= $sth->fetchrow_hashref) {
 131         $dbdists->add_weighted_edge($row->{'a'}, $row->{'b'}, $row->{'dist'});
 132     }
 133 }
 134
 135 sub database_graph_spr () {
 136     $dbspr= shortest_path_reduction('db',$dbdists);
 137 }
 138
 139 sub yppedia_graphs_add_shortcuts () {
 140     # We add edges between LPs we know about, as you can chart
 141     # between them.  Yppedia often lacks these edges.
 142     #
 143     foreach my $p ($widists->vertices) {
 144         my ($ax,$ay) = $p =~ m/^(\d+)\,(\d+)$/ or die;
 145         my $add_shortcut= sub {
 146             my $q= sprintf "%d,%d", $ax+$_[0], $ay+$_[1];
 147             return unless $widists->has_vertex($q);
 148             return if $widists->has_edge($p,$q);
 149             printf DEBUG "%-5s league-shortcut %-5s\n", $p, $q;
 150             $widists->add_weighted_edge($p,$q,1);
 151         };
 152         $add_shortcut->( 2,0);
 153         $add_shortcut->(+1,1);
 154         $add_shortcut->(-1,1);
 155     }
 156 }
 157
 158 sub yppedia_graphs_prune_boring () {
 159     # Prune the LP database by eliminating boring intermediate vertices
 160     foreach my $delete ($widists->vertices()) {
 161         next if exists $winode2island{$delete};
 162         my @neigh= $widists->neighbours($delete);
 163         next unless @neigh==2;
 164         my $weight= 0;
 165         map { $weight += $widists->get_edge_weight($delete, $_) } @neigh;
 166         $widists->add_weighted_edge(@neigh, $weight);
 167         $widists->delete_vertex($delete);
 168         printf DEBUG "%-5s elide %5s %-5s %2d\n", $delete, @neigh, $weight;
 169     }
 170 }
 171
 172 sub yppedia_graphs_check () {
 173     # Check that it's connected.
 174     foreach my $cc ($widists->connected_components()) {
 175         next if 2*@$cc > $widists->vertices();
 176         my $m= "disconnected league point(s):";
 177         foreach my $n (@$cc) {
 178             $m .= "\n    LP $n, def. yppedia line(s): ".
 179                 join(',', sort keys %{ $winode2lines{$n} });
 180         }
 181         warning($m);
 182     }
 183 }
 184
 185 sub yppedia_archs_sourceinfo () {
 186     # Assign archipelagoes according to the source-info file
 187     foreach my $arch (sort keys %{ $oceans{$ocean} }) {
 188         foreach my $islename (sort keys %{ $oceans{$ocean}{$arch} }) {
 189             my $islenode= $wiisland2node{$islename};
 190             defined $islenode or
 191                 error("island $islename in source-info but not in WP map");
 192             my $ccix= $wiarchs->connected_component_by_vertex($islenode);
 193             my $oldarch= $wiccix2arch{$ccix};
 194             error("island $islename in $arch in source-info".
 195                   " connected to $oldarch as well")
 196                 if defined $oldarch && $oldarch ne $arch;
 197             printf DEBUG "%-5s force-island-arch cc%-2d %-10s %s\n",
 198                 $islenode, $ccix, $arch, $islename;
 199             $wiccix2arch{$ccix}= $arch;
 200         }
 201     }
 202 }
 203
 204 sub yppedia_archs_chart_labels () {
 205     # Assign archipelago labels to groups of islands
 206     #
 207     foreach my $label (@wiarchlabels) {
 208         my ($ax,$ay,$arch) = @$label;
 209         my $best_ccmulti= -1;
 210         my $best_d2= 0;
 211         my $best_n;
 212 #       print DEBUG "$ax,$ay arch-island-search $arch\n";
 213         $ay += 1;  $ax += 2;  # coords are rather to the top left of label
 214         foreach my $vertex ($wiarchs->vertices()) {
 215             next unless exists $winode2island{$vertex};
 216             my $ccix= $wiarchs->connected_component_by_vertex($vertex);
 217             my @cc= $wiarchs->connected_component_by_index($ccix);
 218             my $ccmulti= @cc > 1;
 219             my ($vx,$vy) = split /,/, $vertex;
 220             my $d2= ($vx-$ax)*($vx-$ax) + ($vy-$ay)*($vy-$ay);
 221             my $cmp= $ccmulti <=> $best_ccmulti
 222                 ||   $best_d2 <=> $d2;
 223             printf DEBUG "%2d,%-2d arch-island-search %5s d2=%4d cc%-2d".
 224                          " #cc=%2d ccmulti=%d cmp=%2d %s\n",
 225                 $ax,$ay, $vertex, $d2, $ccix, scalar(@cc), $ccmulti, $cmp,
 226                 $winode2island{$vertex};
 227             next unless $cmp > 0;
 228             $best_n=       $vertex;
 229             $best_d2=      $d2;
 230             $best_ccmulti= $ccmulti;
 231         }
 232         die 'no island vertices?!' unless defined $best_n;
 233         my $ccix= $wiarchs->connected_component_by_vertex($best_n);
 234         printf DEBUG
 235             "%2d,%-2d arch-island-select %-5s d2=%4d cc%-2d     %-10s %s\n",
 236             $ax,$ay, $best_n, $ccix, $best_d2, $arch, $winode2island{$best_n};
 237         my $desc= join "\n", map {
 238             my $in= $winode2island{$_};
 239             "    LP $_". (defined $in ? ", $in" : "");
 240         } sort $wiarchs->connected_component_by_index($ccix);
 241
 242         if (exists $wiccix2arch{$ccix} and $wiccix2arch{$ccix} ne $arch) {
 243             error("archipelago determination failed, wrongly merged:\n".
 244                   "    archipelago $arch\n".
 245                   "    archipelago $wiccix2arch{$ccix}\n".
 246                   $desc);
 247             next;
 248         }
 249         $wiccix2arch{$ccix}= $arch;
 250 #       print "$ccix $arch ::\n$desc\n";
 251     }
 252 }
 253
 254 sub yppedia_archs_fillbynearest() {
 255     # Assign islands not labelled above to archipelagoes.
 256     #
 257     # We do this by, for each connected component (set of islands
 258     # linked by purchaseable charts), searching for the nearest other
 259     # connected component which has already been assigned an arch.
 260     # `Nearest' means shortest distance of unpurchaseable charts, in
 261     # leagues.
 262     #
 263     # we need only consider vertices which weren't `boring intermediate
 264     # vertices' (removed during optimisation as being of order 2)
 265     my @ccs_useful= map {
 266         [ grep { $widists->has_vertex($_) } @$_ ]
 267     } $wiarchs->connected_components();
 268
 269     my @assignments;
 270
 271     foreach my $sourceccix (0..$#ccs_useful) {
 272         next if defined $wiccix2arch{$sourceccix};
 273         next unless $ccs_useful[$sourceccix];
 274
 275         my @sourcecc= $wiarchs->connected_component_by_index($sourceccix);
 276         my @islandnodes= grep { $winode2island{$_} } @sourcecc;
 277         next unless @islandnodes; # don't care, then
 278
 279         foreach my $islandnode (@islandnodes) {
 280             printf DEBUG "%-5s arch-join-need cc%-2d             %s\n",
 281                 $islandnode, $sourceccix, $winode2island{$islandnode};
 282         }
 283         my $best_dist= 9999999;
 284         my ($best_target, $best_targetccix, $best_source);
 285         foreach my $targetccix (0..$#ccs_useful) {
 286             next unless defined $wiccix2arch{$targetccix}; # not helpful
 287             next unless $ccs_useful[$targetccix];
 288             foreach my $target ($wiarchs->
 289                          connected_component_by_index($targetccix)) {
 290                 next unless $widists->has_vertex($target);
 291                 foreach my $source (@sourcecc) {
 292                     my $target_dist= widist($target,$source);
 293                     next unless defined $target_dist;
 294                     next if $target_dist >= $best_dist;
 295                     $best_dist= $target_dist;
 296                     $best_source= $source;
 297                     $best_target= $target;
 298                     $best_targetccix= $targetccix;
 299                 }
 300             }
 301         }
 302         die "no possible target ?!" unless defined $best_target;
 303
 304         my $arch= $wiccix2arch{$best_targetccix};
 305         my $best_island= $winode2island{$best_target};
 306         printf DEBUG "%-5s arch-join-to %-5s dist=%2d cc%-2d  %-10s %s\n",
 307             $best_source, $best_target, $best_dist,
 308             $best_targetccix, $arch,
 309             defined($best_island) ? $best_island : "-";
 310
 311         push @assignments, [ $sourceccix, $arch ];
 312     }
 313     foreach my $assign (@assignments) {
 314         $wiccix2arch{$assign->[0]}= $assign->[1];
 315     }
 316 }
 317
 318 sub yppedia_graph_shortest_paths () {
 319     $wialldists= $widists->APSP_Floyd_Warshall();
 320 }
 321
 322 sub widist ($$) {
 323     my ($p,$q) = @_;
 324     my $pl= $wialldists->path_length($p,$q);
 325 #    die "$p $q" unless defined $pl;
 326 #    my @pv= $wialldists->path_vertices($p,$q);
 327 #    if (@pv == $pl) { return $pl; }
 328 #   printf DEBUG "%-5s PATHLENGTH %-5s pl=%s pv=%s\n", $p,$q,$pl,join('|',@pv);
 329     return $pl;
 330 }
 331
 332 sub winode2arch ($) {
 333     my ($node) = @_;
 334     my $ccix= $wiarchs->connected_component_by_vertex($node);
 335     return $wiccix2arch{$ccix};
 336 }
 337 sub wiisland2arch ($) {
 338     my ($island) = @_;
 339     my $node= $wiisland2node{$island};
 340     die "$island ?" unless defined $node;
 341     return winode2arch($node);
 342 }
 343
 344 sub compare_island_lists () {
 345     foreach my $island (sort keys %dbisland2arch) {
 346         my $node= $wiisland2node{$island};
 347         if (!defined $node) {
 348             error("would delete island: $island");
 349             next;
 350         }
 351         my $wiarch= winode2arch($node);
 352         if (!defined $wiarch) {
 353             error("island has no arch: $island");
 354             next;
 355         }
 356         my $dbarch= $dbisland2arch{$island};
 357         if ($wiarch ne $dbarch) {
 358             change("archipelago change from $dbarch to $wiarch".
 359                    " for island $island");
 360         }
 361     }
 362     foreach my $island (sort keys %wiisland2node) {
 363         my $dbarch= $dbisland2arch{$island};
 364         if (!defined $dbarch) {
 365             my $wiarch= wiisland2arch($island);
 366             if (!defined $wiarch) {
 367                 error("new island has no arch: $island");
 368                 next;
 369                 # We check arches of non-new islands above
 370             }
 371             change("island new in $wiarch: $island");
 372         }
 373     }
 374 }
 375
 376 sub shortest_path_reduction ($$) {
 377     my ($what,$g) = @_;
 378     #
 379     # Takes a graph $g (and a string for messages $what) and returns
 380     # a new graph which is the miminal shortest path transient reduction
 381     # of $g.
 382     #
 383     # We also check that the shortest path closure of the intended result
 384     # is the same graph as the input.  Thus the input must itself be
 385     # a shortest path closure; if it isn't, we die.
 386
 387     my $proof=<<'END'; # way to make a big comment
 388
 389     Premises and definitions:
 390
 391     1. F is an undirected weighted graph with positive edge weights.
 392
 393     2. All graphs we will consider have the same vertices as F.
 394
 395     3. G = Closure(F) is the graph of cliques whose edge weights
 396        are the shortest paths in F, one clique for each connected
 397        component in F.
 398
 399     3a. |XY| for vertices X, Y is the weight of the edge XY in G.
 400        If XY is not in G, |XY| is infinite.
 401
 402     4. A `reduction' of G is a subgraph K of G such that Closure(K) = G.
 403        The reduction is `minimal' if there is no strict subgraph K'
 404        of K such that Closure(K') = G.
 405
 406     5. Now each edge of G may be:
 407        - `unnecessary': included in no minimal reductions of G.
 408        - `essential': included in all minimal reductions of G.
 409        - `contingent': included in some but not all.
 410
 411     6. Consider for any edge AC between the vertices A and C,
 412        whether there is any B such that |AB|+|BC| = |AC| ?
 413        (There can be no B such that the sum < |AC| since that would
 414        mean that |AC| wasn't equal to the shortest path length.)
 415
 416     6a. No such B:  AC is therefore the only shortest path from A to C
 417         (since G is not a multigraph).  AC is thus an essential edge.
 418
 419     6b. Some such B: Call all such edges AC `questionable'.
 420
 421     6c. Thus all edges are essential or questionable.
 422
 423     7. Suppose AC is a shortest contingent edge.  AC must be
 424        questionable since it is not essential.  Suppose it is
 425        made questionable by the existence of B such that |AB|+|BC| =
 426        |AC|.  Consider AB and BC.  Since |AB| and |BC| are positive,
 427        |BC| and |AB| must be < |AC| ie AB and BC are shorter than AC.
 428        Since AC is a shortest contingent edge, there must be shortest
 429        paths in G for AB and BC consisting entirely of essential edges.
 430
 431     8. Therefore it is always safe to remove AC since the paths
 432        A..B and B..C will definitely still remain and provide a path
 433        A..B..C with length |AB|+|BC| = |AC|.
 434
 435     9. Thus AC is unnecessary, contradicting the assumption in 7.
 436        There are therefore no shortest contingent edges, and
 437        thus no contingent edges.
 438
 439     10. We can construct a minimal reduction directly: for each edge
 440         AC in G, search for a vertex B such that |AB|+|BC| = |AC|.
 441         If we find none, AC is essential.  If we find one then AC is
 442         not essential and is therefore unnecessary.
 443
 444 END
 445
 446     printf DEBUG "spr %s before %d\n", $what, scalar($g->edges());
 447
 448     my $result= Graph::Undirected->new();
 449     foreach my $edge_ac ($g->edges()) {
 450         my $edgename_ac= join ' .. ', @$edge_ac;
 451         printf DEBUG "spr %s edge %s\n", $what, $edgename_ac;
 452         my $w_ac= $g->get_edge_weight(@$edge_ac);
 453         my $needed= 1;
 454         foreach my $vertex_b ($g->vertices()) {
 455             next if grep { $_ eq $vertex_b } @$edge_ac;
 456             my $w_ab= $g->get_edge_weight($edge_ac->[0], $vertex_b);
 457             next unless defined $w_ab;
 458             next if $w_ab >= $w_ac;
 459             my $w_bc= $g->get_edge_weight($vertex_b, $edge_ac->[1]);
 460             next unless defined $w_ac;
 461             next if $w_ab + $w_bc > $w_ac;
 462             # found path
 463             printf DEBUG "spr %s edge %s unnecessary %s\n",
 464                 $what, $edgename_ac, $vertex_b;
 465             $needed= 0;
 466             last;
 467         }
 468         if ($needed) {
 469             printf DEBUG "spr %s edge %s essential\n", $what, $edgename_ac;
 470             $result->add_weighted_edge(@$edge_ac,$w_ac);
 471         }
 472     }
 473     printf DEBUG "spr %s result %d\n", $what, scalar($result->edges());
 474
 475     my $apsp= $result->APSP_Floyd_Warshall();
 476     foreach my $ia (sort $g->vertices()) {
 477         foreach my $ib (sort $g->vertices()) {
 478             my $din= $g->get_edge_weight($ia,$ib);
 479             my $dout= $apsp->path_length($ia,$ib);
 480             $din= defined($din) ? $din : 'infinity';
 481             $dout= defined($dout) ? $dout : 'infinity';
 482             error("$what spr apsp discrepancy in=$din out=$dout".
 483                   " for $ia .. $ib")
 484                 if $din != $dout;
 485         }
 486     }
 487     return $result;
 488 }
 489
 490 sub yppedia_graph_spr () {
 491     my $base= Graph::Undirected->new();
 492     foreach my $na (sort keys %winode2island) {
 493         my $ia= $winode2island{$na};
 494         foreach my $nb (sort keys %winode2island) {
 495             my $ib= $winode2island{$nb};
 496             $base->add_weighted_edge($ia,$ib, widist($na,$nb));
 497         }
 498     }
 499     $wispr= shortest_path_reduction('wi',$base);
 500 }
 501
 502 sub compare_distances () {
 503     foreach my $ia (sort keys %dbisland2arch) {
 504         my $na= $wiisland2node{$ia};
 505         next unless defined $na;
 506         foreach my $ib (sort keys %dbisland2arch) {
 507             next unless $ia le $ib; # do every pair only once
 508             my $dbdist= $dbspr->get_edge_weight($ia,$ib);
 509             my $widist= $wispr->get_edge_weight($ia,$ib);
 510             next unless defined $dbdist || defined $widist;
 511
 512             if (!defined $widist) {
 513                 warning(sprintf "route delete %2d for %s .. %s",
 514                         $dbdist, $ia,$ib);
 515             } elsif (!defined $dbdist) {
 516                 change(sprintf "route new %2d for %s .. %s",
 517                        $widist, $ia,$ib);
 518             } elsif ($dbdist != $widist) {
 519                 change(sprintf "route change %2d to %2d for %s .. %s",
 520                        $dbdist, $widist, $ia,$ib);
 521             }
 522         }
 523     }
 524 }
 525
 526 parse_info_serverside();
 527
 528 progress("reading database");
 529
 530 db_setocean($ocean);
 531 db_connect();
 532 database_fetch_ocean();
 533
 534 progress("computing database spr");         database_graph_spr();
 535
 536 progress("reading yppedia chart");          yppedia_chart_parse();
 537 progress("adding shortcuts");               yppedia_graphs_add_shortcuts();
 538 progress("pruning boring vertices");        yppedia_graphs_prune_boring();
 539 progress("checking yppedia graphs");        yppedia_graphs_check();
 540 progress("setting archs from source-info"); yppedia_archs_sourceinfo();
 541 progress("computing shortest paths");       yppedia_graph_shortest_paths();
 542 progress("setting archs from labels");      yppedia_archs_chart_labels();
 543 progress("setting archs from nearby");      yppedia_archs_fillbynearest();
 544 progress("computing yppedia spr");          yppedia_graph_spr();
 545
 546 progress("comparing islands");              compare_island_lists();
 547 progress("comparing distances");            compare_distances();
 548
 549 print_messages();