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 $!;
40 if (@ARGV && $ARGV[0] eq '--debug') {
42 open DEBUG, ">&STDOUT" or die $!;
45 open DEBUG, ">/dev/null" or die $!;
52 my $tp= (0+$x ^ 0+$y) & 1;
53 defined $parity or $parity=$tp;
54 $tp==$parity or warning("line $.: parity error $x,$y is $tp not $parity");
56 $winode2lines{$n}{$.}++;
60 sub yppedia_chart_parse () {
61 # We don't even bother with tag soup; instead we do line-oriented parsing.
65 s/^\s*//; chomp; s/\s+$//; s/\s+/ /g;
67 s/\{\{Chart\ style\|[^{}]*\}\}//g;
68 next unless m/\{\{/; # only interested in chart template stuff
70 my ($x,$y, $arch,$island,$solid,$dirn);
71 my $nn= sub { return nn_xy($x,$y) };
74 m/^\{\{ chart\ label \|(\d+)\|(\d+)\| .*
75 \'\[\[ [^][\']* \| (\S+)\ archipelago \]\]\'*\}\}$/xi) {
76 printf DEBUG "%2d,%-2d arch %s\n", $x,$y,$arch;
77 push @wiarchlabels, [ $x,$y,$arch ];
78 } elsif (($x,$y,$island) =
79 m/^\{\{ chart\ island\ icon \|(\d+)\|(\d+)\|
80 ([^| ][^|]*[^| ]) \| .*\}\}$/xi) {
82 $wiisland2node{$island}= $n;
83 $winode2island{$n}= $island;
84 $widists->add_vertex($n);
85 $wiarchs->add_vertex($n);
86 printf DEBUG "%2d,%-2d island %s\n", $x,$y,$island;
87 } elsif (($solid,$x,$y,$dirn) =
88 m/^\{\{ chart\ league((?:\ solid)?) \|(\d+)\|(\d+)\|
89 ([-\/\\o]) \| .*\}\}$/xi) {
92 my ($bx,$by) = ($x,$y);
93 if ($dirn eq '-') { $bx+=2; }
94 elsif ($dirn eq '\\') { $bx++; $by++; }
95 elsif ($dirn eq '/') { $x++; $by++; }
98 my $nb= nn_xy($bx,$by);
99 $widists->add_weighted_edge($nn->(), $nb, 1);
100 $wiarchs->add_edge($nn->(), $nb) if $solid;
101 $wiarchs->add_edge($nn->(), $nb) if $solid;
103 printf DEBUG "%2d,%-2d league %-6s %s %s\n", $x,$y,
104 $solid?'solid':'dotted', $dirn, $nb;
106 m/^\{\{ chart\ head \}\}$/xi
110 warning("line $.: ignoring incomprehensible: $_");
115 sub database_fetch_ocean () {
117 $sth= $dbh->prepare('SELECT islandname, archipelago FROM islands');
119 while ($row= $sth->fetchrow_hashref) {
120 print DEBUG "database-island $row->{'islandname'}".
121 " $row->{'archipelago'}\n";
122 $dbisland2arch{$row->{'islandname'}}= $row->{'archipelago'};
124 $sth= $dbh->prepare('SELECT dist, a.islandname a, b.islandname b
126 JOIN islands AS a ON dists.aiid==a.islandid
127 JOIN islands AS b ON dists.biid==b.islandid');
129 while ($row= $sth->fetchrow_hashref) {
130 $dbdists->add_weighted_edge($row->{'a'}, $row->{'b'}, $row->{'dist'});
134 sub database_graph_spr () {
135 $dbspr= shortest_path_reduction('db',$dbdists);
138 sub yppedia_graphs_add_shortcuts () {
139 # We add edges between LPs we know about, as you can chart
140 # between them. Yppedia often lacks these edges.
142 foreach my $p ($widists->vertices) {
143 my ($ax,$ay) = $p =~ m/^(\d+)\,(\d+)$/ or die;
144 my $add_shortcut= sub {
145 my $q= sprintf "%d,%d", $ax+$_[0], $ay+$_[1];
146 return unless $widists->has_vertex($q);
147 return if $widists->has_edge($p,$q);
148 printf DEBUG "%-5s league-shortcut %-5s\n", $p, $q;
149 $widists->add_weighted_edge($p,$q,1);
151 $add_shortcut->( 2,0);
152 $add_shortcut->(+1,1);
153 $add_shortcut->(-1,1);
157 sub yppedia_graphs_prune_boring () {
158 # Prune the LP database by eliminating boring intermediate vertices
159 foreach my $delete ($widists->vertices()) {
160 next if exists $winode2island{$delete};
161 my @neigh= $widists->neighbours($delete);
162 next unless @neigh==2;
164 map { $weight += $widists->get_edge_weight($delete, $_) } @neigh;
165 $widists->add_weighted_edge(@neigh, $weight);
166 $widists->delete_vertex($delete);
167 printf DEBUG "%-5s elide %5s %-5s %2d\n", $delete, @neigh, $weight;
171 sub yppedia_graphs_check () {
172 # Check that it's connected.
173 foreach my $cc ($widists->connected_components()) {
174 next if 2*@$cc > $widists->vertices();
175 my $m= "disconnected league point(s):";
176 foreach my $n (@$cc) {
177 $m .= "\n LP $n, def. yppedia line(s): ".
178 join(',', sort keys %{ $winode2lines{$n} });
184 sub yppedia_archs_sourceinfo () {
185 # Assign archipelagoes according to the source-info file
186 foreach my $arch (sort keys %{ $oceans{$ocean} }) {
187 foreach my $islename (sort keys %{ $oceans{$ocean}{$arch} }) {
188 my $islenode= $wiisland2node{$islename};
190 error("island $islename in source-info but not in WP map");
191 my $ccix= $wiarchs->connected_component_by_vertex($islenode);
192 my $oldarch= $wiccix2arch{$ccix};
193 error("island $islename in $arch in source-info".
194 " connected to $oldarch as well")
195 if defined $oldarch && $oldarch ne $arch;
196 printf DEBUG "%-5s force-island-arch cc%-2d %-10s %s\n",
197 $islenode, $ccix, $arch, $islename;
198 $wiccix2arch{$ccix}= $arch;
203 sub yppedia_archs_chart_labels () {
204 # Assign archipelago labels to groups of islands
206 foreach my $label (@wiarchlabels) {
207 my ($ax,$ay,$arch) = @$label;
208 my $best_ccmulti= -1;
211 # print DEBUG "$ax,$ay arch-island-search $arch\n";
212 $ay += 1; $ax += 2; # coords are rather to the top left of label
213 foreach my $vertex ($wiarchs->vertices()) {
214 next unless exists $winode2island{$vertex};
215 my $ccix= $wiarchs->connected_component_by_vertex($vertex);
216 my @cc= $wiarchs->connected_component_by_index($ccix);
217 my $ccmulti= @cc > 1;
218 my ($vx,$vy) = split /,/, $vertex;
219 my $d2= ($vx-$ax)*($vx-$ax) + ($vy-$ay)*($vy-$ay);
220 my $cmp= $ccmulti <=> $best_ccmulti
222 printf DEBUG "%2d,%-2d arch-island-search %5s d2=%4d cc%-2d".
223 " #cc=%2d ccmulti=%d cmp=%2d %s\n",
224 $ax,$ay, $vertex, $d2, $ccix, scalar(@cc), $ccmulti, $cmp,
225 $winode2island{$vertex};
226 next unless $cmp > 0;
229 $best_ccmulti= $ccmulti;
231 die 'no island vertices?!' unless defined $best_n;
232 my $ccix= $wiarchs->connected_component_by_vertex($best_n);
234 "%2d,%-2d arch-island-select %-5s d2=%4d cc%-2d %-10s %s\n",
235 $ax,$ay, $best_n, $ccix, $best_d2, $arch, $winode2island{$best_n};
236 my $desc= join "\n", map {
237 my $in= $winode2island{$_};
238 " LP $_". (defined $in ? ", $in" : "");
239 } sort $wiarchs->connected_component_by_index($ccix);
241 if (exists $wiccix2arch{$ccix} and $wiccix2arch{$ccix} ne $arch) {
242 error("archipelago determination failed, wrongly merged:\n".
243 " archipelago $arch\n".
244 " archipelago $wiccix2arch{$ccix}\n".
248 $wiccix2arch{$ccix}= $arch;
249 # print "$ccix $arch ::\n$desc\n";
253 sub yppedia_archs_fillbynearest() {
254 # Assign islands not labelled above to archipelagoes.
256 # We do this by, for each connected component (set of islands
257 # linked by purchaseable charts), searching for the nearest other
258 # connected component which has already been assigned an arch.
259 # `Nearest' means shortest distance of unpurchaseable charts, in
262 # we need only consider vertices which weren't `boring intermediate
263 # vertices' (removed during optimisation as being of order 2)
264 my @ccs_useful= map {
265 [ grep { $widists->has_vertex($_) } @$_ ]
266 } $wiarchs->connected_components();
270 foreach my $sourceccix (0..$#ccs_useful) {
271 next if defined $wiccix2arch{$sourceccix};
272 next unless $ccs_useful[$sourceccix];
274 my @sourcecc= $wiarchs->connected_component_by_index($sourceccix);
275 my @islandnodes= grep { $winode2island{$_} } @sourcecc;
276 next unless @islandnodes; # don't care, then
278 foreach my $islandnode (@islandnodes) {
279 printf DEBUG "%-5s arch-join-need cc%-2d %s\n",
280 $islandnode, $sourceccix, $winode2island{$islandnode};
282 my $best_dist= 9999999;
283 my ($best_target, $best_targetccix, $best_source);
284 foreach my $targetccix (0..$#ccs_useful) {
285 next unless defined $wiccix2arch{$targetccix}; # not helpful
286 next unless $ccs_useful[$targetccix];
287 foreach my $target ($wiarchs->
288 connected_component_by_index($targetccix)) {
289 next unless $widists->has_vertex($target);
290 foreach my $source (@sourcecc) {
291 my $target_dist= widist($target,$source);
292 next unless defined $target_dist;
293 next if $target_dist >= $best_dist;
294 $best_dist= $target_dist;
295 $best_source= $source;
296 $best_target= $target;
297 $best_targetccix= $targetccix;
301 die "no possible target ?!" unless defined $best_target;
303 my $arch= $wiccix2arch{$best_targetccix};
304 my $best_island= $winode2island{$best_target};
305 printf DEBUG "%-5s arch-join-to %-5s dist=%2d cc%-2d %-10s %s\n",
306 $best_source, $best_target, $best_dist,
307 $best_targetccix, $arch,
308 defined($best_island) ? $best_island : "-";
310 push @assignments, [ $sourceccix, $arch ];
312 foreach my $assign (@assignments) {
313 $wiccix2arch{$assign->[0]}= $assign->[1];
317 sub yppedia_graph_shortest_paths () {
318 $wialldists= $widists->APSP_Floyd_Warshall();
323 my $pl= $wialldists->path_length($p,$q);
324 # die "$p $q" unless defined $pl;
325 # my @pv= $wialldists->path_vertices($p,$q);
326 # if (@pv == $pl) { return $pl; }
327 # printf DEBUG "%-5s PATHLENGTH %-5s pl=%s pv=%s\n", $p,$q,$pl,join('|',@pv);
331 sub winode2arch ($) {
333 my $ccix= $wiarchs->connected_component_by_vertex($node);
334 return $wiccix2arch{$ccix};
336 sub wiisland2arch ($) {
338 my $node= $wiisland2node{$island};
339 die "$island ?" unless defined $node;
340 return winode2arch($node);
343 sub compare_island_lists () {
344 foreach my $island (sort keys %dbisland2arch) {
345 my $node= $wiisland2node{$island};
346 if (!defined $node) {
347 error("would delete island: $island");
350 my $wiarch= winode2arch($node);
351 if (!defined $wiarch) {
352 error("island has no arch: $island");
355 my $dbarch= $dbisland2arch{$island};
356 if ($wiarch ne $dbarch) {
357 change("change archipelago from $dbarch to $wiarch".
358 " for island $island");
361 foreach my $island (sort keys %wiisland2node) {
362 my $dbarch= $dbisland2arch{$island};
363 if (!defined $dbarch) {
364 my $wiarch= wiisland2arch($island);
365 if (!defined $wiarch) {
366 error("new island has no arch: $island");
368 # We check arches of non-new islands above
370 change("new island in $wiarch: $island");
375 sub shortest_path_reduction ($$) {
376 my ($what,$base) = @_;
378 # Takes a graph $base (and a string for messages $what) and returns
379 # a new graph which is the miminal shortest path transient reduction
382 # We also check that the shortest path closure of the intended result
383 # is the same graph as the input. Thus the input must itself be
384 # a shortest path closure; if it isn't, we die.
386 my $proof=<<'END'; # way to make a big comment
388 Premises and definitions:
390 1. F is a connected undirected weighted graph with positive edge
393 2. All graphs we will consider have the same vertices as F.
395 3. G = Closure(F) is the complete graph whose edge weights
396 are the shortest paths in F. (G is the input graph $base.)
398 3a. |XY| for vertices X, Y is the weight of the edge XY in G.
400 4. A `reduction' of G is a subgraph K of G such that Closure(K) = G.
401 The reduction is `minimal' if there is no strict subgraph K'
402 of K such that Closure(K') = G.
404 5. Now each edge of G may be:
405 - `unnecessary': included in no minimal reductions of G.
406 - `essential': included in all minimal reductions of G.
407 - `contingent': included in some but not all.
409 6. Consider for any edge AC between the vertices A and C,
410 whether there is any B such that |AB|+|BC| = |AC| ?
411 (There can be no B such that the sum < |AC| since that would
412 mean that |AC| wasn't equal to the shortest path length.)
414 6a. No such B: AC is therefore the only shortest path from A to C
415 (since G is not a multigraph). AC is thus an essential edge.
417 6b. Some such B: Call all such edges AC `questionable'.
419 6c. Thus all edges are essential or questionable.
421 7. Suppose AC is a shortest contingent edge. AC must be
422 questionable since it is not essential. Suppose it is
423 made questionable by the existence of B such that |AB|+|BC| =
424 |AC|. Consider AB and BC. Since |AB| and |BC| are positive,
425 |BC| and |AB| must be < |AC| ie AB and BC are shorter than AC.
426 Since AC is a shortest contingent edge, there must be shortest
427 paths in G for AB and BC consisting entirely of essential edges.
429 8. Therefore it is always safe to remove AC since the paths
430 A..B and B..C will definitely still remain and provide a path
431 A..B..C with length |AB|+|BC| = |AC|.
433 9. Thus AC is unnecessary, contradicting the assumption in 7.
434 There are therefore no shortest contingent edges, and
435 thus no contingent edges.
437 10. We can construct a minimal reduction directly: for each edge
438 AC in G, search for a vertex B such that |AB|+|BC| = |AC|.
439 If we find none, AC is essential. If we find one then AC is
440 not essential and is therefore unnecessary.
444 printf DEBUG "spr %s before %d\n", $what, scalar($base->edges());
446 my $result= Graph::Undirected->new();
447 foreach my $edge_ac ($base->edges()) {
448 my $edgename_ac= join '..', @$edge_ac;
449 printf DEBUG "spr %s edge %s\n", $what, $edgename_ac;
450 my $w_ac= $base->get_edge_weight(@$edge_ac);
452 foreach my $vertex_b ($base->vertices()) {
453 next if grep { $_ eq $vertex_b } @$edge_ac;
454 my $w_ab= $base->get_edge_weight($edge_ac->[0], $vertex_b);
455 next unless defined $w_ab;
456 next if $w_ab >= $w_ac;
457 my $w_bc= $base->get_edge_weight($vertex_b, $edge_ac->[1]);
458 next unless defined $w_ac;
459 next if $w_ab + $w_bc > $w_ac;
461 printf DEBUG "spr %s edge %s unnecessary %s\n",
462 $what, $edgename_ac, $vertex_b;
467 printf DEBUG "spr %s edge %s essential\n", $what, $edgename_ac;
468 $result->add_weighted_edge(@$edge_ac,$w_ac);
471 printf DEBUG "spr %s result %d\n", $what, scalar($result->edges());
473 my $apsp= $result->APSP_Floyd_Warshall();
474 foreach my $ia (sort $base->vertices()) {
475 foreach my $ib (sort $base->vertices()) {
476 my $din= $base->get_edge_weight($ia,$ib);
477 my $dout= $apsp->path_length($ia,$ib);
478 $din= defined($din) ? $din : 'infinity';
479 $dout= defined($dout) ? $dout : 'infinity';
480 error("$what spr apsp discrepancy in=$din out=$dout for $ia..$ib")
487 sub yppedia_graph_spr () {
488 my $base= Graph::Undirected->new();
489 foreach my $na (sort keys %winode2island) {
490 my $ia= $winode2island{$na};
491 foreach my $nb (sort keys %winode2island) {
492 my $ib= $winode2island{$nb};
493 $base->add_weighted_edge($ia,$ib, widist($na,$nb));
496 $wispr= shortest_path_reduction('wi',$base);
499 sub compare_distances () {
500 foreach my $ia (sort keys %dbisland2arch) {
501 my $na= $wiisland2node{$ia};
502 next unless defined $na;
503 foreach my $ib (sort keys %dbisland2arch) {
504 next unless $ia le $ib; # do every pair only once
505 my $dbdist= $dbspr->get_edge_weight($ia,$ib);
506 my $widist= $wispr->get_edge_weight($ia,$ib);
507 next unless defined $dbdist || defined $widist;
509 if (!defined $widist) {
510 warning(sprintf "route delete %2d for %s..%s",
512 } elsif (!defined $dbdist) {
513 change(sprintf "route create %2d for %s..%s",
515 } elsif ($dbdist != $widist) {
516 change(sprintf "route change %2d to %2d for %s..%s",
517 $dbdist, $widist, $ia,$ib);
523 parse_info_serverside();
525 print "reading database\n";
529 database_fetch_ocean();
531 print "computing database spr\n"; database_graph_spr();
533 print "reading yppedia chart\n"; yppedia_chart_parse();
534 print "adding shortcuts\n"; yppedia_graphs_add_shortcuts();
535 print "pruning boring vertices\n"; yppedia_graphs_prune_boring();
536 print "checking yppedia graphs\n"; yppedia_graphs_check();
537 print "setting archs from source-info\n"; yppedia_archs_sourceinfo();
538 print "computing shortest paths\n"; yppedia_graph_shortest_paths();
539 print "setting archs from labels\n"; yppedia_archs_chart_labels();
540 print "setting archs from nearby\n"; yppedia_archs_fillbynearest();
541 print "computing yppedia spr\n"; yppedia_graph_spr();
545 compare_island_lists();