chiark / gitweb /
Extend proof to non-connected graphs; cosmetic improvements
[ypp-sc-tools.db-live.git] / yarrg / yppedia-chart-parser
1 #!/usr/bin/perl
2
3 use strict (qw(vars));
4 use warnings;
5
6 use Graph::Undirected;
7 use Commods;
8 use CommodsDatabase;
9
10 my $ocean= 'Midnight';
11
12
13 my $widists= Graph::Undirected->new();
14 my $wiarchs= Graph::Undirected->new();
15 my $wispr;
16 my $dbspr;
17 my @wiarchlabels;
18 my %wiisland2node;
19 my %winode2island;
20 my %winode2lines;
21 my %wiccix2arch;
22 my $wialldists;
23
24 my $dbdists= Graph::Undirected->new();
25 my %dbisland2arch;
26
27 my %msgs;
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)) {
34         my $m= $msgs{$k};
35         next unless $m;
36         print sort @$m or die $!;
37     }
38 }
39 sub progress ($) { print "($_[0])\n"; }
40
41 if (@ARGV && $ARGV[0] eq '--debug') {
42     shift @ARGV;
43     open DEBUG, ">&STDOUT" or die $!;
44     select(DEBUG); $|=1;
45 } else {
46     open DEBUG, ">/dev/null" or die $!;
47 }
48 select(STDOUT); $|=1;
49
50 my $parity;
51 sub nn_xy ($$) {
52     my ($x,$y) = @_;
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");
56     my $n= "$_[0],$_[1]";
57     $winode2lines{$n}{$.}++;
58     return $n;
59 }
60
61 sub yppedia_chart_parse () {
62     # We don't even bother with tag soup; instead we do line-oriented parsing.
63
64     while (<>) {
65         s/\<--.*--\>//g;
66         s/^\s*//; chomp; s/\s+$//; s/\s+/ /g;
67         s/\<\/?(?:b|em)\>//g;
68         s/\{\{Chart\ style\|[^{}]*\}\}//g;
69         next unless m/\{\{/; # only interested in chart template stuff
70
71         my ($x,$y, $arch,$island,$solid,$dirn);
72         my $nn= sub { return nn_xy($x,$y) };
73     
74         if (($x,$y,$arch) =
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) {
82             my $n= $nn->();
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) {
91             next if $dirn eq 'o';
92
93             my ($bx,$by) = ($x,$y);
94             if ($dirn eq '-') { $bx+=2; }
95             elsif ($dirn eq '\\') { $bx++; $by++; }
96             elsif ($dirn eq '/') { $x++; $by++; }
97             else { die; }
98
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;
103
104             printf DEBUG "%2d,%-2d league %-6s %s %s\n", $x,$y,
105                 $solid?'solid':'dotted', $dirn, $nb;
106         } elsif (
107             m/^\{\{ chart\ head \}\}$/xi
108                  ) {
109             next;
110         } else {
111             warning("line $.: ignoring incomprehensible: $_");
112         }
113     }
114 }
115
116 sub database_fetch_ocean () {
117     my ($row,$sth);
118     $sth= $dbh->prepare('SELECT islandname, archipelago FROM islands');
119     $sth->execute();
120     while ($row= $sth->fetchrow_hashref) {
121         print DEBUG "database-island $row->{'islandname'}".
122                      " $row->{'archipelago'}\n";
123         $dbisland2arch{$row->{'islandname'}}= $row->{'archipelago'};
124     }
125     $sth= $dbh->prepare('SELECT dist, a.islandname a, b.islandname b
126                                 FROM dists
127                                 JOIN islands AS a ON dists.aiid==a.islandid
128                                 JOIN islands AS b ON dists.biid==b.islandid');
129     $sth->execute();
130     while ($row= $sth->fetchrow_hashref) {
131         $dbdists->add_weighted_edge($row->{'a'}, $row->{'b'}, $row->{'dist'});
132     }
133 }                        
134
135 sub database_graph_spr () {
136     $dbspr= shortest_path_reduction('db',$dbdists);
137 }
138
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.
142     #
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);
151         };
152         $add_shortcut->( 2,0);
153         $add_shortcut->(+1,1);
154         $add_shortcut->(-1,1);
155     }
156 }
157
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;
164         my $weight= 0;
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;
169     }
170 }
171
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} });
180         }
181         warning($m);
182     }
183 }
184
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};
190             defined $islenode or
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;
200         }
201     }
202 }
203
204 sub yppedia_archs_chart_labels () {
205     # Assign archipelago labels to groups of islands
206     #
207     foreach my $label (@wiarchlabels) {
208         my ($ax,$ay,$arch) = @$label;
209         my $best_ccmulti= -1;
210         my $best_d2= 0;
211         my $best_n;
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
222                 ||   $best_d2 <=> $d2;
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;
228             $best_n=       $vertex;
229             $best_d2=      $d2;
230             $best_ccmulti= $ccmulti;
231         }
232         die 'no island vertices?!' unless defined $best_n;
233         my $ccix= $wiarchs->connected_component_by_vertex($best_n);
234         printf DEBUG
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);
241
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".
246                   $desc);
247             next;
248         }
249         $wiccix2arch{$ccix}= $arch;
250 #       print "$ccix $arch ::\n$desc\n";
251     }
252 }
253
254 sub yppedia_archs_fillbynearest() {
255     # Assign islands not labelled above to archipelagoes.
256     #
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
261     # leagues.
262     #
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();
268
269     my @assignments;
270
271     foreach my $sourceccix (0..$#ccs_useful) {
272         next if defined $wiccix2arch{$sourceccix};
273         next unless $ccs_useful[$sourceccix];
274
275         my @sourcecc= $wiarchs->connected_component_by_index($sourceccix);
276         my @islandnodes= grep { $winode2island{$_} } @sourcecc;
277         next unless @islandnodes; # don't care, then
278
279         foreach my $islandnode (@islandnodes) {
280             printf DEBUG "%-5s arch-join-need cc%-2d             %s\n",
281                 $islandnode, $sourceccix, $winode2island{$islandnode};
282         }
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;
299                 }
300             }
301         }
302         die "no possible target ?!" unless defined $best_target;
303
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 : "-";
310
311         push @assignments, [ $sourceccix, $arch ];
312     }
313     foreach my $assign (@assignments) {
314         $wiccix2arch{$assign->[0]}= $assign->[1];
315     }
316 }
317
318 sub yppedia_graph_shortest_paths () {
319     $wialldists= $widists->APSP_Floyd_Warshall();
320 }
321
322 sub widist ($$) {
323     my ($p,$q) = @_;
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);
329     return $pl;
330 }
331                         
332 sub winode2arch ($) {
333     my ($node) = @_;
334     my $ccix= $wiarchs->connected_component_by_vertex($node);
335     return $wiccix2arch{$ccix};
336 }
337 sub wiisland2arch ($) {
338     my ($island) = @_;
339     my $node= $wiisland2node{$island};
340     die "$island ?" unless defined $node;
341     return winode2arch($node);
342 }
343
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");
349             next;
350         }
351         my $wiarch= winode2arch($node);
352         if (!defined $wiarch) {
353             error("island has no arch: $island");
354             next;
355         }
356         my $dbarch= $dbisland2arch{$island};
357         if ($wiarch ne $dbarch) {
358             change("archipelago change from $dbarch to $wiarch".
359                    " for island $island");
360         }
361     }
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");
368                 next;
369                 # We check arches of non-new islands above
370             }
371             change("island new in $wiarch: $island");
372         }
373     }
374 }
375
376 sub shortest_path_reduction ($$) {
377     my ($what,$g) = @_;
378     #
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
381     # of $g.
382     #
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.
386
387     my $proof=<<'END'; # way to make a big comment
388
389     Premises and definitions:
390
391     1. F is an undirected weighted graph with positive edge weights.
392
393     2. All graphs we will consider have the same vertices as F.
394
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
397        component in F.
398
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.
401
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.
405
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.
410
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.)
415
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.
418
419     6b. Some such B: Call all such edges AC `questionable'.
420
421     6c. Thus all edges are essential or questionable.
422
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.
430
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|.
434
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.
438
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.
443
444 END
445     
446     printf DEBUG "spr %s before %d\n", $what, scalar($g->edges());
447
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);
453         my $needed= 1;
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;
462             # found path
463             printf DEBUG "spr %s edge %s unnecessary %s\n",
464                 $what, $edgename_ac, $vertex_b;
465             $needed= 0;
466             last;
467         }
468         if ($needed) {
469             printf DEBUG "spr %s edge %s essential\n", $what, $edgename_ac;
470             $result->add_weighted_edge(@$edge_ac,$w_ac);
471         }
472     }
473     printf DEBUG "spr %s result %d\n", $what, scalar($result->edges());
474
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".
483                   " for $ia .. $ib")
484                 if $din != $dout;
485         }
486     }
487     return $result;
488 }
489
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));
497         }
498     }
499     $wispr= shortest_path_reduction('wi',$base);
500 }
501
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;
511             
512             if (!defined $widist) {
513                 warning(sprintf "route delete %2d for %s .. %s",
514                         $dbdist, $ia,$ib);
515             } elsif (!defined $dbdist) {
516                 change(sprintf "route new %2d for %s .. %s",
517                        $widist, $ia,$ib);
518             } elsif ($dbdist != $widist) {
519                 change(sprintf "route change %2d to %2d for %s .. %s",
520                        $dbdist, $widist, $ia,$ib);
521             }
522         }
523     }
524 }
525
526 parse_info_serverside();
527
528 progress("reading database");
529
530 db_setocean($ocean);
531 db_connect();
532 database_fetch_ocean();
533
534 progress("computing database spr");         database_graph_spr();
535
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();
545
546 progress("comparing islands");              compare_island_lists();
547 progress("comparing distances");            compare_distances();
548
549 print_messages();