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