chiark / gitweb /
Break process_yppedia_graphs into multiple subs
[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 @wiarchlabels;
16 my %wiisland2node;
17 my %winode2island;
18 my %winode2lines;
19 my %wiccix2arch;
20 my $wialldists;
21
22 my $dbdists= Graph::Undirected->new();
23 my %dbisland2arch;
24
25 my %msgs;
26 sub pmsg ($$) { push @{ $msgs{$_[0]} }, "$_[0]: $_[1]\n"; }
27 sub warning ($) { pmsg("warning",$_[0]); }
28 sub error   ($) { pmsg("error",  $_[0]); }
29 sub change  ($) { pmsg("change", $_[0]); }
30 sub print_messages () {
31     foreach my $k (qw(change warning error)) {
32         my $m= $msgs{$k};
33         next unless $m;
34         print sort @$m or die $!;
35     }
36 }
37
38 if (@ARGV && $ARGV[0] eq '--debug') {
39     shift @ARGV;
40     open DEBUG, ">&STDOUT" or die $!;
41     select(DEBUG); $|=1;
42 } else {
43     open DEBUG, ">/dev/null" or die $!;
44 }
45 select(STDOUT); $|=1;
46
47 my $parity;
48 sub nn_xy ($$) {
49     my ($x,$y) = @_;
50     my $tp= (0+$x ^ 0+$y) & 1;
51     defined $parity or $parity=$tp;
52     $tp==$parity or warning("line $.: parity error $x,$y is $tp not $parity");
53     my $n= "$_[0],$_[1]";
54     $winode2lines{$n}{$.}++;
55     return $n;
56 }
57
58 sub yppedia_chart_parse () {
59     # We don't even bother with tag soup; instead we do line-oriented parsing.
60
61     while (<>) {
62         s/\<--.*--\>//g;
63         s/^\s*//; chomp; s/\s+$//; s/\s+/ /g;
64         s/\<\/?(?:b|em)\>//g;
65         s/\{\{Chart\ style\|[^{}]*\}\}//g;
66         next unless m/\{\{/; # only interested in chart template stuff
67
68         my ($x,$y, $arch,$island,$solid,$dirn);
69         my $nn= sub { return nn_xy($x,$y) };
70     
71         if (($x,$y,$arch) =
72             m/^\{\{ chart\ label \|(\d+)\|(\d+)\| .*
73                     \'\[\[ [^][\']* \| (\S+)\ archipelago \]\]\'*\}\}$/xi) {
74             printf DEBUG "%2d,%-2d arch %s\n", $x,$y,$arch;
75             push @wiarchlabels, [ $x,$y,$arch ];
76         } elsif (($x,$y,$island) =
77             m/^\{\{ chart\ island\ icon \|(\d+)\|(\d+)\|
78                     ([^| ][^|]*[^| ]) \| .*\}\}$/xi) {
79             my $n= $nn->();
80             $wiisland2node{$island}= $n;
81             $winode2island{$n}= $island;
82             $widists->add_vertex($n);
83             $wiarchs->add_vertex($n);
84 #print "\$g->add_vertex('$n');\n";
85             printf DEBUG "%2d,%-2d island %s\n", $x,$y,$island;
86         } elsif (($solid,$x,$y,$dirn) =
87             m/^\{\{ chart\ league((?:\ solid)?) \|(\d+)\|(\d+)\|
88                     ([-\/\\o]) \| .*\}\}$/xi) {
89             next if $dirn eq 'o';
90
91             my ($bx,$by) = ($x,$y);
92             if ($dirn eq '-') { $bx+=2; }
93             elsif ($dirn eq '\\') { $bx++; $by++; }
94             elsif ($dirn eq '/') { $x++; $by++; }
95             else { die; }
96
97             $widists->add_weighted_edge($nn->(), nn_xy($bx,$by), 1);
98             $wiarchs->add_edge($nn->(), nn_xy($bx,$by)) if $solid;
99             $wiarchs->add_edge($nn->(), nn_xy($bx,$by)) if $solid;
100 #print "\$g->add_edge('".$nn->()."','".nn_xy($bx,$by)."');\n" if $solid;
101
102             printf DEBUG "%2d,%-2d league %-6s %s\n", $x,$y,
103                 $solid?'solid':'dotted', $dirn;
104         } elsif (
105             m/^\{\{ chart\ head \}\}$/xi
106                  ) {
107             next;
108         } else {
109             warning("line $.: ignoring incomprehensible: $_");
110         }
111     }
112 }
113
114 sub database_fetch_ocean () {
115     my ($row,$sth);
116     $sth= $dbh->prepare('SELECT islandname, archipelago FROM islands');
117     $sth->execute();
118     while ($row= $sth->fetchrow_hashref) {
119         print DEBUG "database-island $row->{'islandname'}".
120                      " $row->{'archipelago'}\n";
121         $dbisland2arch{$row->{'islandname'}}= $row->{'archipelago'};
122     }
123     $sth= $dbh->prepare('SELECT dist, a.islandname a, b.islandname b
124                                 FROM dists
125                                 JOIN islands AS a ON dists.aiid==a.islandid
126                                 JOIN islands AS b ON dists.biid==b.islandid');
127     $sth->execute();
128     while ($row= $sth->fetchrow_hashref) {
129         $dbdists->add_weighted_edge($row->{'a'}, $row->{'b'}, $row->{'dist'});
130     }
131 }                        
132
133 sub yppedia_graphs_prune_boring () {
134     # Prune the LP database by eliminating boring intermediate vertices
135     foreach my $delete ($widists->vertices()) {
136         next if exists $winode2island{$delete};
137         my @neigh= $widists->neighbours($delete);
138         next unless @neigh==2;
139         my $weight= 0;
140         map { $weight += $widists->get_edge_weight($delete, $_) } @neigh;
141         $widists->add_weighted_edge(@neigh, $weight);
142         $widists->delete_vertex($delete);
143         printf DEBUG "%-5s elide %5s %-5s %2d\n", $delete, @neigh, $weight;
144     }
145 }
146
147 sub yppedia_graphs_check () {
148     # Check that it's connected.
149     foreach my $cc ($widists->connected_components()) {
150         next if 2*@$cc > $widists->vertices();
151         my $m= "disconnected league point(s):";
152         foreach my $n (@$cc) {
153             $m .= "\n    LP $n, def. yppedia line(s): ".
154                 join(',', sort keys %{ $winode2lines{$n} });
155         }
156         warning($m);
157     }
158 }
159
160 sub yppedia_archs_sourceinfo () {
161     # Assign archipelagoes according to the source-info file
162     foreach my $arch (sort keys %{ $oceans{$ocean} }) {
163         foreach my $islename (sort keys %{ $oceans{$ocean}{$arch} }) {
164             my $islenode= $wiisland2node{$islename};
165             defined $islenode or
166                 error("island $islename in source-info but not in WP map");
167             my $ccix= $wiarchs->connected_component_by_vertex($islenode);
168             my $oldarch= $wiccix2arch{$ccix};
169             error("island $islename in $arch in source-info".
170                   " connected to $oldarch as well")
171                 if defined $oldarch && $oldarch ne $arch;
172             printf DEBUG "%-5s force-island-arch cc%-2d %-10s %s\n",
173                 $islenode, $ccix, $arch, $islename;
174             $wiccix2arch{$ccix}= $arch;
175         }
176     }
177 }
178
179 sub yppedia_archs_chart_labels () {
180     # Assign archipelago labels to groups of islands
181     #
182     foreach my $label (@wiarchlabels) {
183         my ($ax,$ay,$arch) = @$label;
184         my $best_ccmulti= -1;
185         my $best_d2= 0;
186         my $best_n;
187 #       print DEBUG "$ax,$ay arch-island-search $arch\n";
188         $ay += 1;  $ax += 2;  # coords are rather to the top left of label
189         foreach my $vertex ($wiarchs->vertices()) {
190             next unless exists $winode2island{$vertex};
191             my $ccix= $wiarchs->connected_component_by_vertex($vertex);
192             my @cc= $wiarchs->connected_component_by_index($ccix);
193             my $ccmulti= @cc > 1;
194             my ($vx,$vy) = split /,/, $vertex;
195             my $d2= ($vx-$ax)*($vx-$ax) + ($vy-$ay)*($vy-$ay);
196             my $cmp= $ccmulti <=> $best_ccmulti
197                 ||   $best_d2 <=> $d2;
198             printf DEBUG "%2d,%-2d arch-island-search %5s d2=%4d cc%-2d".
199                          " #cc=%2d ccmulti=%d cmp=%2d %s\n",
200                 $ax,$ay, $vertex, $d2, $ccix, scalar(@cc), $ccmulti, $cmp,
201                 $winode2island{$vertex};
202             next unless $cmp > 0;
203             $best_n=       $vertex;
204             $best_d2=      $d2;
205             $best_ccmulti= $ccmulti;
206         }
207         die 'no island vertices?!' unless defined $best_n;
208         my $ccix= $wiarchs->connected_component_by_vertex($best_n);
209         printf DEBUG
210             "%2d,%-2d arch-island-select %-5s d2=%4d cc%-2d     %-10s %s\n",
211             $ax,$ay, $best_n, $ccix, $best_d2, $arch, $winode2island{$best_n};
212         my $desc= join "\n", map {
213             my $in= $winode2island{$_};
214             "    LP $_". (defined $in ? ", $in" : "");
215         } sort $wiarchs->connected_component_by_index($ccix);
216
217         if (exists $wiccix2arch{$ccix} and $wiccix2arch{$ccix} ne $arch) {
218             error("archipelago determination failed, wrongly merged:\n".
219                   "    archipelago $arch\n".
220                   "    archipelago $wiccix2arch{$ccix}\n".
221                   $desc);
222             next;
223         }
224         $wiccix2arch{$ccix}= $arch;
225 #       print "$ccix $arch ::\n$desc\n";
226     }
227 }
228
229 sub yppedia_archs_fillbynearest() {
230     # Assign islands not labelled above to archipelagoes.
231     #
232     # We do this by, for each connected component (set of islands
233     # linked by purchaseable charts), searching for the nearest other
234     # connected component which has already been assigned an arch.
235     # `Nearest' means shortest distance of unpurchaseable charts, in
236     # leagues.
237     #
238     # we need only consider vertices which weren't `boring intermediate
239     # vertices' (removed during optimisation as being of order 2)
240     my @ccs_useful= map {
241         [ grep { $widists->has_vertex($_) } @$_ ]
242     } $wiarchs->connected_components();
243
244     my @assignments;
245
246     foreach my $sourceccix (0..$#ccs_useful) {
247         next if defined $wiccix2arch{$sourceccix};
248         next unless $ccs_useful[$sourceccix];
249
250         my @sourcecc= $wiarchs->connected_component_by_index($sourceccix);
251         my @islandnodes= grep { $winode2island{$_} } @sourcecc;
252         next unless @islandnodes; # don't care, then
253
254         foreach my $islandnode (@islandnodes) {
255             printf DEBUG "%-5s arch-join-need cc%-2d             %s\n",
256                 $islandnode, $sourceccix, $winode2island{$islandnode};
257         }
258         my $best_dist= 9999999;
259         my ($best_target, $best_targetccix, $best_source);
260         foreach my $targetccix (0..$#ccs_useful) {
261             next unless defined $wiccix2arch{$targetccix}; # not helpful
262             next unless $ccs_useful[$targetccix];
263             foreach my $target ($wiarchs->
264                          connected_component_by_index($targetccix)) {
265                 foreach my $source (@sourcecc) {
266                     my $target_dist= $wialldists->path_length($target,$source);
267                     next unless defined $target_dist;
268                     next if $target_dist >= $best_dist;
269                     $best_dist= $target_dist;
270                     $best_source= $source;
271                     $best_target= $target;
272                     $best_targetccix= $targetccix;
273                 }
274             }
275         }
276         die "no possible target ?!" unless defined $best_target;
277
278         my $arch= $wiccix2arch{$best_targetccix};
279         my $best_island= $winode2island{$best_target};
280         printf DEBUG "%-5s arch-join-to %-5s dist=%2d cc%-2d  %-10s %s\n",
281             $best_source, $best_target, $best_dist,
282             $best_targetccix, $arch,
283             defined($best_island) ? $best_island : "-";
284
285         push @assignments, [ $sourceccix, $arch ];
286     }
287     foreach my $assign (@assignments) {
288         $wiccix2arch{$assign->[0]}= $assign->[1];
289     }
290 }
291
292 sub winode2arch ($) {
293     my ($node) = @_;
294     my $ccix= $wiarchs->connected_component_by_vertex($node);
295     return $wiccix2arch{$ccix};
296 }
297 sub wiisland2arch ($) {
298     my ($island) = @_;
299     my $node= $wiisland2node{$island};
300     die "$island ?" unless defined $node;
301     return winode2arch($node);
302 }
303
304 sub compare_island_lists () {
305     foreach my $island (sort keys %dbisland2arch) {
306         my $node= $wiisland2node{$island};
307         if (!defined $node) {
308             error("would delete island: $island");
309             next;
310         }
311         my $wiarch= winode2arch($node);
312         if (!defined $wiarch) {
313             error("island has no arch: $island");
314             next;
315         }
316         my $dbarch= $dbisland2arch{$island};
317         if ($wiarch ne $dbarch) {
318             change("change archipelago from $dbarch to $wiarch".
319                    " for island $island");
320         }
321     }
322     foreach my $island (sort keys %wiisland2node) {
323         my $dbarch= $dbisland2arch{$island};
324         if (!defined $dbarch) {
325             my $wiarch= wiisland2arch($island);
326             if (!defined $wiarch) {
327                 error("new island has no arch: $island");
328                 next;
329                 # We check arches of non-new islands above
330             }
331             change("new island in $wiarch: $island");
332         }
333     }
334 }
335
336 sub compare_distances () {
337     foreach my $ia (sort keys %dbisland2arch) {
338         my $na= $wiisland2node{$ia};
339         next unless defined $na;
340         foreach my $ib (sort keys %dbisland2arch) {
341             next unless $ia le $ib; # do every pair only once
342             my $nb= $wiisland2node{$ib};
343             next unless defined $nb;
344             my $dbdist= $dbdists->get_edge_weight($ia,$ib);
345             my $widist= $wialldists->path_length($na,$nb);
346             if (!defined $dbdist) {
347                 change(sprintf "define distance %2d for %s..%s",
348                        $widist, $ia,$ib);
349             } elsif ($dbdist != $widist) {
350                 change(sprintf "change distance %2d to %2d for %s..%s",
351                        $dbdist, $widist, $ia,$ib);
352             }
353         }
354     }
355 }
356
357 parse_info_serverside();
358
359 db_setocean($ocean);
360 db_connect();
361 database_fetch_ocean();
362
363 yppedia_chart_parse();
364 yppedia_graphs_prune_boring();
365 yppedia_graphs_check();
366 yppedia_archs_sourceinfo();
367 $wialldists= $widists->APSP_Floyd_Warshall();
368 yppedia_archs_chart_labels();
369 yppedia_archs_fillbynearest();
370
371 compare_island_lists();
372 compare_distances();
373
374 print_messages();