chiark / gitweb /
Add proof (from email)
[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
40 if (@ARGV && $ARGV[0] eq '--debug') {
41     shift @ARGV;
42     open DEBUG, ">&STDOUT" or die $!;
43     select(DEBUG); $|=1;
44 } else {
45     open DEBUG, ">/dev/null" or die $!;
46 }
47 select(STDOUT); $|=1;
48
49 my $parity;
50 sub nn_xy ($$) {
51     my ($x,$y) = @_;
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");
55     my $n= "$_[0],$_[1]";
56     $winode2lines{$n}{$.}++;
57     return $n;
58 }
59
60 sub yppedia_chart_parse () {
61     # We don't even bother with tag soup; instead we do line-oriented parsing.
62
63     while (<>) {
64         s/\<--.*--\>//g;
65         s/^\s*//; chomp; s/\s+$//; s/\s+/ /g;
66         s/\<\/?(?:b|em)\>//g;
67         s/\{\{Chart\ style\|[^{}]*\}\}//g;
68         next unless m/\{\{/; # only interested in chart template stuff
69
70         my ($x,$y, $arch,$island,$solid,$dirn);
71         my $nn= sub { return nn_xy($x,$y) };
72     
73         if (($x,$y,$arch) =
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) {
81             my $n= $nn->();
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) {
90             next if $dirn eq 'o';
91
92             my ($bx,$by) = ($x,$y);
93             if ($dirn eq '-') { $bx+=2; }
94             elsif ($dirn eq '\\') { $bx++; $by++; }
95             elsif ($dirn eq '/') { $x++; $by++; }
96             else { die; }
97
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;
102
103             printf DEBUG "%2d,%-2d league %-6s %s %s\n", $x,$y,
104                 $solid?'solid':'dotted', $dirn, $nb;
105         } elsif (
106             m/^\{\{ chart\ head \}\}$/xi
107                  ) {
108             next;
109         } else {
110             warning("line $.: ignoring incomprehensible: $_");
111         }
112     }
113 }
114
115 sub database_fetch_ocean () {
116     my ($row,$sth);
117     $sth= $dbh->prepare('SELECT islandname, archipelago FROM islands');
118     $sth->execute();
119     while ($row= $sth->fetchrow_hashref) {
120         print DEBUG "database-island $row->{'islandname'}".
121                      " $row->{'archipelago'}\n";
122         $dbisland2arch{$row->{'islandname'}}= $row->{'archipelago'};
123     }
124     $sth= $dbh->prepare('SELECT dist, a.islandname a, b.islandname b
125                                 FROM dists
126                                 JOIN islands AS a ON dists.aiid==a.islandid
127                                 JOIN islands AS b ON dists.biid==b.islandid');
128     $sth->execute();
129     while ($row= $sth->fetchrow_hashref) {
130         $dbdists->add_weighted_edge($row->{'a'}, $row->{'b'}, $row->{'dist'});
131     }
132 }                        
133
134 sub database_graph_spr () {
135     $dbspr= shortest_path_reduction('db',$dbdists);
136 }
137
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.
141     #
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);
150         };
151         $add_shortcut->( 2,0);
152         $add_shortcut->(+1,1);
153         $add_shortcut->(-1,1);
154     }
155 }
156
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;
163         my $weight= 0;
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;
168     }
169 }
170
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} });
179         }
180         warning($m);
181     }
182 }
183
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};
189             defined $islenode or
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;
199         }
200     }
201 }
202
203 sub yppedia_archs_chart_labels () {
204     # Assign archipelago labels to groups of islands
205     #
206     foreach my $label (@wiarchlabels) {
207         my ($ax,$ay,$arch) = @$label;
208         my $best_ccmulti= -1;
209         my $best_d2= 0;
210         my $best_n;
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
221                 ||   $best_d2 <=> $d2;
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;
227             $best_n=       $vertex;
228             $best_d2=      $d2;
229             $best_ccmulti= $ccmulti;
230         }
231         die 'no island vertices?!' unless defined $best_n;
232         my $ccix= $wiarchs->connected_component_by_vertex($best_n);
233         printf DEBUG
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);
240
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".
245                   $desc);
246             next;
247         }
248         $wiccix2arch{$ccix}= $arch;
249 #       print "$ccix $arch ::\n$desc\n";
250     }
251 }
252
253 sub yppedia_archs_fillbynearest() {
254     # Assign islands not labelled above to archipelagoes.
255     #
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
260     # leagues.
261     #
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();
267
268     my @assignments;
269
270     foreach my $sourceccix (0..$#ccs_useful) {
271         next if defined $wiccix2arch{$sourceccix};
272         next unless $ccs_useful[$sourceccix];
273
274         my @sourcecc= $wiarchs->connected_component_by_index($sourceccix);
275         my @islandnodes= grep { $winode2island{$_} } @sourcecc;
276         next unless @islandnodes; # don't care, then
277
278         foreach my $islandnode (@islandnodes) {
279             printf DEBUG "%-5s arch-join-need cc%-2d             %s\n",
280                 $islandnode, $sourceccix, $winode2island{$islandnode};
281         }
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;
298                 }
299             }
300         }
301         die "no possible target ?!" unless defined $best_target;
302
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 : "-";
309
310         push @assignments, [ $sourceccix, $arch ];
311     }
312     foreach my $assign (@assignments) {
313         $wiccix2arch{$assign->[0]}= $assign->[1];
314     }
315 }
316
317 sub yppedia_graph_shortest_paths () {
318     $wialldists= $widists->APSP_Floyd_Warshall();
319 }
320
321 sub widist ($$) {
322     my ($p,$q) = @_;
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);
328     return $pl;
329 }
330                         
331 sub winode2arch ($) {
332     my ($node) = @_;
333     my $ccix= $wiarchs->connected_component_by_vertex($node);
334     return $wiccix2arch{$ccix};
335 }
336 sub wiisland2arch ($) {
337     my ($island) = @_;
338     my $node= $wiisland2node{$island};
339     die "$island ?" unless defined $node;
340     return winode2arch($node);
341 }
342
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");
348             next;
349         }
350         my $wiarch= winode2arch($node);
351         if (!defined $wiarch) {
352             error("island has no arch: $island");
353             next;
354         }
355         my $dbarch= $dbisland2arch{$island};
356         if ($wiarch ne $dbarch) {
357             change("change archipelago from $dbarch to $wiarch".
358                    " for island $island");
359         }
360     }
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");
367                 next;
368                 # We check arches of non-new islands above
369             }
370             change("new island in $wiarch: $island");
371         }
372     }
373 }
374
375 sub shortest_path_reduction ($$) {
376     my ($what,$base) = @_;
377     #
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
380     # of $base.
381     #
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.
385
386     my $proof=<<'END'; # way to make a big comment
387
388     Premises and definitions:
389
390     1. F is a connected undirected weighted graph with positive edge
391        weights.
392
393     2. All graphs we will consider have the same vertices as F.
394
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.)
397
398     3a. |XY| for vertices X, Y is the weight of the edge XY in G.
399
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.
403
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.
408
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.)
413
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.
416
417     6b. Some such B: Call all such edges AC `questionable'.
418
419     6c. Thus all edges are essential or questionable.
420
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.
428
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|.
432
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.
436
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.
441
442 END
443     
444     printf DEBUG "spr %s before %d\n", $what, scalar($base->edges());
445
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);
451         my $needed= 1;
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;
460             # found path
461             printf DEBUG "spr %s edge %s unnecessary %s\n",
462                 $what, $edgename_ac, $vertex_b;
463             $needed= 0;
464             last;
465         }
466         if ($needed) {
467             printf DEBUG "spr %s edge %s essential\n", $what, $edgename_ac;
468             $result->add_weighted_edge(@$edge_ac,$w_ac);
469         }
470     }
471     printf DEBUG "spr %s result %d\n", $what, scalar($result->edges());
472
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")
481                 if $din != $dout;
482         }
483     }
484     return $result;
485 }
486
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));
494         }
495     }
496     $wispr= shortest_path_reduction('wi',$base);
497 }
498
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;
508             
509             if (!defined $widist) {
510                 warning(sprintf "route delete %2d for %s..%s",
511                         $dbdist, $ia,$ib);
512             } elsif (!defined $dbdist) {
513                 change(sprintf "route create %2d for %s..%s",
514                        $widist, $ia,$ib);
515             } elsif ($dbdist != $widist) {
516                 change(sprintf "route change %2d to %2d for %s..%s",
517                        $dbdist, $widist, $ia,$ib);
518             }
519         }
520     }
521 }
522
523 parse_info_serverside();
524
525 print "reading database\n";
526
527 db_setocean($ocean);
528 db_connect();
529 database_fetch_ocean();
530
531 print "computing database spr\n";         database_graph_spr();
532
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();
542
543 print "comparing\n";
544
545 compare_island_lists();
546 compare_distances();
547
548 print_messages();