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     #
 378     # Takes a graph $base (and a string for messages $what) and returns
 379     # a new graph which is the miminal shortest path transient reduction
 380     # of $base.
 381     #
 382     # We also check that the shortest path closure of the intended result
 383     # is the same graph as the input.  Thus the input must itself be
 384     # a shortest path closure; if it isn't, we die.
 385
 386     my $proof=<<'END'; # way to make a big comment
 387
 388     Premises and definitions:
 389
 390     1. F is a connected undirected weighted graph with positive edge
 391        weights.
 392
 393     2. All graphs we will consider have the same vertices as F.
 394
 395     3. G = Closure(F) is the complete graph whose edge weights
 396        are the shortest paths in F.  (G is the input graph $base.)
 397
 398     3a. |XY| for vertices X, Y is the weight of the edge XY in G.
 399
 400     4. A `reduction' of G is a subgraph K of G such that Closure(K) = G.
 401        The reduction is `minimal' if there is no strict subgraph K'
 402        of K such that Closure(K') = G.
 403
 404     5. Now each edge of G may be:
 405        - `unnecessary': included in no minimal reductions of G.
 406        - `essential': included in all minimal reductions of G.
 407        - `contingent': included in some but not all.
 408
 409     6. Consider for any edge AC between the vertices A and C,
 410        whether there is any B such that |AB|+|BC| = |AC| ?
 411        (There can be no B such that the sum < |AC| since that would
 412        mean that |AC| wasn't equal to the shortest path length.)
 413
 414     6a. No such B:  AC is therefore the only shortest path from A to C
 415         (since G is not a multigraph).  AC is thus an essential edge.
 416
 417     6b. Some such B: Call all such edges AC `questionable'.
 418
 419     6c. Thus all edges are essential or questionable.
 420
 421     7. Suppose AC is a shortest contingent edge.  AC must be
 422        questionable since it is not essential.  Suppose it is
 423        made questionable by the existence of B such that |AB|+|BC| =
 424        |AC|.  Consider AB and BC.  Since |AB| and |BC| are positive,
 425        |BC| and |AB| must be < |AC| ie AB and BC are shorter than AC.
 426        Since AC is a shortest contingent edge, there must be shortest
 427        paths in G for AB and BC consisting entirely of essential edges.
 428
 429     8. Therefore it is always safe to remove AC since the paths
 430        A..B and B..C will definitely still remain and provide a path
 431        A..B..C with length |AB|+|BC| = |AC|.
 432
 433     9. Thus AC is unnecessary, contradicting the assumption in 7.
 434        There are therefore no shortest contingent edges, and
 435        thus no contingent edges.
 436
 437     10. We can construct a minimal reduction directly: for each edge
 438         AC in G, search for a vertex B such that |AB|+|BC| = |AC|.
 439         If we find none, AC is essential.  If we find one then AC is
 440         not essential and is therefore unnecessary.
 441
 442 END
 443
 444     printf DEBUG "spr %s before %d\n", $what, scalar($base->edges());
 445
 446     my $result= Graph::Undirected->new();
 447     foreach my $edge_ac ($base->edges()) {
 448         my $edgename_ac= join '..', @$edge_ac;
 449         printf DEBUG "spr %s edge %s\n", $what, $edgename_ac;
 450         my $w_ac= $base->get_edge_weight(@$edge_ac);
 451         my $needed= 1;
 452         foreach my $vertex_b ($base->vertices()) {
 453             next if grep { $_ eq $vertex_b } @$edge_ac;
 454             my $w_ab= $base->get_edge_weight($edge_ac->[0], $vertex_b);
 455             next unless defined $w_ab;
 456             next if $w_ab >= $w_ac;
 457             my $w_bc= $base->get_edge_weight($vertex_b, $edge_ac->[1]);
 458             next unless defined $w_ac;
 459             next if $w_ab + $w_bc > $w_ac;
 460             # found path
 461             printf DEBUG "spr %s edge %s unnecessary %s\n",
 462                 $what, $edgename_ac, $vertex_b;
 463             $needed= 0;
 464             last;
 465         }
 466         if ($needed) {
 467             printf DEBUG "spr %s edge %s essential\n", $what, $edgename_ac;
 468             $result->add_weighted_edge(@$edge_ac,$w_ac);
 469         }
 470     }
 471     printf DEBUG "spr %s result %d\n", $what, scalar($result->edges());
 472
 473     my $apsp= $result->APSP_Floyd_Warshall();
 474     foreach my $ia (sort $base->vertices()) {
 475         foreach my $ib (sort $base->vertices()) {
 476             my $din= $base->get_edge_weight($ia,$ib);
 477             my $dout= $apsp->path_length($ia,$ib);
 478             $din= defined($din) ? $din : 'infinity';
 479             $dout= defined($dout) ? $dout : 'infinity';
 480             error("$what spr apsp discrepancy in=$din out=$dout for $ia..$ib")
 481                 if $din != $dout;
 482         }
 483     }
 484     return $result;
 485 }
 486
 487 sub yppedia_graph_spr () {
 488     my $base= Graph::Undirected->new();
 489     foreach my $na (sort keys %winode2island) {
 490         my $ia= $winode2island{$na};
 491         foreach my $nb (sort keys %winode2island) {
 492             my $ib= $winode2island{$nb};
 493             $base->add_weighted_edge($ia,$ib, widist($na,$nb));
 494         }
 495     }
 496     $wispr= shortest_path_reduction('wi',$base);
 497 }
 498
 499 sub compare_distances () {
 500     foreach my $ia (sort keys %dbisland2arch) {
 501         my $na= $wiisland2node{$ia};
 502         next unless defined $na;
 503         foreach my $ib (sort keys %dbisland2arch) {
 504             next unless $ia le $ib; # do every pair only once
 505             my $dbdist= $dbspr->get_edge_weight($ia,$ib);
 506             my $widist= $wispr->get_edge_weight($ia,$ib);
 507             next unless defined $dbdist || defined $widist;
 508
 509             if (!defined $widist) {
 510                 warning(sprintf "route delete %2d for %s..%s",
 511                         $dbdist, $ia,$ib);
 512             } elsif (!defined $dbdist) {
 513                 change(sprintf "route create %2d for %s..%s",
 514                        $widist, $ia,$ib);
 515             } elsif ($dbdist != $widist) {
 516                 change(sprintf "route change %2d to %2d for %s..%s",
 517                        $dbdist, $widist, $ia,$ib);
 518             }
 519         }
 520     }
 521 }
 522
 523 parse_info_serverside();
 524
 525 print "reading database\n";
 526
 527 db_setocean($ocean);
 528 db_connect();
 529 database_fetch_ocean();
 530
 531 print "computing database spr\n";         database_graph_spr();
 532
 533 print "reading yppedia chart\n";          yppedia_chart_parse();
 534 print "adding shortcuts\n";               yppedia_graphs_add_shortcuts();
 535 print "pruning boring vertices\n";        yppedia_graphs_prune_boring();
 536 print "checking yppedia graphs\n";        yppedia_graphs_check();
 537 print "setting archs from source-info\n"; yppedia_archs_sourceinfo();
 538 print "computing shortest paths\n";       yppedia_graph_shortest_paths();
 539 print "setting archs from labels\n";      yppedia_archs_chart_labels();
 540 print "setting archs from nearby\n";      yppedia_archs_fillbynearest();
 541 print "computing yppedia spr\n";          yppedia_graph_spr();
 542
 543 print "comparing\n";
 544
 545 compare_island_lists();
 546 compare_distances();
 547
 548 print_messages();