10 my $ocean= 'Midnight';
13 my $widists= Graph::Undirected->new();
14 my $wiarchs= Graph::Undirected->new();
24 my $dbdists= Graph::Undirected->new();
28 sub pmsg ($$) { push @{ $msgs{$_[0]} }, "$_[0]: $_[1]\n"; }
29 sub warning ($) { pmsg("warning",$_[0]); }
30 sub error ($) { pmsg("error", $_[0]); }
31 sub change ($) { pmsg("change", $_[0]); }
32 sub print_messages () {
33 foreach my $k (qw(change warning error)) {
36 print sort @$m or die $!;
39 sub progress ($) { print "($_[0])\n"; }
41 if (@ARGV && $ARGV[0] eq '--debug') {
43 open DEBUG, ">&STDOUT" or die $!;
46 open DEBUG, ">/dev/null" or die $!;
53 my $tp= (0+$x ^ 0+$y) & 1;
54 defined $parity or $parity=$tp;
55 $tp==$parity or warning("line $.: parity error $x,$y is $tp not $parity");
57 $winode2lines{$n}{$.}++;
61 sub yppedia_chart_parse () {
62 # We don't even bother with tag soup; instead we do line-oriented parsing.
66 s/^\s*//; chomp; s/\s+$//; s/\s+/ /g;
68 s/\{\{Chart\ style\|[^{}]*\}\}//g;
69 next unless m/\{\{/; # only interested in chart template stuff
71 my ($x,$y, $arch,$island,$solid,$dirn);
72 my $nn= sub { return nn_xy($x,$y) };
75 m/^\{\{ chart\ label \|(\d+)\|(\d+)\| .*
76 \'\[\[ [^][\']* \| (\S+)\ archipelago \]\]\'*\}\}$/xi) {
77 printf DEBUG "%2d,%-2d arch %s\n", $x,$y,$arch;
78 push @wiarchlabels, [ $x,$y,$arch ];
79 } elsif (($x,$y,$island) =
80 m/^\{\{ chart\ island\ icon \|(\d+)\|(\d+)\|
81 ([^| ][^|]*[^| ]) \| .*\}\}$/xi) {
83 $wiisland2node{$island}= $n;
84 $winode2island{$n}= $island;
85 $widists->add_vertex($n);
86 $wiarchs->add_vertex($n);
87 printf DEBUG "%2d,%-2d island %s\n", $x,$y,$island;
88 } elsif (($solid,$x,$y,$dirn) =
89 m/^\{\{ chart\ league((?:\ solid)?) \|(\d+)\|(\d+)\|
90 ([-\/\\o]) \| .*\}\}$/xi) {
93 my ($bx,$by) = ($x,$y);
94 if ($dirn eq '-') { $bx+=2; }
95 elsif ($dirn eq '\\') { $bx++; $by++; }
96 elsif ($dirn eq '/') { $x++; $by++; }
99 my $nb= nn_xy($bx,$by);
100 $widists->add_weighted_edge($nn->(), $nb, 1);
101 $wiarchs->add_edge($nn->(), $nb) if $solid;
102 $wiarchs->add_edge($nn->(), $nb) if $solid;
104 printf DEBUG "%2d,%-2d league %-6s %s %s\n", $x,$y,
105 $solid?'solid':'dotted', $dirn, $nb;
107 m/^\{\{ chart\ head \}\}$/xi
111 warning("line $.: ignoring incomprehensible: $_");
116 sub database_fetch_ocean () {
118 $sth= $dbh->prepare('SELECT islandname, archipelago FROM islands');
120 while ($row= $sth->fetchrow_hashref) {
121 print DEBUG "database-island $row->{'islandname'}".
122 " $row->{'archipelago'}\n";
123 $dbisland2arch{$row->{'islandname'}}= $row->{'archipelago'};
125 $sth= $dbh->prepare('SELECT dist, a.islandname a, b.islandname b
127 JOIN islands AS a ON dists.aiid==a.islandid
128 JOIN islands AS b ON dists.biid==b.islandid');
130 while ($row= $sth->fetchrow_hashref) {
131 $dbdists->add_weighted_edge($row->{'a'}, $row->{'b'}, $row->{'dist'});
135 sub database_graph_spr () {
136 $dbspr= shortest_path_reduction('db',$dbdists);
139 sub yppedia_graphs_add_shortcuts () {
140 # We add edges between LPs we know about, as you can chart
141 # between them. Yppedia often lacks these edges.
143 foreach my $p ($widists->vertices) {
144 my ($ax,$ay) = $p =~ m/^(\d+)\,(\d+)$/ or die;
145 my $add_shortcut= sub {
146 my $q= sprintf "%d,%d", $ax+$_[0], $ay+$_[1];
147 return unless $widists->has_vertex($q);
148 return if $widists->has_edge($p,$q);
149 printf DEBUG "%-5s league-shortcut %-5s\n", $p, $q;
150 $widists->add_weighted_edge($p,$q,1);
152 $add_shortcut->( 2,0);
153 $add_shortcut->(+1,1);
154 $add_shortcut->(-1,1);
158 sub yppedia_graphs_prune_boring () {
159 # Prune the LP database by eliminating boring intermediate vertices
160 foreach my $delete ($widists->vertices()) {
161 next if exists $winode2island{$delete};
162 my @neigh= $widists->neighbours($delete);
163 next unless @neigh==2;
165 map { $weight += $widists->get_edge_weight($delete, $_) } @neigh;
166 $widists->add_weighted_edge(@neigh, $weight);
167 $widists->delete_vertex($delete);
168 printf DEBUG "%-5s elide %5s %-5s %2d\n", $delete, @neigh, $weight;
172 sub yppedia_graphs_check () {
173 # Check that it's connected.
174 foreach my $cc ($widists->connected_components()) {
175 next if 2*@$cc > $widists->vertices();
176 my $m= "disconnected league point(s):";
177 foreach my $n (@$cc) {
178 $m .= "\n LP $n, def. yppedia line(s): ".
179 join(',', sort keys %{ $winode2lines{$n} });
185 sub yppedia_archs_sourceinfo () {
186 # Assign archipelagoes according to the source-info file
187 foreach my $arch (sort keys %{ $oceans{$ocean} }) {
188 foreach my $islename (sort keys %{ $oceans{$ocean}{$arch} }) {
189 my $islenode= $wiisland2node{$islename};
191 error("island $islename in source-info but not in WP map");
192 my $ccix= $wiarchs->connected_component_by_vertex($islenode);
193 my $oldarch= $wiccix2arch{$ccix};
194 error("island $islename in $arch in source-info".
195 " connected to $oldarch as well")
196 if defined $oldarch && $oldarch ne $arch;
197 printf DEBUG "%-5s force-island-arch cc%-2d %-10s %s\n",
198 $islenode, $ccix, $arch, $islename;
199 $wiccix2arch{$ccix}= $arch;
204 sub yppedia_archs_chart_labels () {
205 # Assign archipelago labels to groups of islands
207 foreach my $label (@wiarchlabels) {
208 my ($ax,$ay,$arch) = @$label;
209 my $best_ccmulti= -1;
212 # print DEBUG "$ax,$ay arch-island-search $arch\n";
213 $ay += 1; $ax += 2; # coords are rather to the top left of label
214 foreach my $vertex ($wiarchs->vertices()) {
215 next unless exists $winode2island{$vertex};
216 my $ccix= $wiarchs->connected_component_by_vertex($vertex);
217 my @cc= $wiarchs->connected_component_by_index($ccix);
218 my $ccmulti= @cc > 1;
219 my ($vx,$vy) = split /,/, $vertex;
220 my $d2= ($vx-$ax)*($vx-$ax) + ($vy-$ay)*($vy-$ay);
221 my $cmp= $ccmulti <=> $best_ccmulti
223 printf DEBUG "%2d,%-2d arch-island-search %5s d2=%4d cc%-2d".
224 " #cc=%2d ccmulti=%d cmp=%2d %s\n",
225 $ax,$ay, $vertex, $d2, $ccix, scalar(@cc), $ccmulti, $cmp,
226 $winode2island{$vertex};
227 next unless $cmp > 0;
230 $best_ccmulti= $ccmulti;
232 die 'no island vertices?!' unless defined $best_n;
233 my $ccix= $wiarchs->connected_component_by_vertex($best_n);
235 "%2d,%-2d arch-island-select %-5s d2=%4d cc%-2d %-10s %s\n",
236 $ax,$ay, $best_n, $ccix, $best_d2, $arch, $winode2island{$best_n};
237 my $desc= join "\n", map {
238 my $in= $winode2island{$_};
239 " LP $_". (defined $in ? ", $in" : "");
240 } sort $wiarchs->connected_component_by_index($ccix);
242 if (exists $wiccix2arch{$ccix} and $wiccix2arch{$ccix} ne $arch) {
243 error("archipelago determination failed, wrongly merged:\n".
244 " archipelago $arch\n".
245 " archipelago $wiccix2arch{$ccix}\n".
249 $wiccix2arch{$ccix}= $arch;
250 # print "$ccix $arch ::\n$desc\n";
254 sub yppedia_archs_fillbynearest() {
255 # Assign islands not labelled above to archipelagoes.
257 # We do this by, for each connected component (set of islands
258 # linked by purchaseable charts), searching for the nearest other
259 # connected component which has already been assigned an arch.
260 # `Nearest' means shortest distance of unpurchaseable charts, in
263 # we need only consider vertices which weren't `boring intermediate
264 # vertices' (removed during optimisation as being of order 2)
265 my @ccs_useful= map {
266 [ grep { $widists->has_vertex($_) } @$_ ]
267 } $wiarchs->connected_components();
271 foreach my $sourceccix (0..$#ccs_useful) {
272 next if defined $wiccix2arch{$sourceccix};
273 next unless $ccs_useful[$sourceccix];
275 my @sourcecc= $wiarchs->connected_component_by_index($sourceccix);
276 my @islandnodes= grep { $winode2island{$_} } @sourcecc;
277 next unless @islandnodes; # don't care, then
279 foreach my $islandnode (@islandnodes) {
280 printf DEBUG "%-5s arch-join-need cc%-2d %s\n",
281 $islandnode, $sourceccix, $winode2island{$islandnode};
283 my $best_dist= 9999999;
284 my ($best_target, $best_targetccix, $best_source);
285 foreach my $targetccix (0..$#ccs_useful) {
286 next unless defined $wiccix2arch{$targetccix}; # not helpful
287 next unless $ccs_useful[$targetccix];
288 foreach my $target ($wiarchs->
289 connected_component_by_index($targetccix)) {
290 next unless $widists->has_vertex($target);
291 foreach my $source (@sourcecc) {
292 my $target_dist= widist($target,$source);
293 next unless defined $target_dist;
294 next if $target_dist >= $best_dist;
295 $best_dist= $target_dist;
296 $best_source= $source;
297 $best_target= $target;
298 $best_targetccix= $targetccix;
302 die "no possible target ?!" unless defined $best_target;
304 my $arch= $wiccix2arch{$best_targetccix};
305 my $best_island= $winode2island{$best_target};
306 printf DEBUG "%-5s arch-join-to %-5s dist=%2d cc%-2d %-10s %s\n",
307 $best_source, $best_target, $best_dist,
308 $best_targetccix, $arch,
309 defined($best_island) ? $best_island : "-";
311 push @assignments, [ $sourceccix, $arch ];
313 foreach my $assign (@assignments) {
314 $wiccix2arch{$assign->[0]}= $assign->[1];
318 sub yppedia_graph_shortest_paths () {
319 $wialldists= $widists->APSP_Floyd_Warshall();
324 my $pl= $wialldists->path_length($p,$q);
325 # die "$p $q" unless defined $pl;
326 # my @pv= $wialldists->path_vertices($p,$q);
327 # if (@pv == $pl) { return $pl; }
328 # printf DEBUG "%-5s PATHLENGTH %-5s pl=%s pv=%s\n", $p,$q,$pl,join('|',@pv);
332 sub winode2arch ($) {
334 my $ccix= $wiarchs->connected_component_by_vertex($node);
335 return $wiccix2arch{$ccix};
337 sub wiisland2arch ($) {
339 my $node= $wiisland2node{$island};
340 die "$island ?" unless defined $node;
341 return winode2arch($node);
344 sub compare_island_lists () {
345 foreach my $island (sort keys %dbisland2arch) {
346 my $node= $wiisland2node{$island};
347 if (!defined $node) {
348 error("would delete island: $island");
351 my $wiarch= winode2arch($node);
352 if (!defined $wiarch) {
353 error("island has no arch: $island");
356 my $dbarch= $dbisland2arch{$island};
357 if ($wiarch ne $dbarch) {
358 change("archipelago change from $dbarch to $wiarch".
359 " for island $island");
362 foreach my $island (sort keys %wiisland2node) {
363 my $dbarch= $dbisland2arch{$island};
364 if (!defined $dbarch) {
365 my $wiarch= wiisland2arch($island);
366 if (!defined $wiarch) {
367 error("new island has no arch: $island");
369 # We check arches of non-new islands above
371 change("island new in $wiarch: $island");
376 sub shortest_path_reduction ($$) {
379 # Takes a graph $g (and a string for messages $what) and returns
380 # a new graph which is the miminal shortest path transient reduction
383 # We also check that the shortest path closure of the intended result
384 # is the same graph as the input. Thus the input must itself be
385 # a shortest path closure; if it isn't, we die.
387 my $proof=<<'END'; # way to make a big comment
389 Premises and definitions:
391 1. F is an undirected weighted graph with positive edge weights.
393 2. All graphs we will consider have the same vertices as F.
395 3. G = Closure(F) is the graph of cliques whose edge weights
396 are the shortest paths in F, one clique for each connected
399 3a. |XY| for vertices X, Y is the weight of the edge XY in G.
400 If XY is not in G, |XY| is infinite.
402 4. A `reduction' of G is a subgraph K of G such that Closure(K) = G.
403 The reduction is `minimal' if there is no strict subgraph K'
404 of K such that Closure(K') = G.
406 5. Now each edge of G may be:
407 - `unnecessary': included in no minimal reductions of G.
408 - `essential': included in all minimal reductions of G.
409 - `contingent': included in some but not all.
411 6. Consider for any edge AC between the vertices A and C,
412 whether there is any B such that |AB|+|BC| = |AC| ?
413 (There can be no B such that the sum < |AC| since that would
414 mean that |AC| wasn't equal to the shortest path length.)
416 6a. No such B: AC is therefore the only shortest path from A to C
417 (since G is not a multigraph). AC is thus an essential edge.
419 6b. Some such B: Call all such edges AC `questionable'.
421 6c. Thus all edges are essential or questionable.
423 7. Suppose AC is a shortest contingent edge. AC must be
424 questionable since it is not essential. Suppose it is
425 made questionable by the existence of B such that |AB|+|BC| =
426 |AC|. Consider AB and BC. Since |AB| and |BC| are positive,
427 |BC| and |AB| must be < |AC| ie AB and BC are shorter than AC.
428 Since AC is a shortest contingent edge, there must be shortest
429 paths in G for AB and BC consisting entirely of essential edges.
431 8. Therefore it is always safe to remove AC since the paths
432 A..B and B..C will definitely still remain and provide a path
433 A..B..C with length |AB|+|BC| = |AC|.
435 9. Thus AC is unnecessary, contradicting the assumption in 7.
436 There are therefore no shortest contingent edges, and
437 thus no contingent edges.
439 10. We can construct a minimal reduction directly: for each edge
440 AC in G, search for a vertex B such that |AB|+|BC| = |AC|.
441 If we find none, AC is essential. If we find one then AC is
442 not essential and is therefore unnecessary.
446 printf DEBUG "spr %s before %d\n", $what, scalar($g->edges());
448 my $result= Graph::Undirected->new();
449 foreach my $edge_ac ($g->edges()) {
450 my $edgename_ac= join ' .. ', @$edge_ac;
451 printf DEBUG "spr %s edge %s\n", $what, $edgename_ac;
452 my $w_ac= $g->get_edge_weight(@$edge_ac);
454 foreach my $vertex_b ($g->vertices()) {
455 next if grep { $_ eq $vertex_b } @$edge_ac;
456 my $w_ab= $g->get_edge_weight($edge_ac->[0], $vertex_b);
457 next unless defined $w_ab;
458 next if $w_ab >= $w_ac;
459 my $w_bc= $g->get_edge_weight($vertex_b, $edge_ac->[1]);
460 next unless defined $w_ac;
461 next if $w_ab + $w_bc > $w_ac;
463 printf DEBUG "spr %s edge %s unnecessary %s\n",
464 $what, $edgename_ac, $vertex_b;
469 printf DEBUG "spr %s edge %s essential\n", $what, $edgename_ac;
470 $result->add_weighted_edge(@$edge_ac,$w_ac);
473 printf DEBUG "spr %s result %d\n", $what, scalar($result->edges());
475 my $apsp= $result->APSP_Floyd_Warshall();
476 foreach my $ia (sort $g->vertices()) {
477 foreach my $ib (sort $g->vertices()) {
478 my $din= $g->get_edge_weight($ia,$ib);
479 my $dout= $apsp->path_length($ia,$ib);
480 $din= defined($din) ? $din : 'infinity';
481 $dout= defined($dout) ? $dout : 'infinity';
482 error("$what spr apsp discrepancy in=$din out=$dout".
490 sub yppedia_graph_spr () {
491 my $base= Graph::Undirected->new();
492 foreach my $na (sort keys %winode2island) {
493 my $ia= $winode2island{$na};
494 foreach my $nb (sort keys %winode2island) {
495 my $ib= $winode2island{$nb};
496 $base->add_weighted_edge($ia,$ib, widist($na,$nb));
499 $wispr= shortest_path_reduction('wi',$base);
502 sub compare_distances () {
503 foreach my $ia (sort keys %dbisland2arch) {
504 my $na= $wiisland2node{$ia};
505 next unless defined $na;
506 foreach my $ib (sort keys %dbisland2arch) {
507 next unless $ia le $ib; # do every pair only once
508 my $dbdist= $dbspr->get_edge_weight($ia,$ib);
509 my $widist= $wispr->get_edge_weight($ia,$ib);
510 next unless defined $dbdist || defined $widist;
512 if (!defined $widist) {
513 warning(sprintf "route delete %2d for %s .. %s",
515 } elsif (!defined $dbdist) {
516 change(sprintf "route new %2d for %s .. %s",
518 } elsif ($dbdist != $widist) {
519 change(sprintf "route change %2d to %2d for %s .. %s",
520 $dbdist, $widist, $ia,$ib);
526 parse_info_serverside();
528 progress("reading database");
532 database_fetch_ocean();
534 progress("computing database spr"); database_graph_spr();
536 progress("reading yppedia chart"); yppedia_chart_parse();
537 progress("adding shortcuts"); yppedia_graphs_add_shortcuts();
538 progress("pruning boring vertices"); yppedia_graphs_prune_boring();
539 progress("checking yppedia graphs"); yppedia_graphs_check();
540 progress("setting archs from source-info"); yppedia_archs_sourceinfo();
541 progress("computing shortest paths"); yppedia_graph_shortest_paths();
542 progress("setting archs from labels"); yppedia_archs_chart_labels();
543 progress("setting archs from nearby"); yppedia_archs_fillbynearest();
544 progress("computing yppedia spr"); yppedia_graph_spr();
546 progress("comparing islands"); compare_island_lists();
547 progress("comparing distances"); compare_distances();