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