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