yarrg/yppedia-chart-parser

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