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