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