X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~yarrgweb/git?a=blobdiff_plain;f=yarrg%2Fyppedia-chart-parser;h=2da027e14829255b308d8e2071e1976285a61c76;hb=fc9092694d98ee3737f8cdceef02d65cc6255dd4;hp=1a90e8482af2234cfb2b068ef87a64b9553593da;hpb=9b682fcef909400761d3941b43b2788b0f912a17;p=ypp-sc-tools.web-live.git diff --git a/yarrg/yppedia-chart-parser b/yarrg/yppedia-chart-parser index 1a90e84..2da027e 100755 --- a/yarrg/yppedia-chart-parser +++ b/yarrg/yppedia-chart-parser @@ -5,14 +5,45 @@ use warnings; use Graph::Undirected; -my $dists= Graph::Undirected->new(); -my $archs= Graph::Undirected->new(); -my @arch_labels; -my %islandname; +use CommodsDatabase; -open PO, ">/dev/null" or die $!; +my $widists= Graph::Undirected->new(); +my $wiarchs= Graph::Undirected->new(); +my @wiarchlabels; +my %wiisland2node; +my %winode2island; +my %wiisland2arch; +my %winode2lines; +my %wiccix2arch; -sub nn_xy ($$) { return "n$_[0]x$_[1]"; } +my $dbdists= Graph::Undirected->new(); +my %dbisland2arch; + +my %msgcount; +sub perr ($$) { print STDERR "$_[0]: $_[1]\n"; $msgcount{$_[0]}++; } +sub warning ($) { perr("warning",$_[0]); } +sub error ($) { perr("error", $_[0]); } +sub change ($) { perr("change", $_[0]); } + +if ($ARGV[0] eq '--debug') { + shift @ARGV; + open DEBUG, ">&STDOUT" or die $!; + select(DEBUG); $|=1; +} else { + open DEBUG, ">/dev/null" or die $!; +} +select(STDOUT); $|=1; + +my $parity; +sub nn_xy ($$) { + my ($x,$y) = @_; + my $tp= (0+$x ^ 0+$y) & 1; + defined $parity or $parity=$tp; + $tp==$parity or warning("line $.: parity error $x,$y is $tp not $parity"); + my $n= "$_[0],$_[1]"; + $winode2lines{$n}{$.}++; + return $n; +} sub parse_yppedia_map () { # We don't even bother with tag soup; instead we do line-oriented parsing. @@ -30,15 +61,18 @@ sub parse_yppedia_map () { if (($x,$y,$arch) = m/^\{\{ chart\ label \|(\d+)\|(\d+)\| .* \'\[\[ [^][\']* \| (\S+)\ archipelago \]\]\'*\}\}$/xi) { - printf PO "%d,%d arch %s\n", $x,$y,$arch; - push @arch_labels, [ $x,$y,$arch ]; + printf DEBUG "%2d,%-2d arch %s\n", $x,$y,$arch; + push @wiarchlabels, [ $x,$y,$arch ]; } elsif (($x,$y,$island) = m/^\{\{ chart\ island\ icon \|(\d+)\|(\d+)\| - (\S.*\S) \| .*\}\}$/xi) { - $islandname{$nn->()}= $island; - $dists->add_vertex($nn->()); - $archs->add_vertex($nn->()); - printf PO "%d,%d island %s\n", $x,$y,$island; + ([^| ][^|]*[^| ]) \| .*\}\}$/xi) { + my $n= $nn->(); + $wiisland2node{$island}= $n; + $winode2island{$n}= $island; + $widists->add_vertex($n); + $wiarchs->add_vertex($n); +#print "\$g->add_vertex('$n');\n"; + printf DEBUG "%2d,%-2d island %s\n", $x,$y,$island; } elsif (($solid,$x,$y,$dirn) = m/^\{\{ chart\ league((?:\ solid)?) \|(\d+)\|(\d+)\| ([-\/\\o]) \| .*\}\}$/xi) { @@ -47,22 +81,222 @@ sub parse_yppedia_map () { my ($bx,$by) = ($x,$y); if ($dirn eq '-') { $bx+=2; } elsif ($dirn eq '\\') { $bx++; $by++; } - elsif ($dirn eq '/') { $bx--; $by++; } + elsif ($dirn eq '/') { $x++; $by++; } else { die; } - $dists->add_edge($nn->(), nn_xy($bx,$by)); - $archs->add_edge($nn->(), nn_xy($bx,$by)) if $solid; + $widists->add_weighted_edge($nn->(), nn_xy($bx,$by), 1); + $wiarchs->add_edge($nn->(), nn_xy($bx,$by)) if $solid; + $wiarchs->add_edge($nn->(), nn_xy($bx,$by)) if $solid; +#print "\$g->add_edge('".$nn->()."','".nn_xy($bx,$by)."');\n" if $solid; - printf PO "%d,%d league %s %s \n", $x,$y, + printf DEBUG "%2d,%-2d league %-6s %s\n", $x,$y, $solid?'solid':'dotted', $dirn; } elsif ( m/^\{\{ chart\ head \}\}$/xi ) { next; } else { - warn "line $.: ignoring incomprehensible: $_\n"; + warning("line $.: ignoring incomprehensible: $_"); + } + } +} + +sub parse_database_map () { + my ($row,$sth); + $sth= $dbh->prepare('SELECT islandname, archipelago FROM islands'); + $sth->execute(); + while ($row= $sth->fetchrow_hashref) { + print DEBUG "database-island $row->{'islandname'}". + " $row->{'archipelago'}\n"; + $dbisland2arch{$row->{'islandname'}}= $row->{'archipelago'}; + } + $sth= $dbh->prepare('SELECT dist, a.islandname a, b.islandname b + FROM dists + JOIN islands AS a ON dists.aiid==a.islandid + JOIN islands AS b ON dists.biid==b.islandid'); + $sth->execute(); + while ($row= $sth->fetchrow_hashref) { + $dbdists->add_weighted_edge($row->{'a'}, $row->{'b'}, $row->{'dist'}); + } +} + +sub process_yppedia_graphs () { + # Prune the LP database by eliminating boring intermediate vertices + foreach my $delete ($widists->vertices()) { + next if exists $winode2island{$delete}; + my @neigh= $widists->neighbours($delete); + next unless @neigh==2; +# my @aneigh= $wiarchs->has_vertex($delete) +# ? $wiarchs->neighbours($delete) : (); +# next unless @aneigh==0 || @aneigh==2; + my $weight= 0; + map { $weight += $widists->get_edge_weight($delete, $_) } @neigh; + $widists->add_weighted_edge(@neigh, $weight); + $widists->delete_vertex($delete); + printf DEBUG "%-5s elide %5s %-5s %2d\n", $delete, @neigh, $weight; + } + + # Check that it's connected. + foreach my $cc ($widists->connected_components()) { + next if 2*@$cc > $widists->vertices(); + my $m= "disconnected league point(s):"; + foreach my $n (@$cc) { + $m .= "\n LP $n, def. yppedia line(s): ". + join(',', sort keys %{ $winode2lines{$n} }); + } + warning($m); + } + + # Compute all-pairs-shortest-paths on dist, which is the + # actual distances between all LPs. + my $wialldists= $widists->APSP_Floyd_Warshall(); + + # Assign archipelago labels to groups of islands + foreach my $label (@wiarchlabels) { + my ($ax,$ay,$arch) = @$label; + my $best_ccmulti= -1; + my $best_d2= 0; + my $best_n; +# print DEBUG "$ax,$ay arch-island-search $arch\n"; + $ay += 1; $ax += 2; # coords are rather to the top left of label + foreach my $vertex ($wiarchs->vertices()) { + next unless exists $winode2island{$vertex}; + my $ccix= $wiarchs->connected_component_by_vertex($vertex); + my @cc= $wiarchs->connected_component_by_index($ccix); + my $ccmulti= @cc > 1; + my ($vx,$vy) = split /,/, $vertex; + my $d2= ($vx-$ax)*($vx-$ax) + ($vy-$ay)*($vy-$ay); + my $cmp= $ccmulti <=> $best_ccmulti + || $best_d2 <=> $d2; + printf DEBUG "%2d,%-2d arch-island-search %5s d2=%4d ccix=%-2d". + " cc=%2d ccmulti=%d cmp=%-2d %s\n", + $ax,$ay, $vertex, $d2, $ccix, scalar(@cc), $ccmulti, $cmp, + $winode2island{$vertex}; + next unless $cmp > 0; + $best_n= $vertex; + $best_d2= $d2; + $best_ccmulti= $ccmulti; + } + die 'no island vertices?!' unless defined $best_n; + printf DEBUG "%2d,%-2d arch-island-select %-5s d2=%-2d %-10s %s\n", + $ax,$ay, $best_n, $best_d2, $arch, $winode2island{$best_n}; + my $ccix= $wiarchs->connected_component_by_vertex($best_n); + my $desc= join "\n", map { + my $in= $winode2island{$_}; + " LP $_". (defined $in ? ", $in" : ""); + } sort $wiarchs->connected_component_by_index($ccix); + + if (exists $wiccix2arch{$ccix}) { + error("archipelago determination failed, wrongly merged:\n". + " archipelago $arch\n". + " archipelago $wiccix2arch{$ccix}\n". + $desc); + next; + } + $wiccix2arch{$ccix}= $arch; +# print "$ccix $arch ::\n$desc\n"; + } + + # Assign islands not labelled above to archipelagoes. + # + # We do this by, for each connected component (set of islands + # linked by purchaseable charts), searching for the nearest other + # connected component which has already been assigned an arch. + # `Nearest' means shortest distance of unpurchaseable charts, in + # leagues. + + # fixme need some hints + + # we need only consider vertices which weren't `boring intermediate + # vertices' (removed during optimisation as being of order 2) + my @ccs_useful= map { + [ grep { $widists->has_vertex($_) } @$_ ] + } $wiarchs->connected_components(); + + foreach my $sourceccix (0..$#ccs_useful) { + next if defined $wiccix2arch{$sourceccix}; + + my $sourcecc= $ccs_useful[$sourceccix]; + my @islandnodes= grep { $winode2island{$_} } @$sourcecc; + next unless @islandnodes; # don't care, then + + my $best_dist= 9999999; + my $best_target; + foreach my $targetccix (0..$#ccs_useful) { + next unless defined $wiccix2arch{$targetccix}; # not helpful + my $targetcc= $ccs_useful[$targetccix]; + foreach my $target (@$targetcc) { + foreach my $source (@$sourcecc) { + my $target_dist= $wialldists->path_length($target,$source); + next if $target_dist >= $best_dist; + $best_dist= $target_dist; + $best_target= $target; + } + } + } +# die "no possible target ?!" unless defined $best_target; +# +# printf DEBUG " +# +# foreach my $node (sort keys %winode2island) { +# my $island= $winode2island{$node}; +# my $arch= winode2arch($node); +# next if defined $arch; +# my $ccix= $wiarchs->connected_component_by_vertex($node); +# my @cc= $wiarchs->connected_component_by_index($ccix); +# @cc= grep { defined $winode2island{$_} } @cc; +# # We search for the best: +# # - member of this connected component + } +} + +sub winode2arch ($) { + my ($node) = @_; + my $ccix= $wiarchs->connected_component_by_vertex($node); + return $wiccix2arch{$ccix}; +} +sub wiisland2arch ($) { + my ($island) = @_; + my $node= $wiisland2node{$island}; + die "$island ?" unless defined $node; + return winode2arch($node); +} + +sub compare_island_lists () { + foreach my $island (sort keys %dbisland2arch) { + my $node= $wiisland2node{$island}; + if (!defined $node) { + error("would delete island: $island"); + next; + } + my $wiarch= winode2arch($node); + if (!defined $wiarch) { + error("island has no arch: $island"); + next; + } + my $dbarch= $dbisland2arch{$island}; + if ($wiarch ne $dbarch) { + change("change archipelago from $dbarch to $wiarch". + " for island $island"); + } + } + foreach my $island (sort keys %wiisland2node) { + my $dbarch= $dbisland2arch{$island}; + if (!defined $dbarch) { + my $wiarch= wiisland2arch($island); + if (!defined $wiarch) { + error("new island has no arch: $island"); + next; + # We check arches of non-new islands above + } + change("new island in $wiarch: $island"); } } } +db_setocean('Midnight'); +db_connect(); parse_yppedia_map(); +parse_database_map(); +process_yppedia_graphs(); +compare_island_lists();