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