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