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