yarrg/yppedia-chart-parser

   1 #!/usr/bin/perl
   2 #
   3 # Normally run from
   4 #  update-master-info
   5 #
   6 # usage: ./yppedia-chart-parser <Oceanname>
   7 #  updates OCEAN-Oceanname.db and _ocean-<oceanname>.txt
   8 #  from YPPedia (chart and ocean page) and source-info.txt
   9
  10 # This is part of ypp-sc-tools, a set of third-party tools for assisting
  11 # players of Yohoho Puzzle Pirates.
  12 #
  13 # Copyright (C) 2009 Ian Jackson <ijackson@chiark.greenend.org.uk>
  14 #
  15 # This program is free software: you can redistribute it and/or modify
  16 # it under the terms of the GNU General Public License as published by
  17 # the Free Software Foundation, either version 3 of the License, or
  18 # (at your option) any later version.
  19 #
  20 # This program is distributed in the hope that it will be useful,
  21 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  22 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  23 # GNU General Public License for more details.
  24 #
  25 # You should have received a copy of the GNU General Public License
  26 # along with this program.  If not, see <http://www.gnu.org/licenses/>.
  27 #
  28 # Yohoho and Puzzle Pirates are probably trademarks of Three Rings and
  29 # are used without permission.  This program is not endorsed or
  30 # sponsored by Three Rings.
  31
  32 use strict (qw(vars));
  33 use warnings;
  34
  35 use Graph::Undirected;
  36 use Commods;
  37 use CommodsDatabase;
  38
  39 my $widists= Graph::Undirected->new();
  40 my $wiarchs= Graph::Undirected->new();
  41 my $wispr;
  42 my $dbspr;
  43 my @wiarchlabels;
  44 my %wiisland2node;
  45 my %winode2island;
  46 my %winode2lines;
  47 my %wiccix2arch;
  48 my $wialldists;
  49 my %wtisland2arch;
  50
  51 my $dbdists;
  52 my %dbisland2arch;
  53
  54 my @msgkinds= qw(change warning error);
  55 my %msgs;
  56 my %msgprinted;
  57 my %msgkindprinted;
  58 sub pmsg ($$) { push @{ $msgs{$_[0]} }, "$_[0]: $_[1]\n"; }
  59 sub warning ($) { pmsg("warning",$_[0]); }
  60 sub error   ($) { pmsg("error",  $_[0]); }
  61 sub change  ($) { pmsg("change", $_[0]); }
  62 sub print_messages () {
  63     foreach my $k (@msgkinds) {
  64         my $ms= $msgs{$k};
  65         next unless $ms;
  66         foreach my $m (sort @$ms) {
  67             next if $msgprinted{$m};
  68             print $m or die $!;
  69             $msgprinted{$m}++;
  70             $msgkindprinted{$k}++;
  71         }
  72     }
  73 }
  74 sub progress ($) { print "($_[0])\n"; }
  75
  76 my $stdin_chart=0;
  77
  78 open DEBUG, ">/dev/null" or die $!;
  79
  80 while (@ARGV) {
  81     last unless $ARGV[0] =~ m/^-/;
  82     $_= shift @ARGV;
  83     last if m/^--$/;
  84     if ($_ eq '--debug') {
  85         open DEBUG, ">&STDOUT" or die $!;
  86         select(DEBUG); $|=1; select(STDOUT);
  87     } elsif ($_ eq '--stdin-chart') {
  88         $stdin_chart=1;
  89     } else {
  90         die;
  91     }
  92 }
  93 $|=1;
  94
  95 @ARGV==1 or die;
  96 my $ocean= shift @ARGV;
  97
  98
  99 my $parity;
 100 sub nn_xy ($$) {
 101     my ($x,$y) = @_;
 102     my $tp= (0+$x ^ 0+$y) & 1;
 103     defined $parity or $parity=$tp;
 104     $tp==$parity or warning("line $.: parity error $x,$y is $tp not $parity");
 105     my $n= "$_[0],$_[1]";
 106     $winode2lines{$n}{$.}++;
 107     return $n;
 108 }
 109
 110 sub yppedia_chart_parse () {
 111     # We don't even bother with tag soup; instead we do line-oriented parsing.
 112
 113     while (<OCEAN>) {
 114         s/\<--.*--\>//g;
 115         s/^\s*//; chomp; s/\s+$//; s/\s+/ /g;
 116         s/\<\/?(?:b|em)\>//g;
 117         s/\{\{Chart\ style\|[^{}]*\}\}//g;
 118         next unless m/\{\{/; # only interested in chart template stuff
 119
 120         my ($x,$y, $arch,$island,$solid,$dirn);
 121         my $nn= sub { return nn_xy($x,$y) };
 122
 123         if (($x,$y,$arch) =
 124             m/^\{\{ chart\ label \|(\d+)\|(\d+)\| .*
 125                     \'\[\[ [^][\']* \| (\S+)\ archipelago \]\]\'*\}\}$/xi) {
 126             printf DEBUG "%2d,%-2d arch %s\n", $x,$y,$arch;
 127             push @wiarchlabels, [ $x,$y,$arch ];
 128         } elsif (($x,$y,$island) =
 129             m/^\{\{ chart\ island\ icon \|(\d+)\|(\d+)\|
 130                     ([^| ][^|]*[^| ]) \| .*\}\}$/xi) {
 131             my $n= $nn->();
 132             $wiisland2node{$island}= $n;
 133             $winode2island{$n}= $island;
 134             $widists->add_vertex($n);
 135             $wiarchs->add_vertex($n);
 136             printf DEBUG "%2d,%-2d island %s\n", $x,$y,$island;
 137         } elsif (($solid,$x,$y,$dirn) =
 138             m/^\{\{ chart\ league((?:\ solid)?) \|(\d+)\|(\d+)\|
 139                     ([-\/\\o]) \| .*\}\}$/xi) {
 140             next if $dirn eq 'o';
 141
 142             my ($bx,$by) = ($x,$y);
 143             if ($dirn eq '-') { $bx+=2; }
 144             elsif ($dirn eq '\\') { $bx++; $by++; }
 145             elsif ($dirn eq '/') { $x++; $by++; }
 146             else { die; }
 147
 148             my $nb= nn_xy($bx,$by);
 149             $widists->add_weighted_edge($nn->(), $nb, 1);
 150             $wiarchs->add_edge($nn->(), $nb) if $solid;
 151             $wiarchs->add_edge($nn->(), $nb) if $solid;
 152
 153             printf DEBUG "%2d,%-2d league %-6s %s %s\n", $x,$y,
 154                 $solid?'solid':'dotted', $dirn, $nb;
 155         } elsif (
 156             m/^\{\{ chart\ head \}\}$/xi
 157                  ) {
 158             next;
 159         } else {
 160             warning("line $.: ignoring incomprehensible: $_");
 161         }
 162     }
 163 }
 164
 165 sub yppedia_graphs_add_shortcuts () {
 166     # We add edges between LPs we know about, as you can chart
 167     # between them.  Yppedia often lacks these edges.
 168     #
 169     foreach my $p ($widists->vertices) {
 170         my ($ax,$ay) = $p =~ m/^(\d+)\,(\d+)$/ or die;
 171         my $add_shortcut= sub {
 172             my $q= sprintf "%d,%d", $ax+$_[0], $ay+$_[1];
 173             return unless $widists->has_vertex($q);
 174             return if $widists->has_edge($p,$q);
 175             printf DEBUG "%-5s league-shortcut %-5s\n", $p, $q;
 176             $widists->add_weighted_edge($p,$q,1);
 177         };
 178         $add_shortcut->( 2,0);
 179         $add_shortcut->(+1,1);
 180         $add_shortcut->(-1,1);
 181     }
 182 }
 183
 184 sub yppedia_graphs_prune_boring () {
 185     # Prune the LP database by eliminating boring intermediate vertices
 186     foreach my $delete ($widists->vertices()) {
 187         next if exists $winode2island{$delete};
 188         my @neigh= $widists->neighbours($delete);
 189         next unless @neigh==2;
 190         my $weight= 0;
 191         map { $weight += $widists->get_edge_weight($delete, $_) } @neigh;
 192         $widists->add_weighted_edge(@neigh, $weight);
 193         $widists->delete_vertex($delete);
 194         printf DEBUG "%-5s elide %5s %-5s %2d\n", $delete, @neigh, $weight;
 195     }
 196 }
 197
 198 sub yppedia_graphs_check () {
 199     # Check that it's connected.
 200     foreach my $cc ($widists->connected_components()) {
 201         next if 2*@$cc > $widists->vertices();
 202         my $m= "disconnected league point(s):";
 203         foreach my $n (@$cc) {
 204             $m .= "\n    LP $n, def. yppedia line(s): ".
 205                 join(',', sort keys %{ $winode2lines{$n} });
 206         }
 207         warning($m);
 208     }
 209 }
 210
 211 sub yppedia_archs_sourceinfo () {
 212     # Assign archipelagoes according to the source-info file
 213     foreach my $arch (sort keys %{ $oceans{$ocean} }) {
 214         foreach my $islename (sort keys %{ $oceans{$ocean}{$arch} }) {
 215             my $islenode= $wiisland2node{$islename};
 216             if (!defined $islenode) {
 217                 error("island $islename in source-info but not in WP map");
 218                 next;
 219             }
 220             my $ccix= $wiarchs->connected_component_by_vertex($islenode);
 221             my $oldarch= $wiccix2arch{$ccix};
 222             error("island in $arch in source-info".
 223                   " connected to $oldarch as well: $islename")
 224                 if defined $oldarch && $oldarch ne $arch;
 225             printf DEBUG "%-5s force-island-arch cc%-2d %-10s %s\n",
 226                 $islenode, $ccix, $arch, $islename;
 227             $wiccix2arch{$ccix}= $arch;
 228         }
 229     }
 230 }
 231
 232 sub yppedia_archs_chart_labels () {
 233     # Assign archipelago labels to groups of islands
 234     #
 235     foreach my $label (@wiarchlabels) {
 236         my ($ax,$ay,$arch) = @$label;
 237         my $best_ccmulti= -1;
 238         my $best_d2= 0;
 239         my $best_n;
 240 #       print DEBUG "$ax,$ay arch-island-search $arch\n";
 241         $ay += 1;  $ax += 2;  # coords are rather to the top left of label
 242         foreach my $vertex ($wiarchs->vertices()) {
 243             next unless exists $winode2island{$vertex};
 244             my $ccix= $wiarchs->connected_component_by_vertex($vertex);
 245             my @cc= $wiarchs->connected_component_by_index($ccix);
 246             my $ccmulti= @cc > 1;
 247             my ($vx,$vy) = split /,/, $vertex;
 248             my $d2= ($vx-$ax)*($vx-$ax) + ($vy-$ay)*($vy-$ay);
 249             my $cmp= $ccmulti <=> $best_ccmulti
 250                 ||   $best_d2 <=> $d2;
 251             printf DEBUG "%2d,%-2d arch-island-search %5s d2=%4d cc%-2d".
 252                          " #cc=%2d ccmulti=%d cmp=%2d %s\n",
 253                 $ax,$ay, $vertex, $d2, $ccix, scalar(@cc), $ccmulti, $cmp,
 254                 $winode2island{$vertex};
 255             next unless $cmp > 0;
 256             $best_n=       $vertex;
 257             $best_d2=      $d2;
 258             $best_ccmulti= $ccmulti;
 259         }
 260         die 'no island vertices?!' unless defined $best_n;
 261         my $ccix= $wiarchs->connected_component_by_vertex($best_n);
 262         printf DEBUG
 263             "%2d,%-2d arch-island-select %-5s d2=%4d cc%-2d     %-10s %s\n",
 264             $ax,$ay, $best_n, $ccix, $best_d2, $arch, $winode2island{$best_n};
 265         my $desc= join "\n", map {
 266             my $in= $winode2island{$_};
 267             "    LP $_". (defined $in ? ", $in" : "");
 268         } sort $wiarchs->connected_component_by_index($ccix);
 269
 270         if (exists $wiccix2arch{$ccix} and $wiccix2arch{$ccix} ne $arch) {
 271             error("archipelago determination failed, wrongly merged:\n".
 272                   "    archipelago $arch\n".
 273                   "    archipelago $wiccix2arch{$ccix}\n".
 274                   $desc);
 275             next;
 276         }
 277         $wiccix2arch{$ccix}= $arch;
 278 #       print "$ccix $arch ::\n$desc\n";
 279     }
 280 }
 281
 282 sub yppedia_archs_fillbynearest() {
 283     # Assign islands not labelled above to archipelagoes.
 284     #
 285     # We do this by, for each connected component (set of islands
 286     # linked by purchaseable charts), searching for the nearest other
 287     # connected component which has already been assigned an arch.
 288     # `Nearest' means shortest distance of unpurchaseable charts, in
 289     # leagues.
 290     #
 291     # we need only consider vertices which weren't `boring intermediate
 292     # vertices' (removed during optimisation as being of order 2)
 293     my @ccs_useful= map {
 294         [ grep { $widists->has_vertex($_) } @$_ ]
 295     } $wiarchs->connected_components();
 296
 297     my @assignments;
 298
 299     foreach my $sourceccix (0..$#ccs_useful) {
 300         next if defined $wiccix2arch{$sourceccix};
 301         next unless $ccs_useful[$sourceccix];
 302
 303         my @sourcecc= $wiarchs->connected_component_by_index($sourceccix);
 304         my @islandnodes= grep { $winode2island{$_} } @sourcecc;
 305         next unless @islandnodes; # don't care, then
 306
 307         foreach my $islandnode (@islandnodes) {
 308             printf DEBUG "%-5s arch-join-need cc%-2d             %s\n",
 309                 $islandnode, $sourceccix, $winode2island{$islandnode};
 310         }
 311         my $best_dist= 9999999;
 312         my ($best_target, $best_targetccix, $best_source);
 313         foreach my $targetccix (0..$#ccs_useful) {
 314             next unless defined $wiccix2arch{$targetccix}; # not helpful
 315             next unless $ccs_useful[$targetccix];
 316             foreach my $target ($wiarchs->
 317                          connected_component_by_index($targetccix)) {
 318                 next unless $widists->has_vertex($target);
 319                 foreach my $source (@sourcecc) {
 320                     my $target_dist= widist($target,$source);
 321                     next unless defined $target_dist;
 322                     next if $target_dist >= $best_dist;
 323                     $best_dist= $target_dist;
 324                     $best_source= $source;
 325                     $best_target= $target;
 326                     $best_targetccix= $targetccix;
 327                 }
 328             }
 329         }
 330         die "no possible target ?!" unless defined $best_target;
 331
 332         my $arch= $wiccix2arch{$best_targetccix};
 333         my $best_island= $winode2island{$best_target};
 334         printf DEBUG "%-5s arch-join-to %-5s dist=%2d cc%-2d  %-10s %s\n",
 335             $best_source, $best_target, $best_dist,
 336             $best_targetccix, $arch,
 337             defined($best_island) ? $best_island : "-";
 338
 339         push @assignments, [ $sourceccix, $arch ];
 340     }
 341     foreach my $assign (@assignments) {
 342         $wiccix2arch{$assign->[0]}= $assign->[1];
 343     }
 344 }
 345
 346 sub yppedia_graph_shortest_paths () {
 347     $wialldists= $widists->APSP_Floyd_Warshall();
 348 }
 349
 350 sub widist ($$) {
 351     my ($p,$q) = @_;
 352     my $pl= $wialldists->path_length($p,$q);
 353 #    die "$p $q" unless defined $pl;
 354 #    my @pv= $wialldists->path_vertices($p,$q);
 355 #    if (@pv == $pl) { return $pl; }
 356 #   printf DEBUG "%-5s PATHLENGTH %-5s pl=%s pv=%s\n", $p,$q,$pl,join('|',@pv);
 357     return $pl;
 358 }
 359
 360 sub winode2arch ($) {
 361     my ($node) = @_;
 362     my $ccix= $wiarchs->connected_component_by_vertex($node);
 363     return $wiccix2arch{$ccix};
 364 }
 365 sub wiisland2arch ($) {
 366     my ($island) = @_;
 367     my $node= $wiisland2node{$island};
 368     die "$island ?" unless defined $node;
 369     return winode2arch($node);
 370 }
 371
 372 sub compare_island_lists () {
 373     foreach my $island (sort keys %dbisland2arch) {
 374         my $node= $wiisland2node{$island};
 375         if (!defined $node) {
 376             error("would delete island: $island");
 377             next;
 378         }
 379         my $wiarch= winode2arch($node);
 380         if (!defined $wiarch) {
 381             error("island has no arch: $island");
 382             next;
 383         }
 384         my $dbarch= $dbisland2arch{$island};
 385         if ($wiarch ne $dbarch) {
 386             change("archipelago change from $dbarch to $wiarch".
 387                    " for island $island");
 388         }
 389     }
 390     foreach my $island (sort keys %wiisland2node) {
 391         my $wtarch= $wtisland2arch{$island};
 392         my $wiarch= wiisland2arch($island);
 393         if (!$stdin_chart) {
 394             if (!defined $wtarch) {
 395                 error("island from chart not found on ocean page: $island");
 396             } elsif (defined $wiarch and $wtarch ne $wiarch) {
 397                 error("island in $wtarch on ocean page but".
 398                       " concluded $wiarch from chart: $island");
 399             }
 400         }
 401
 402         my $dbarch= $dbisland2arch{$island};
 403         if (!defined $dbarch) {
 404             my $wiarch= wiisland2arch($island);
 405             if (!defined $wiarch) {
 406                 error("new island has no arch: $island");
 407                 next;
 408                 # We check arches of non-new islands above
 409             }
 410             change("island new in $wiarch: $island");
 411         }
 412     }
 413     if (!$stdin_chart) {
 414         foreach my $island (sort keys %wtisland2arch) {
 415             my $node= $wiisland2node{$island};
 416             next if defined $node;
 417             error("island on ocean page but not in chart: $island");
 418         }
 419     }
 420 }
 421
 422 sub shortest_path_reduction ($$) {
 423     my ($what,$g) = @_;
 424     #
 425     # Takes a graph $g (and a string for messages $what) and returns
 426     # a new graph which is the miminal shortest path transient reduction
 427     # of $g.
 428     #
 429     # We also check that the shortest path closure of the intended result
 430     # is the same graph as the input.  Thus the input must itself be
 431     # a shortest path closure; if it isn't, we die.
 432
 433     my $proof=<<'END'; # way to make a big comment
 434
 435     Premises and definitions:
 436
 437     1. F is an undirected weighted graph with positive edge weights.
 438
 439     2. All graphs we will consider have the same vertices as F
 440        and none have self-edges.
 441
 442     3. G = Closure(F) is the graph of cliques whose edge weights
 443        are the shortest paths in F, one clique for each connected
 444        component in F.
 445
 446     3a. |XY| for vertices X, Y is the weight of the edge XY in G.
 447        If XY is not in G, |XY| is infinite.
 448
 449     4. A `reduction' of G is a subgraph K of G such that Closure(K) = G.
 450        The reduction is `minimal' if there is no strict subgraph K'
 451        of K such that Closure(K') = G.
 452
 453     5. Now each edge of G may be:
 454        - `unnecessary': included in no minimal reductions of G.
 455        - `essential': included in all minimal reductions of G.
 456        - `contingent': included in some but not all.
 457
 458     6. Consider for any edge AC between the vertices A and C,
 459        whether there is any B such that |AB|+|BC| = |AC| ?
 460        (There can be no B such that the sum < |AC| since that would
 461        mean that |AC| wasn't equal to the shortest path length.)
 462
 463     6a. No such B:  AC is therefore the only shortest path from A to C
 464         (since G is not a multigraph).  AC is thus an essential edge.
 465
 466     6b. Some such B: Call all such edges AC `questionable'.
 467
 468     6c. Thus all edges are essential or questionable.
 469
 470     7. Suppose AC is a shortest contingent edge.  AC must be
 471        questionable since it is not essential.  Suppose it is
 472        made questionable by the existence of B such that |AB|+|BC| =
 473        |AC|.  Consider AB and BC.  Since |AB| and |BC| are positive,
 474        |BC| and |AB| must be < |AC| ie AB and BC are shorter than AC.
 475        Since AC is a shortest contingent edge, there must be shortest
 476        paths in G for AB and BC consisting entirely of essential edges.
 477
 478     8. Therefore it is always safe to remove AC since the paths
 479        A..B and B..C will definitely still remain and provide a path
 480        A..B..C with length |AB|+|BC| = |AC|.
 481
 482     9. Thus AC is unnecessary, contradicting the assumption in 7.
 483        There are therefore no shortest contingent edges, and
 484        thus no contingent edges.
 485
 486     10. We can construct a minimal reduction directly: for each edge
 487         AC in G, search for a vertex B such that |AB|+|BC| = |AC|.
 488         If we find none, AC is essential.  If we find one then AC is
 489         not essential and is therefore unnecessary.
 490
 491 END
 492
 493     printf DEBUG "spr %s before %d\n", $what, scalar($g->edges());
 494
 495     my $result= Graph::Undirected->new();
 496     foreach my $edge_ac ($g->edges()) {
 497         $result->add_vertex($edge_ac->[0]); # just in case
 498         next if $edge_ac->[0] eq $edge_ac->[1];
 499         my $edgename_ac= join ' .. ', @$edge_ac;
 500         printf DEBUG "spr %s edge %s\n", $what, $edgename_ac;
 501         my $w_ac= $g->get_edge_weight(@$edge_ac);
 502         my $needed= 1;
 503         foreach my $vertex_b ($g->vertices()) {
 504             next if grep { $_ eq $vertex_b } @$edge_ac;
 505             my $w_ab= $g->get_edge_weight($edge_ac->[0], $vertex_b);
 506             next unless defined $w_ab;
 507             next if $w_ab >= $w_ac;
 508             my $w_bc= $g->get_edge_weight($vertex_b, $edge_ac->[1]);
 509             next unless defined $w_ac;
 510             next if $w_ab + $w_bc > $w_ac;
 511             # found path
 512             printf DEBUG "spr %s edge %s unnecessary %s\n",
 513                 $what, $edgename_ac, $vertex_b;
 514             $needed= 0;
 515             last;
 516         }
 517         if ($needed) {
 518             printf DEBUG "spr %s edge %s essential\n", $what, $edgename_ac;
 519             $result->add_weighted_edge(@$edge_ac,$w_ac);
 520         }
 521     }
 522     printf DEBUG "spr %s result %d\n", $what, scalar($result->edges());
 523
 524     my $apsp= $result->APSP_Floyd_Warshall();
 525     foreach my $ia (sort $g->vertices()) {
 526         foreach my $ib (sort $g->vertices()) {
 527             my $din= $g->get_edge_weight($ia,$ib);
 528             my $dout= $apsp->path_length($ia,$ib);
 529             $din= defined($din) ? $din : 'infinity';
 530             $dout= defined($dout) ? $dout : 'infinity';
 531             error("$what spr apsp discrepancy in=$din out=$dout".
 532                   " for $ia .. $ib")
 533                 if $din != $dout;
 534         }
 535     }
 536     return $result;
 537 }
 538
 539 sub yppedia_graph_spr () {
 540     my $base= Graph::Undirected->new();
 541     foreach my $na (sort keys %winode2island) {
 542         my $ia= $winode2island{$na};
 543         foreach my $nb (sort keys %winode2island) {
 544             my $ib= $winode2island{$nb};
 545             $base->add_weighted_edge($ia,$ib, widist($na,$nb));
 546         }
 547     }
 548     $wispr= shortest_path_reduction('wi',$base);
 549 }
 550
 551 sub yppedia_ocean_fetch_start ($) {
 552     my ($chart) = @_;
 553     my @args= ();
 554     push @args, '--chart' if $chart;
 555     push @args, $ocean;
 556     open OCEAN, '-|', "./yppedia-ocean-scraper", @args or die $!;
 557 }
 558 sub yppedia_ocean_fetch_done () {
 559     $?=0; $!=0; close OCEAN; $? and die $?; $! and die $!;
 560 }
 561
 562 sub yppedia_ocean_fetch_chart () {
 563     if ($stdin_chart) {
 564         open OCEAN, "<& STDIN" or die $!;
 565         yppedia_chart_parse();
 566     } else {
 567         yppedia_ocean_fetch_start(1);
 568         yppedia_chart_parse();
 569         yppedia_ocean_fetch_done();
 570     }
 571 }
 572
 573 sub yppedia_ocean_fetch_text () {
 574     yppedia_ocean_fetch_start(0);
 575     my $arch;
 576     while (<OCEAN>) {
 577         chomp;
 578         if (m/^ocean /) {
 579             $' eq $ocean or die;
 580         } elsif (m/^  /) {
 581             die unless defined $arch;
 582             $wtisland2arch{$'}= $arch;
 583         } elsif (m/^ /) {
 584             $arch= $';
 585         } else {
 586             die;
 587         }
 588     }
 589     yppedia_ocean_fetch_done();
 590 }
 591
 592 sub compare_distances () {
 593     foreach my $ia (sort keys %dbisland2arch) {
 594         my $na= $wiisland2node{$ia};
 595         next unless defined $na;
 596         foreach my $ib (sort keys %dbisland2arch) {
 597             next unless $ia le $ib; # do every pair only once
 598             my $dbdist= $dbspr->get_edge_weight($ia,$ib);
 599             my $widist= $wispr->get_edge_weight($ia,$ib);
 600             next unless defined $dbdist || defined $widist;
 601
 602             if (!defined $widist) {
 603                 warning(sprintf "route delete %2d for %s .. %s",
 604                         $dbdist, $ia,$ib);
 605             } elsif (!defined $dbdist) {
 606                 change(sprintf "route new %2d for %s .. %s",
 607                        $widist, $ia,$ib);
 608             } elsif ($dbdist != $widist) {
 609                 change(sprintf "route change %2d to %2d for %s .. %s",
 610                        $dbdist, $widist, $ia,$ib);
 611             }
 612         }
 613     }
 614 }
 615
 616 #========== database handling ==========
 617
 618 sub database_fetch_ocean () {
 619     my ($row,$sth);
 620     $sth= $dbh->prepare('SELECT islandname, archipelago FROM islands');
 621     $sth->execute();
 622     undef %dbisland2arch;
 623     $dbdists= Graph::Undirected->new();
 624     while ($row= $sth->fetchrow_hashref) {
 625         print DEBUG "database-island $row->{'islandname'}".
 626                      " $row->{'archipelago'}\n";
 627         $dbisland2arch{$row->{'islandname'}}= $row->{'archipelago'};
 628     }
 629     $sth= $dbh->prepare('SELECT dist, a.islandname a, b.islandname b
 630                                 FROM dists
 631                                 JOIN islands AS a ON dists.aiid==a.islandid
 632                                 JOIN islands AS b ON dists.biid==b.islandid');
 633     $sth->execute();
 634     while ($row= $sth->fetchrow_hashref) {
 635         $dbdists->add_weighted_edge($row->{'a'}, $row->{'b'}, $row->{'dist'});
 636     }
 637 }
 638
 639 sub database_graph_spr () {
 640     $dbspr= shortest_path_reduction('db',$dbdists);
 641 }
 642
 643 sub database_do_updates () {
 644     my $addisland= $dbh->prepare(<<'END')
 645  INSERT OR IGNORE INTO islands (islandname, archipelago) VALUES (?, ?);
 646 END
 647     ;
 648     foreach my $island (sort keys %wiisland2node) {
 649         my $wiarch= wiisland2arch($island);
 650         $addisland->execute($island, $wiarch);
 651     }
 652
 653     db_doall(<<END)
 654  DELETE FROM dists;
 655  DELETE FROM routes;
 656 END
 657     ;
 658     my $adddist= $dbh->prepare(<<'END')
 659  INSERT INTO dists VALUES
 660         ((SELECT islandid FROM islands WHERE islandname == ?),
 661          (SELECT islandid FROM islands WHERE islandname == ?),
 662          ?);
 663 END
 664     ;
 665     my $addroute= $dbh->prepare(<<'END')
 666  INSERT INTO routes VALUES
 667         ((SELECT islandid FROM islands WHERE islandname == ?),
 668          (SELECT islandid FROM islands WHERE islandname == ?),
 669          ?);
 670 END
 671     ;
 672     foreach my $ia (sort keys %wiisland2node) {
 673         my $na= $wiisland2node{$ia};
 674         foreach my $ib (sort keys %wiisland2node) {
 675             my $nb= $wiisland2node{$ib};
 676             my $apdist= $ia eq $ib ? 0 : widist($na,$nb);
 677             die "$ia $ib" unless defined $apdist;
 678             my $sprdist= $wispr->get_edge_weight($ia,$ib);
 679             die "$ia $ib $apdist $sprdist" if
 680                 defined($sprdist) && $sprdist != $apdist;
 681
 682             $adddist->execute($ia,$ib,$apdist);
 683             $addroute->execute($ia,$ib,$sprdist) if defined $sprdist;
 684         }
 685     }
 686
 687     # select ia.islandname, ib.islandname, d.dist from dists as d, islands as ia on d.aiid = ia.islandid, islands as ib on d.biid = ib.islandid order by ia.islandname, ib.islandname;
 688
 689 }
 690
 691 #========== update _ocean-*.txt ==========
 692
 693 our $localtopo_path;
 694
 695 sub localtopo_rewrite () {
 696     $localtopo_path= '_ocean-'.(lc $ocean).'.txt';
 697     my $fh= new IO::File "$localtopo_path.tmp", 'w';
 698     print $fh "# autogenerated - do not edit\n" or die $!;
 699     print $fh "ocean $ocean\n" or die $!;
 700     my %arches;
 701     foreach my $isle (sort keys %wtisland2arch) {
 702         my $arch= $wtisland2arch{$isle};
 703         push @{ $arches{$arch} }, $isle;
 704     }
 705     foreach my $arch (sort keys %arches) {
 706         print $fh " $arch\n" or die $!;
 707         foreach my $isle (@{ $arches{$arch} }) {
 708             print $fh "  $isle\n" or die $!;
 709         }
 710     }
 711     print $fh "\n" or die $!;
 712     close $fh or die $!;
 713 }
 714
 715 sub localtopo_commit () {
 716     rename "$localtopo_path.tmp", $localtopo_path or die $!;
 717 }
 718
 719 #========== main program ==========
 720
 721 parse_info_serverside();
 722
 723 progress("fetching yppedia chart");         yppedia_ocean_fetch_chart();
 724 progress("adding shortcuts");               yppedia_graphs_add_shortcuts();
 725 progress("pruning boring vertices");        yppedia_graphs_prune_boring();
 726 progress("checking yppedia graphs");        yppedia_graphs_check();
 727 progress("setting archs from source-info"); yppedia_archs_sourceinfo();
 728 progress("computing shortest paths");       yppedia_graph_shortest_paths();
 729 progress("setting archs from labels");      yppedia_archs_chart_labels();
 730 progress("setting archs from nearby");      yppedia_archs_fillbynearest();
 731 progress("computing yppedia spr");          yppedia_graph_spr();
 732
 733 if (!$stdin_chart) {
 734     progress("fetching yppedia ocean text");    yppedia_ocean_fetch_text();
 735 }
 736
 737 db_setocean($ocean);
 738 db_connect();
 739 my $iteration=0;
 740 for (;;) {
 741     progress("reading database");
 742     database_fetch_ocean();
 743     progress("computing database spr");         database_graph_spr();
 744
 745     progress("comparing islands");              compare_island_lists();
 746     progress("comparing distances");            compare_distances();
 747
 748     print "\n";
 749     print_messages();
 750
 751     foreach my $k (@msgkinds) {
 752         my $n= $msgkindprinted{$k};
 753         next unless $n;
 754         printf STDERR "*** %d%s %ss\n", $n, $iteration?' additional':'', $k;
 755     }
 756
 757     if ($msgs{'error'}) {
 758         print STDERR "*** errors, aborting update\n";
 759         exit 1;
 760     }
 761
 762     if (!%msgkindprinted) {
 763         progress("updating database");         database_do_updates();
 764         progress("updating _ocean-*.txt");     localtopo_rewrite();
 765         if ($stdin_chart) {
 766             print STDERR "*** --stdin-chart, aborting!\n";
 767             exit 1;
 768         }
 769         progress("committing database");       $dbh->commit();
 770         progress("committing _ocean-*.txt");   localtopo_commit();
 771         exit 0;
 772     }
 773     $dbh->rollback();
 774
 775     my $default= !$msgkindprinted{'warning'};
 776     printf STDERR "*** confirm update %s ? ", $default?'(y/n)':'(n/y)';
 777
 778     if ($stdin_chart) {
 779         printf STDERR "[--stdin-chart]\n";
 780         exit 1;
 781     }
 782
 783     $!=0; my $result= <STDIN>;  defined $result or die $!;
 784     $result =~ s/\s//g;
 785     $result= $default?'y':'n' if !length $result;
 786     $result= $result =~ m/^y/i;
 787
 788     if (!$result) {
 789         printf STDERR "*** updated abandoned at your request\n";
 790         exit 1;
 791     }
 792
 793     print "\n";
 794     undef %msgkindprinted;
 795     $iteration++;
 796 }
 797
 798 print_messages();