3 # Updater for island topology
5 # This is part of ypp-sc-tools, a set of third-party tools for assisting
6 # players of Yohoho Puzzle Pirates.
8 # Copyright (C) 2009 Ian Jackson <ijackson@chiark.greenend.org.uk>
10 # This program is free software: you can redistribute it and/or modify
11 # it under the terms of the GNU General Public License as published by
12 # the Free Software Foundation, either version 3 of the License, or
13 # (at your option) any later version.
15 # This program is distributed in the hope that it will be useful,
16 # but WITHOUT ANY WARRANTY; without even the implied warranty of
17 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 # GNU General Public License for more details.
20 # You should have received a copy of the GNU General Public License
21 # along with this program. If not, see <http://www.gnu.org/licenses/>.
23 # Yohoho and Puzzle Pirates are probably trademarks of Three Rings and
24 # are used without permission. This program is not endorsed or
25 # sponsored by Three Rings.
27 # usage: ./yppedia-chart-parser OCEAN
29 use strict (qw(vars));
32 use Graph::Undirected;
36 my $widists= Graph::Undirected->new();
37 my $wiarchs= Graph::Undirected->new();
48 my $dbdists= Graph::Undirected->new();
52 sub pmsg ($$) { push @{ $msgs{$_[0]} }, "$_[0]: $_[1]\n"; }
53 sub warning ($) { pmsg("warning",$_[0]); }
54 sub error ($) { pmsg("error", $_[0]); }
55 sub change ($) { pmsg("change", $_[0]); }
56 sub print_messages () {
57 foreach my $k (qw(change warning error)) {
60 print sort @$m or die $!;
63 sub progress ($) { print "($_[0])\n"; }
65 if (@ARGV && $ARGV[0] eq '--debug') {
67 open DEBUG, ">&STDOUT" or die $!;
70 open DEBUG, ">/dev/null" or die $!;
75 $ARGV[0] =~ m/^\-/ and die;
76 my $ocean= shift @ARGV;
82 my $tp= (0+$x ^ 0+$y) & 1;
83 defined $parity or $parity=$tp;
84 $tp==$parity or warning("line $.: parity error $x,$y is $tp not $parity");
86 $winode2lines{$n}{$.}++;
90 sub yppedia_chart_parse () {
91 # We don't even bother with tag soup; instead we do line-oriented parsing.
95 s/^\s*//; chomp; s/\s+$//; s/\s+/ /g;
97 s/\{\{Chart\ style\|[^{}]*\}\}//g;
98 next unless m/\{\{/; # only interested in chart template stuff
100 my ($x,$y, $arch,$island,$solid,$dirn);
101 my $nn= sub { return nn_xy($x,$y) };
104 m/^\{\{ chart\ label \|(\d+)\|(\d+)\| .*
105 \'\[\[ [^][\']* \| (\S+)\ archipelago \]\]\'*\}\}$/xi) {
106 printf DEBUG "%2d,%-2d arch %s\n", $x,$y,$arch;
107 push @wiarchlabels, [ $x,$y,$arch ];
108 } elsif (($x,$y,$island) =
109 m/^\{\{ chart\ island\ icon \|(\d+)\|(\d+)\|
110 ([^| ][^|]*[^| ]) \| .*\}\}$/xi) {
112 $wiisland2node{$island}= $n;
113 $winode2island{$n}= $island;
114 $widists->add_vertex($n);
115 $wiarchs->add_vertex($n);
116 printf DEBUG "%2d,%-2d island %s\n", $x,$y,$island;
117 } elsif (($solid,$x,$y,$dirn) =
118 m/^\{\{ chart\ league((?:\ solid)?) \|(\d+)\|(\d+)\|
119 ([-\/\\o]) \| .*\}\}$/xi) {
120 next if $dirn eq 'o';
122 my ($bx,$by) = ($x,$y);
123 if ($dirn eq '-') { $bx+=2; }
124 elsif ($dirn eq '\\') { $bx++; $by++; }
125 elsif ($dirn eq '/') { $x++; $by++; }
128 my $nb= nn_xy($bx,$by);
129 $widists->add_weighted_edge($nn->(), $nb, 1);
130 $wiarchs->add_edge($nn->(), $nb) if $solid;
131 $wiarchs->add_edge($nn->(), $nb) if $solid;
133 printf DEBUG "%2d,%-2d league %-6s %s %s\n", $x,$y,
134 $solid?'solid':'dotted', $dirn, $nb;
136 m/^\{\{ chart\ head \}\}$/xi
140 warning("line $.: ignoring incomprehensible: $_");
145 sub database_fetch_ocean () {
147 $sth= $dbh->prepare('SELECT islandname, archipelago FROM islands');
149 while ($row= $sth->fetchrow_hashref) {
150 print DEBUG "database-island $row->{'islandname'}".
151 " $row->{'archipelago'}\n";
152 $dbisland2arch{$row->{'islandname'}}= $row->{'archipelago'};
154 $sth= $dbh->prepare('SELECT dist, a.islandname a, b.islandname b
156 JOIN islands AS a ON dists.aiid==a.islandid
157 JOIN islands AS b ON dists.biid==b.islandid');
159 while ($row= $sth->fetchrow_hashref) {
160 $dbdists->add_weighted_edge($row->{'a'}, $row->{'b'}, $row->{'dist'});
164 sub database_graph_spr () {
165 $dbspr= shortest_path_reduction('db',$dbdists);
168 sub yppedia_graphs_add_shortcuts () {
169 # We add edges between LPs we know about, as you can chart
170 # between them. Yppedia often lacks these edges.
172 foreach my $p ($widists->vertices) {
173 my ($ax,$ay) = $p =~ m/^(\d+)\,(\d+)$/ or die;
174 my $add_shortcut= sub {
175 my $q= sprintf "%d,%d", $ax+$_[0], $ay+$_[1];
176 return unless $widists->has_vertex($q);
177 return if $widists->has_edge($p,$q);
178 printf DEBUG "%-5s league-shortcut %-5s\n", $p, $q;
179 $widists->add_weighted_edge($p,$q,1);
181 $add_shortcut->( 2,0);
182 $add_shortcut->(+1,1);
183 $add_shortcut->(-1,1);
187 sub yppedia_graphs_prune_boring () {
188 # Prune the LP database by eliminating boring intermediate vertices
189 foreach my $delete ($widists->vertices()) {
190 next if exists $winode2island{$delete};
191 my @neigh= $widists->neighbours($delete);
192 next unless @neigh==2;
194 map { $weight += $widists->get_edge_weight($delete, $_) } @neigh;
195 $widists->add_weighted_edge(@neigh, $weight);
196 $widists->delete_vertex($delete);
197 printf DEBUG "%-5s elide %5s %-5s %2d\n", $delete, @neigh, $weight;
201 sub yppedia_graphs_check () {
202 # Check that it's connected.
203 foreach my $cc ($widists->connected_components()) {
204 next if 2*@$cc > $widists->vertices();
205 my $m= "disconnected league point(s):";
206 foreach my $n (@$cc) {
207 $m .= "\n LP $n, def. yppedia line(s): ".
208 join(',', sort keys %{ $winode2lines{$n} });
214 sub yppedia_archs_sourceinfo () {
215 # Assign archipelagoes according to the source-info file
216 foreach my $arch (sort keys %{ $oceans{$ocean} }) {
217 foreach my $islename (sort keys %{ $oceans{$ocean}{$arch} }) {
218 my $islenode= $wiisland2node{$islename};
219 if (!defined $islenode) {
220 error("island $islename in source-info but not in WP map");
223 my $ccix= $wiarchs->connected_component_by_vertex($islenode);
224 my $oldarch= $wiccix2arch{$ccix};
225 error("island in $arch in source-info".
226 " connected to $oldarch as well: $islename")
227 if defined $oldarch && $oldarch ne $arch;
228 printf DEBUG "%-5s force-island-arch cc%-2d %-10s %s\n",
229 $islenode, $ccix, $arch, $islename;
230 $wiccix2arch{$ccix}= $arch;
235 sub yppedia_archs_chart_labels () {
236 # Assign archipelago labels to groups of islands
238 foreach my $label (@wiarchlabels) {
239 my ($ax,$ay,$arch) = @$label;
240 my $best_ccmulti= -1;
243 # print DEBUG "$ax,$ay arch-island-search $arch\n";
244 $ay += 1; $ax += 2; # coords are rather to the top left of label
245 foreach my $vertex ($wiarchs->vertices()) {
246 next unless exists $winode2island{$vertex};
247 my $ccix= $wiarchs->connected_component_by_vertex($vertex);
248 my @cc= $wiarchs->connected_component_by_index($ccix);
249 my $ccmulti= @cc > 1;
250 my ($vx,$vy) = split /,/, $vertex;
251 my $d2= ($vx-$ax)*($vx-$ax) + ($vy-$ay)*($vy-$ay);
252 my $cmp= $ccmulti <=> $best_ccmulti
254 printf DEBUG "%2d,%-2d arch-island-search %5s d2=%4d cc%-2d".
255 " #cc=%2d ccmulti=%d cmp=%2d %s\n",
256 $ax,$ay, $vertex, $d2, $ccix, scalar(@cc), $ccmulti, $cmp,
257 $winode2island{$vertex};
258 next unless $cmp > 0;
261 $best_ccmulti= $ccmulti;
263 die 'no island vertices?!' unless defined $best_n;
264 my $ccix= $wiarchs->connected_component_by_vertex($best_n);
266 "%2d,%-2d arch-island-select %-5s d2=%4d cc%-2d %-10s %s\n",
267 $ax,$ay, $best_n, $ccix, $best_d2, $arch, $winode2island{$best_n};
268 my $desc= join "\n", map {
269 my $in= $winode2island{$_};
270 " LP $_". (defined $in ? ", $in" : "");
271 } sort $wiarchs->connected_component_by_index($ccix);
273 if (exists $wiccix2arch{$ccix} and $wiccix2arch{$ccix} ne $arch) {
274 error("archipelago determination failed, wrongly merged:\n".
275 " archipelago $arch\n".
276 " archipelago $wiccix2arch{$ccix}\n".
280 $wiccix2arch{$ccix}= $arch;
281 # print "$ccix $arch ::\n$desc\n";
285 sub yppedia_archs_fillbynearest() {
286 # Assign islands not labelled above to archipelagoes.
288 # We do this by, for each connected component (set of islands
289 # linked by purchaseable charts), searching for the nearest other
290 # connected component which has already been assigned an arch.
291 # `Nearest' means shortest distance of unpurchaseable charts, in
294 # we need only consider vertices which weren't `boring intermediate
295 # vertices' (removed during optimisation as being of order 2)
296 my @ccs_useful= map {
297 [ grep { $widists->has_vertex($_) } @$_ ]
298 } $wiarchs->connected_components();
302 foreach my $sourceccix (0..$#ccs_useful) {
303 next if defined $wiccix2arch{$sourceccix};
304 next unless $ccs_useful[$sourceccix];
306 my @sourcecc= $wiarchs->connected_component_by_index($sourceccix);
307 my @islandnodes= grep { $winode2island{$_} } @sourcecc;
308 next unless @islandnodes; # don't care, then
310 foreach my $islandnode (@islandnodes) {
311 printf DEBUG "%-5s arch-join-need cc%-2d %s\n",
312 $islandnode, $sourceccix, $winode2island{$islandnode};
314 my $best_dist= 9999999;
315 my ($best_target, $best_targetccix, $best_source);
316 foreach my $targetccix (0..$#ccs_useful) {
317 next unless defined $wiccix2arch{$targetccix}; # not helpful
318 next unless $ccs_useful[$targetccix];
319 foreach my $target ($wiarchs->
320 connected_component_by_index($targetccix)) {
321 next unless $widists->has_vertex($target);
322 foreach my $source (@sourcecc) {
323 my $target_dist= widist($target,$source);
324 next unless defined $target_dist;
325 next if $target_dist >= $best_dist;
326 $best_dist= $target_dist;
327 $best_source= $source;
328 $best_target= $target;
329 $best_targetccix= $targetccix;
333 die "no possible target ?!" unless defined $best_target;
335 my $arch= $wiccix2arch{$best_targetccix};
336 my $best_island= $winode2island{$best_target};
337 printf DEBUG "%-5s arch-join-to %-5s dist=%2d cc%-2d %-10s %s\n",
338 $best_source, $best_target, $best_dist,
339 $best_targetccix, $arch,
340 defined($best_island) ? $best_island : "-";
342 push @assignments, [ $sourceccix, $arch ];
344 foreach my $assign (@assignments) {
345 $wiccix2arch{$assign->[0]}= $assign->[1];
349 sub yppedia_graph_shortest_paths () {
350 $wialldists= $widists->APSP_Floyd_Warshall();
355 my $pl= $wialldists->path_length($p,$q);
356 # die "$p $q" unless defined $pl;
357 # my @pv= $wialldists->path_vertices($p,$q);
358 # if (@pv == $pl) { return $pl; }
359 # printf DEBUG "%-5s PATHLENGTH %-5s pl=%s pv=%s\n", $p,$q,$pl,join('|',@pv);
363 sub winode2arch ($) {
365 my $ccix= $wiarchs->connected_component_by_vertex($node);
366 return $wiccix2arch{$ccix};
368 sub wiisland2arch ($) {
370 my $node= $wiisland2node{$island};
371 die "$island ?" unless defined $node;
372 return winode2arch($node);
375 sub compare_island_lists () {
376 foreach my $island (sort keys %dbisland2arch) {
377 my $node= $wiisland2node{$island};
378 if (!defined $node) {
379 error("would delete island: $island");
382 my $wiarch= winode2arch($node);
383 if (!defined $wiarch) {
384 error("island has no arch: $island");
387 my $dbarch= $dbisland2arch{$island};
388 if ($wiarch ne $dbarch) {
389 change("archipelago change from $dbarch to $wiarch".
390 " for island $island");
393 foreach my $island (sort keys %wiisland2node) {
394 my $wtarch= $wtisland2arch{$island};
395 my $wiarch= wiisland2arch($island);
396 if (!defined $wtarch) {
397 error("island from chart not found on ocean page: $island");
398 } elsif (defined $wiarch and $wtarch ne $wiarch) {
399 error("island in $wtarch on ocean page but".
400 " concluded $wiarch from chart: $island");
403 my $dbarch= $dbisland2arch{$island};
404 if (!defined $dbarch) {
405 my $wiarch= wiisland2arch($island);
406 if (!defined $wiarch) {
407 error("new island has no arch: $island");
409 # We check arches of non-new islands above
411 change("island new in $wiarch: $island");
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");
421 sub shortest_path_reduction ($$) {
424 # Takes a graph $g (and a string for messages $what) and returns
425 # a new graph which is the miminal shortest path transient reduction
428 # We also check that the shortest path closure of the intended result
429 # is the same graph as the input. Thus the input must itself be
430 # a shortest path closure; if it isn't, we die.
432 my $proof=<<'END'; # way to make a big comment
434 Premises and definitions:
436 1. F is an undirected weighted graph with positive edge weights.
438 2. All graphs we will consider have the same vertices as F.
440 3. G = Closure(F) is the graph of cliques whose edge weights
441 are the shortest paths in F, one clique for each connected
444 3a. |XY| for vertices X, Y is the weight of the edge XY in G.
445 If XY is not in G, |XY| is infinite.
447 4. A `reduction' of G is a subgraph K of G such that Closure(K) = G.
448 The reduction is `minimal' if there is no strict subgraph K'
449 of K such that Closure(K') = G.
451 5. Now each edge of G may be:
452 - `unnecessary': included in no minimal reductions of G.
453 - `essential': included in all minimal reductions of G.
454 - `contingent': included in some but not all.
456 6. Consider for any edge AC between the vertices A and C,
457 whether there is any B such that |AB|+|BC| = |AC| ?
458 (There can be no B such that the sum < |AC| since that would
459 mean that |AC| wasn't equal to the shortest path length.)
461 6a. No such B: AC is therefore the only shortest path from A to C
462 (since G is not a multigraph). AC is thus an essential edge.
464 6b. Some such B: Call all such edges AC `questionable'.
466 6c. Thus all edges are essential or questionable.
468 7. Suppose AC is a shortest contingent edge. AC must be
469 questionable since it is not essential. Suppose it is
470 made questionable by the existence of B such that |AB|+|BC| =
471 |AC|. Consider AB and BC. Since |AB| and |BC| are positive,
472 |BC| and |AB| must be < |AC| ie AB and BC are shorter than AC.
473 Since AC is a shortest contingent edge, there must be shortest
474 paths in G for AB and BC consisting entirely of essential edges.
476 8. Therefore it is always safe to remove AC since the paths
477 A..B and B..C will definitely still remain and provide a path
478 A..B..C with length |AB|+|BC| = |AC|.
480 9. Thus AC is unnecessary, contradicting the assumption in 7.
481 There are therefore no shortest contingent edges, and
482 thus no contingent edges.
484 10. We can construct a minimal reduction directly: for each edge
485 AC in G, search for a vertex B such that |AB|+|BC| = |AC|.
486 If we find none, AC is essential. If we find one then AC is
487 not essential and is therefore unnecessary.
491 printf DEBUG "spr %s before %d\n", $what, scalar($g->edges());
493 my $result= Graph::Undirected->new();
494 foreach my $edge_ac ($g->edges()) {
495 my $edgename_ac= join ' .. ', @$edge_ac;
496 printf DEBUG "spr %s edge %s\n", $what, $edgename_ac;
497 my $w_ac= $g->get_edge_weight(@$edge_ac);
499 foreach my $vertex_b ($g->vertices()) {
500 next if grep { $_ eq $vertex_b } @$edge_ac;
501 my $w_ab= $g->get_edge_weight($edge_ac->[0], $vertex_b);
502 next unless defined $w_ab;
503 next if $w_ab >= $w_ac;
504 my $w_bc= $g->get_edge_weight($vertex_b, $edge_ac->[1]);
505 next unless defined $w_ac;
506 next if $w_ab + $w_bc > $w_ac;
508 printf DEBUG "spr %s edge %s unnecessary %s\n",
509 $what, $edgename_ac, $vertex_b;
514 printf DEBUG "spr %s edge %s essential\n", $what, $edgename_ac;
515 $result->add_weighted_edge(@$edge_ac,$w_ac);
518 printf DEBUG "spr %s result %d\n", $what, scalar($result->edges());
520 my $apsp= $result->APSP_Floyd_Warshall();
521 foreach my $ia (sort $g->vertices()) {
522 foreach my $ib (sort $g->vertices()) {
523 my $din= $g->get_edge_weight($ia,$ib);
524 my $dout= $apsp->path_length($ia,$ib);
525 $din= defined($din) ? $din : 'infinity';
526 $dout= defined($dout) ? $dout : 'infinity';
527 error("$what spr apsp discrepancy in=$din out=$dout".
535 sub yppedia_graph_spr () {
536 my $base= Graph::Undirected->new();
537 foreach my $na (sort keys %winode2island) {
538 my $ia= $winode2island{$na};
539 foreach my $nb (sort keys %winode2island) {
540 my $ib= $winode2island{$nb};
541 $base->add_weighted_edge($ia,$ib, widist($na,$nb));
544 $wispr= shortest_path_reduction('wi',$base);
547 sub yppedia_ocean_fetch_start ($) {
550 push @args, '--chart' if $chart;
552 open OCEAN, '-|', "./yppedia-ocean-scraper", @args or die $!;
554 sub yppedia_ocean_fetch_done () {
555 $?=0; $!=0; close OCEAN; $? and die $?; $! and die $!;
558 sub yppedia_ocean_fetch_chart () {
559 yppedia_ocean_fetch_start(1);
560 yppedia_chart_parse();
561 yppedia_ocean_fetch_done();
564 sub yppedia_ocean_fetch_text () {
565 yppedia_ocean_fetch_start(0);
572 die unless defined $arch;
573 $wtisland2arch{$'}= $arch;
580 yppedia_ocean_fetch_done();
583 sub compare_distances () {
584 foreach my $ia (sort keys %dbisland2arch) {
585 my $na= $wiisland2node{$ia};
586 next unless defined $na;
587 foreach my $ib (sort keys %dbisland2arch) {
588 next unless $ia le $ib; # do every pair only once
589 my $dbdist= $dbspr->get_edge_weight($ia,$ib);
590 my $widist= $wispr->get_edge_weight($ia,$ib);
591 next unless defined $dbdist || defined $widist;
593 if (!defined $widist) {
594 warning(sprintf "route delete %2d for %s .. %s",
596 } elsif (!defined $dbdist) {
597 change(sprintf "route new %2d for %s .. %s",
599 } elsif ($dbdist != $widist) {
600 change(sprintf "route change %2d to %2d for %s .. %s",
601 $dbdist, $widist, $ia,$ib);
607 parse_info_serverside();
609 progress("reading database");
613 database_fetch_ocean();
615 progress("computing database spr"); database_graph_spr();
617 progress("fetching yppedia chart"); yppedia_ocean_fetch_chart();
618 progress("adding shortcuts"); yppedia_graphs_add_shortcuts();
619 progress("pruning boring vertices"); yppedia_graphs_prune_boring();
620 progress("checking yppedia graphs"); yppedia_graphs_check();
621 progress("setting archs from source-info"); yppedia_archs_sourceinfo();
622 progress("computing shortest paths"); yppedia_graph_shortest_paths();
623 progress("setting archs from labels"); yppedia_archs_chart_labels();
624 progress("setting archs from nearby"); yppedia_archs_fillbynearest();
625 progress("computing yppedia spr"); yppedia_graph_spr();
627 progress("fetching yppedia ocean text"); yppedia_ocean_fetch_text();
629 progress("comparing islands"); compare_island_lists();
630 progress("comparing distances"); compare_distances();