Parse.pm

   1 # Parse.pm - module for parsing board definitions
   2 #   for games very like Pandemic Rising Tide
   3 #
   4 # Copyright (C) 2019 Ian Jackson
   5 #
   6 # This program is dual licensed, GPv3+ or CC-BY-SA 4.0+.
   7 # Only to the Pandemic Rising Tide folks, it is permissively licensed.
   8 #
   9 #   This program is free software.
  10 #
  11 #   You can redistribute it and/or modify it under the terms of the
  12 #   GNU General Public License as published by the Free Software
  13 #   Foundation, either version 3 of the License, or (at your option)
  14 #   any later version; or (at your option), under the terms of the
  15 #   Creative Commons Attribution-ShareAlike International License,
  16 #   version 4.0 of that License, or (at your option), any later
  17 #   version.
  18 #
  19 #   This program is distributed in the hope that it will be useful,
  20 #   but WITHOUT ANY WARRANTY; without even the implied warranty of
  21 #   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  22 #   General Public License Creative Commons Attribution-ShareAlike
  23 #   License or the for more details.
  24 #
  25 #   You should have received a copy of these licenses along with this
  26 #   program.  If not, see <https://www.gnu.org/licenses/> and
  27 #   <https://creativecommons.org/licenses/>.
  28 #
  29 # Pandemic and Pandemic Rising Tide are (I think) trademarks of Z-Man
  30 # games and I use them without permission.
  31 #
  32 # For the avoidance of doubt, I do not consider this program to be a
  33 # derivative work of the game Pandemic Rising Tide.  However, it is
  34 # not very useful without a pair of game description files and the
  35 # only nontrivial game description files I know of are indeed such
  36 # derivatives.
  37
  38 package Parse;
  39
  40 use strict;
  41 use Carp;
  42 use Graph;
  43
  44 use Exporter;
  45
  46 our @ISA = qw(Exporter);
  47 our @EXPORT = qw(parse_input_graph o plag_prs %region %c);
  48
  49 our %c;
  50 require 'misc-data.pl';
  51
  52 our %region;
  53 # $region{NAME}{Colour}
  54 # $region{NAME}{Water}
  55 # $region{NAME}{Name}
  56 # $region{NAME}{L} # line number
  57 # $region{NAME}{Adj}[]{Name}
  58 # $region{NAME}{Adj}[]{DisplayName}[]
  59 # $region{NAME}{Adj}[]{Pattern}
  60 # $region{NAME}{Adj}[]{Regexp}
  61 # $region{NAME}{Adj}[]{Dykes}
  62 # $region{NAME}{Adj}[]{L}
  63
  64 our %adj;
  65 # $adj{EARLIER}{LATER}{Dykes}
  66 # $adj{EARLIER}{LATER}{L}[]
  67 # $adj{EARLIER}{LATER}{T}[]
  68
  69 sub read_in () {
  70   my $ccolour;
  71   my $cregion;
  72
  73   while (<>) {
  74     next if m{^\s*\#};
  75     next unless m{\S};
  76     s{\s+$}{} or confess;
  77     if (m{^\w+}) {
  78       $ccolour = $&;
  79       next;
  80     }
  81     if (my ($name, $water) = m{^\t(\S.*\w|L2?)(?: \[(\d+)\])?$}) {
  82       confess unless defined $ccolour;
  83       my $dname = $c{DisplayNames}{$name} // $name;
  84       $name =~ s{/}{}g;
  85       confess "$name ?" if $region{$name};
  86       $region{$name}{Colour} = $ccolour;
  87       $region{$name}{Water} = $water;
  88       $region{$name}{L} = $.;
  89       if ($dname =~ m{/}) {
  90         $dname =~ s{(?<!-)/(?! )}{-/}g;
  91         $region{$name}{DisplayName} = [ grep m/./, split m{ */ *}, $dname ];
  92       } else {
  93         $region{$name}{DisplayName} = [ split m{(?<=-)| }, $dname ];
  94       }
  95       $cregion = $name;
  96       next;
  97     }
  98     if (my ($aref, $adykes, $dwdyke) =
  99         m{^\t\t(\S.*[A-Za-z.]|L2?)(?: (\+\+?)(\@?))?$}) {
 100       my $adj = {
 101                  Dykes => (length $adykes // 0),
 102                  Deltawerk => !!$dwdyke,
 103                  L => $.
 104                 };
 105       if ($aref =~ m{\.}) {
 106         $adj->{Pattern} = $aref;
 107         $aref =~ s{\-}{[^- ]*-}g;
 108         $aref =~ s{\.+}{
 109             length $& eq 1 ? qr{[^- ]* ?} :
 110             length $& eq 2 ? qr{.*}       : confess "$aref"
 111         }ge;
 112         $adj->{Regexp} = $aref;
 113       } else {
 114         $adj->{Name} = $aref;
 115       }
 116       push @{ $region{$cregion}{Adj} }, $adj;
 117       next;
 118     }
 119     confess "$_ ?";
 120   }
 121 }
 122
 123 sub unique_aref ($$) {
 124   my ($ra, $adja) = @_;
 125   my $re = $adja->{Regexp};
 126   return $adja->{Name} unless defined $re;
 127   my @cands;
 128   foreach my $rb (sort keys %region) {
 129     #print STDERR "?? $ra -> $re $rb ?\n";
 130     foreach my $adjb (@{ $region{$rb}{Adj} }) {
 131       my $adjbn = $adjb->{Name};
 132       next unless defined $adjbn;
 133       #print STDERR "?? $ra -> $re $rb ?? $adjbn\n";
 134       next unless $adjbn eq $ra;
 135       push @cands, [ $rb, "$region{$rb}{L},$adjb->{L}" ];
 136     }
 137   }
 138   my @found = grep { $_->[0] =~ m{^$re$} } @cands;
 139   my $pr = sub {
 140     join ' / ', map { "$_->[0] ($_->[1])" } @_;
 141   };
 142   confess "$adja->{L} $adja->{Pattern} /$re/ | ".$pr->(@cands)
 143       ." | ".$pr->(@found)." | ?"
 144       unless @found==1;
 145   my $r = $found[0][0];
 146   #print STDERR "resolve $ra -> $adja->{Pattern} = $r\n";
 147   return $r;
 148 }
 149
 150 sub region_cmp {
 151   ($a eq 'L' ) <=> ($b eq 'L' ) or
 152   ($a eq 'L2') <=> ($b eq 'L2') or
 153   ($a eq $c{Sea}) <=> ($b eq $c{Sea}) or
 154    $a          cmp  $b
 155 }
 156
 157 sub resolve_arefs () {
 158   #print Dumper(\%region);
 159   foreach my $ra (sort keys %region) {
 160     foreach my $adj (@{ $region{$ra}{Adj} }) {
 161       next if defined $adj->{Name};
 162       $adj->{ProspectiveName} = unique_aref $ra, $adj;
 163     }
 164   }
 165   foreach my $ra (sort keys %region) {
 166     foreach my $adj (@{ $region{$ra}{Adj} }) {
 167       $adj->{Name} //= $adj->{ProspectiveName};
 168     }
 169   }
 170   foreach my $ra (sort keys %region) {
 171     foreach my $adj (@{ $region{$ra}{Adj} }) {
 172       confess unless $adj->{Name} eq unique_aref $ra, $adj;
 173     }
 174   }
 175 }
 176
 177 sub adjacencies () {
 178   foreach my $ra (sort keys %region) {
 179     my $adjs = $region{$ra}{Adj};
 180     foreach my $adji (0..$#$adjs) {
 181       my $adja = $adjs->[$adji];
 182       my $rb = $adja->{Name};
 183       my ($r0,$r1) = sort region_cmp ($ra,$rb);
 184       push @{ $adj{$r0}{$r1}{L} }, $adja->{L};
 185       push @{ $adj{$r0}{$r1}{T} }, substr($ra,0,1)."#".$adji;
 186       my $e = $adj{$r0}{$r1};
 187       $e->{Dykes} //= $adja->{Dykes};
 188       confess "$r0 - $r1 | @{ $e->{L} } | $e->{Dykes} $adja->{Dykes} ?"
 189           unless $e->{Dykes} == $adja->{Dykes};
 190     }
 191   }
 192   my $ndykes = 0;
 193   foreach my $r0 (sort keys %adj) {
 194     foreach my $r1 (sort keys %{ $adj{$r0} }) {
 195       my $e = $adj{$r0}{$r1};
 196       confess "$r0 / $r1 : @{ $e->{L} } ?" unless @{ $e->{L} } == 2;
 197       $ndykes += $e->{Dykes};
 198     }
 199   }
 200   #print STDERR "total $ndykes dykes\n";
 201 }
 202
 203 sub names () {
 204   foreach my $r (sort keys %region) {
 205     $region{$r}{Name} = $r;
 206   }
 207 }
 208
 209 sub edge_id_to_other_id ($$) {
 210   my ($ra, $adjia) = @_;
 211   my $adjsa = $region{$ra}{Adj};
 212   my $adja = $adjsa->[$adjia];
 213   my $rb = $adja->{Name};
 214   my $adjsb = $region{$rb}{Adj};
 215   foreach my $adjib (0..$#$adjsb) {
 216     my $adjb = $adjsb->[$adjib];
 217     next unless $adjb->{Name} eq $ra;
 218     # $adjb is the same edge seen from the other side
 219     return ($rb, $adjib);
 220   }
 221   confess "$ra $adjia ?";
 222 }
 223
 224 sub o { print @_ or die $!; }
 225
 226 sub plag_prs ($) {
 227     my ($t) = @_;
 228     $t = $` if $t =~ m/\n/;
 229     $t =~ s/ //g;
 230     $t =~ s/-//g;
 231     return "$t";
 232 }
 233
 234 sub parse_input_graph () {
 235   read_in();
 236   resolve_arefs();
 237   adjacencies();
 238   names();
 239 }
 240
 241 1;