chiark / gitweb /
Do not include self-edges in routes
[ypp-sc-tools.main.git] / 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();