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
 428     3. G = Closure(F) is the graph of cliques whose edge weights
 429        are the shortest paths in F, one clique for each connected
 430        component in F.
 431
 432     3a. |XY| for vertices X, Y is the weight of the edge XY in G.
 433        If XY is not in G, |XY| is infinite.
 434
 435     4. A `reduction' of G is a subgraph K of G such that Closure(K) = G.
 436        The reduction is `minimal' if there is no strict subgraph K'
 437        of K such that Closure(K') = G.
 438
 439     5. Now each edge of G may be:
 440        - `unnecessary': included in no minimal reductions of G.
 441        - `essential': included in all minimal reductions of G.
 442        - `contingent': included in some but not all.
 443
 444     6. Consider for any edge AC between the vertices A and C,
 445        whether there is any B such that |AB|+|BC| = |AC| ?
 446        (There can be no B such that the sum < |AC| since that would
 447        mean that |AC| wasn't equal to the shortest path length.)
 448
 449     6a. No such B:  AC is therefore the only shortest path from A to C
 450         (since G is not a multigraph).  AC is thus an essential edge.
 451
 452     6b. Some such B: Call all such edges AC `questionable'.
 453
 454     6c. Thus all edges are essential or questionable.
 455
 456     7. Suppose AC is a shortest contingent edge.  AC must be
 457        questionable since it is not essential.  Suppose it is
 458        made questionable by the existence of B such that |AB|+|BC| =
 459        |AC|.  Consider AB and BC.  Since |AB| and |BC| are positive,
 460        |BC| and |AB| must be < |AC| ie AB and BC are shorter than AC.
 461        Since AC is a shortest contingent edge, there must be shortest
 462        paths in G for AB and BC consisting entirely of essential edges.
 463
 464     8. Therefore it is always safe to remove AC since the paths
 465        A..B and B..C will definitely still remain and provide a path
 466        A..B..C with length |AB|+|BC| = |AC|.
 467
 468     9. Thus AC is unnecessary, contradicting the assumption in 7.
 469        There are therefore no shortest contingent edges, and
 470        thus no contingent edges.
 471
 472     10. We can construct a minimal reduction directly: for each edge
 473         AC in G, search for a vertex B such that |AB|+|BC| = |AC|.
 474         If we find none, AC is essential.  If we find one then AC is
 475         not essential and is therefore unnecessary.
 476
 477 END
 478
 479     printf DEBUG "spr %s before %d\n", $what, scalar($g->edges());
 480
 481     my $result= Graph::Undirected->new();
 482     foreach my $edge_ac ($g->edges()) {
 483         my $edgename_ac= join ' .. ', @$edge_ac;
 484         printf DEBUG "spr %s edge %s\n", $what, $edgename_ac;
 485         my $w_ac= $g->get_edge_weight(@$edge_ac);
 486         my $needed= 1;
 487         foreach my $vertex_b ($g->vertices()) {
 488             next if grep { $_ eq $vertex_b } @$edge_ac;
 489             my $w_ab= $g->get_edge_weight($edge_ac->[0], $vertex_b);
 490             next unless defined $w_ab;
 491             next if $w_ab >= $w_ac;
 492             my $w_bc= $g->get_edge_weight($vertex_b, $edge_ac->[1]);
 493             next unless defined $w_ac;
 494             next if $w_ab + $w_bc > $w_ac;
 495             # found path
 496             printf DEBUG "spr %s edge %s unnecessary %s\n",
 497                 $what, $edgename_ac, $vertex_b;
 498             $needed= 0;
 499             last;
 500         }
 501         if ($needed) {
 502             printf DEBUG "spr %s edge %s essential\n", $what, $edgename_ac;
 503             $result->add_weighted_edge(@$edge_ac,$w_ac);
 504         }
 505     }
 506     printf DEBUG "spr %s result %d\n", $what, scalar($result->edges());
 507
 508     my $apsp= $result->APSP_Floyd_Warshall();
 509     foreach my $ia (sort $g->vertices()) {
 510         foreach my $ib (sort $g->vertices()) {
 511             my $din= $g->get_edge_weight($ia,$ib);
 512             my $dout= $apsp->path_length($ia,$ib);
 513             $din= defined($din) ? $din : 'infinity';
 514             $dout= defined($dout) ? $dout : 'infinity';
 515             error("$what spr apsp discrepancy in=$din out=$dout".
 516                   " for $ia .. $ib")
 517                 if $din != $dout;
 518         }
 519     }
 520     return $result;
 521 }
 522
 523 sub yppedia_graph_spr () {
 524     my $base= Graph::Undirected->new();
 525     foreach my $na (sort keys %winode2island) {
 526         my $ia= $winode2island{$na};
 527         foreach my $nb (sort keys %winode2island) {
 528             my $ib= $winode2island{$nb};
 529             $base->add_weighted_edge($ia,$ib, widist($na,$nb));
 530         }
 531     }
 532     $wispr= shortest_path_reduction('wi',$base);
 533 }
 534
 535 sub yppedia_ocean_fetch_start ($) {
 536     my ($chart) = @_;
 537     my @args= ();
 538     push @args, '--chart' if $chart;
 539     push @args, $ocean;
 540     open OCEAN, '-|', "./yppedia-ocean-scraper", @args or die $!;
 541 }
 542 sub yppedia_ocean_fetch_done () {
 543     $?=0; $!=0; close OCEAN; $? and die $?; $! and die $!;
 544 }
 545
 546 sub yppedia_ocean_fetch_chart () {
 547     yppedia_ocean_fetch_start(1);
 548     yppedia_chart_parse();
 549     yppedia_ocean_fetch_done();
 550 }
 551
 552 sub yppedia_ocean_fetch_text () {
 553     yppedia_ocean_fetch_start(0);
 554     my $arch;
 555     while (<OCEAN>) {
 556         chomp;
 557         if (m/^ocean /) {
 558             $' eq $ocean or die;
 559         } elsif (m/^  /) {
 560             die unless defined $arch;
 561             $wtisland2arch{$'}= $arch;
 562         } elsif (m/^ /) {
 563             $arch= $';
 564         } else {
 565             die;
 566         }
 567     }
 568     yppedia_ocean_fetch_done();
 569 }
 570
 571 sub compare_distances () {
 572     foreach my $ia (sort keys %dbisland2arch) {
 573         my $na= $wiisland2node{$ia};
 574         next unless defined $na;
 575         foreach my $ib (sort keys %dbisland2arch) {
 576             next unless $ia le $ib; # do every pair only once
 577             my $dbdist= $dbspr->get_edge_weight($ia,$ib);
 578             my $widist= $wispr->get_edge_weight($ia,$ib);
 579             next unless defined $dbdist || defined $widist;
 580
 581             if (!defined $widist) {
 582                 warning(sprintf "route delete %2d for %s .. %s",
 583                         $dbdist, $ia,$ib);
 584             } elsif (!defined $dbdist) {
 585                 change(sprintf "route new %2d for %s .. %s",
 586                        $widist, $ia,$ib);
 587             } elsif ($dbdist != $widist) {
 588                 change(sprintf "route change %2d to %2d for %s .. %s",
 589                        $dbdist, $widist, $ia,$ib);
 590             }
 591         }
 592     }
 593 }
 594
 595 #========== database handling ==========
 596
 597 sub database_fetch_ocean () {
 598     my ($row,$sth);
 599     $sth= $dbh->prepare('SELECT islandname, archipelago FROM islands');
 600     $sth->execute();
 601     undef %dbisland2arch;
 602     $dbdists= Graph::Undirected->new();
 603     while ($row= $sth->fetchrow_hashref) {
 604         print DEBUG "database-island $row->{'islandname'}".
 605                      " $row->{'archipelago'}\n";
 606         $dbisland2arch{$row->{'islandname'}}= $row->{'archipelago'};
 607     }
 608     $sth= $dbh->prepare('SELECT dist, a.islandname a, b.islandname b
 609                                 FROM dists
 610                                 JOIN islands AS a ON dists.aiid==a.islandid
 611                                 JOIN islands AS b ON dists.biid==b.islandid');
 612     $sth->execute();
 613     while ($row= $sth->fetchrow_hashref) {
 614         $dbdists->add_weighted_edge($row->{'a'}, $row->{'b'}, $row->{'dist'});
 615     }
 616 }
 617
 618 sub database_graph_spr () {
 619     $dbspr= shortest_path_reduction('db',$dbdists);
 620 }
 621
 622 sub database_do_updates () {
 623     my $addisland= $dbh->prepare(<<'END')
 624  INSERT OR IGNORE INTO islands (islandname, archipelago) VALUES (?, ?);
 625 END
 626     ;
 627     foreach my $island (sort keys %wiisland2node) {
 628         my $wiarch= wiisland2arch($island);
 629         $addisland->execute($island, $wiarch);
 630     }
 631
 632     db_doall(<<END)
 633  DELETE FROM dists;
 634  DELETE FROM routes;
 635 END
 636     ;
 637     my $adddist= $dbh->prepare(<<'END')
 638  INSERT INTO dists VALUES
 639         ((SELECT islandid FROM islands WHERE islandname == ?),
 640          (SELECT islandid FROM islands WHERE islandname == ?),
 641          ?);
 642 END
 643     ;
 644     my $addroute= $dbh->prepare(<<'END')
 645  INSERT INTO routes VALUES
 646         ((SELECT islandid FROM islands WHERE islandname == ?),
 647          (SELECT islandid FROM islands WHERE islandname == ?),
 648          ?);
 649 END
 650     ;
 651     foreach my $ia (sort keys %wiisland2node) {
 652         my $na= $wiisland2node{$ia};
 653         foreach my $ib (sort keys %wiisland2node) {
 654             my $nb= $wiisland2node{$ib};
 655             my $apdist= $ia eq $ib ? 0 : widist($na,$nb);
 656             die "$ia $ib" unless defined $apdist;
 657             my $sprdist= $wispr->get_edge_weight($ia,$ib);
 658             die "$ia $ib $apdist $sprdist" if
 659                 defined($sprdist) && $sprdist != $apdist;
 660
 661             $adddist->execute($ia,$ib,$apdist);
 662             $addroute->execute($ia,$ib,$sprdist) if defined $sprdist;
 663         }
 664     }
 665
 666     # 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;
 667
 668 }
 669
 670 #========== update _ocean-*.txt ==========
 671
 672 our $localtopo_path;
 673
 674 sub localtopo_rewrite () {
 675     $localtopo_path= '_ocean-'.(lc $ocean).'.txt';
 676     my $fh= new IO::File "$localtopo_path.tmp", 'w';
 677     print $fh "# autogenerated - do not edit\n" or die $!;
 678     print $fh "ocean $ocean\n" or die $!;
 679     my %arches;
 680     foreach my $isle (sort keys %wtisland2arch) {
 681         my $arch= $wtisland2arch{$isle};
 682         push @{ $arches{$arch} }, $isle;
 683     }
 684     foreach my $arch (sort keys %arches) {
 685         print $fh " $arch\n" or die $!;
 686         foreach my $isle (@{ $arches{$arch} }) {
 687             print $fh "  $isle\n" or die $!;
 688         }
 689     }
 690     print $fh "\n" or die $!;
 691     close $fh or die $!;
 692 }
 693
 694 sub localtopo_commit () {
 695     rename "$localtopo_path.tmp", $localtopo_path or die $!;
 696 }
 697
 698 #========== main program ==========
 699
 700 parse_info_serverside();
 701
 702 progress("fetching yppedia chart");         yppedia_ocean_fetch_chart();
 703 progress("adding shortcuts");               yppedia_graphs_add_shortcuts();
 704 progress("pruning boring vertices");        yppedia_graphs_prune_boring();
 705 progress("checking yppedia graphs");        yppedia_graphs_check();
 706 progress("setting archs from source-info"); yppedia_archs_sourceinfo();
 707 progress("computing shortest paths");       yppedia_graph_shortest_paths();
 708 progress("setting archs from labels");      yppedia_archs_chart_labels();
 709 progress("setting archs from nearby");      yppedia_archs_fillbynearest();
 710 progress("computing yppedia spr");          yppedia_graph_spr();
 711 progress("fetching yppedia ocean text");    yppedia_ocean_fetch_text();
 712
 713 db_setocean($ocean);
 714 db_connect();
 715 my $iteration=0;
 716 for (;;) {
 717     progress("reading database");
 718     database_fetch_ocean();
 719     progress("computing database spr");         database_graph_spr();
 720
 721     progress("comparing islands");              compare_island_lists();
 722     progress("comparing distances");            compare_distances();
 723
 724     print "\n";
 725     print_messages();
 726
 727     foreach my $k (@msgkinds) {
 728         my $n= $msgkindprinted{$k};
 729         next unless $n;
 730         printf STDERR "*** %d%s %ss\n", $n, $iteration?' additional':'', $k;
 731     }
 732
 733     if ($msgs{'error'}) {
 734         print STDERR "*** errors, aborting update\n";
 735         exit 1;
 736     }
 737
 738     if (!%msgkindprinted) {
 739         progress("updating database");         database_do_updates();
 740         progress("updating _ocean-*.txt");     localtopo_rewrite();
 741         progress("committing database");       $dbh->commit();
 742         progress("committing _ocean-*.txt");   localtopo_commit();
 743         exit 0;
 744     }
 745     $dbh->rollback();
 746
 747     my $default= !$msgkindprinted{'warning'};
 748     printf STDERR "*** confirm update %s ? ", $default?'(y/n)':'(n/y)';
 749
 750     $!=0; my $result= <STDIN>;  defined $result or die $!;
 751     $result =~ s/\s//g;
 752     $result= $default?'y':'n' if !length $result;
 753     $result= $result =~ m/^y/i;
 754
 755     if (!$result) {
 756         printf STDERR "*** updated abandoned at your request\n";
 757         exit 1;
 758     }
 759
 760     print "\n";
 761     undef %msgkindprinted;
 762     $iteration++;
 763 }
 764
 765 print_messages();