move stuff into Parse.pm; build system

[pandemic-rising-tide.git] / Parse.pm

diff --git a/Parse.pm b/Parse.pm
new file mode 100644 (file)
index 0000000..51cb1fa
--- /dev/null
+++ b/Parse.pm
@@ -0,0 +1,171 @@
+
+package Parse;
+
+use strict;
+use Carp;
+use Graph;
+
+use Exporter;
+
+our @ISA = qw(Exporter);
+our @EXPORT = qw(parse_input_graph o %region %adj);
+
+our %region;
+# $region{NAME}{Colour}
+# $region{NAME}{Water}
+# $region{NAME}{L} # line number
+# $region{NAME}{Adj}[]{Name}
+# $region{NAME}{Adj}[]{Pattern}
+# $region{NAME}{Adj}[]{Regexp}
+# $region{NAME}{Adj}[]{Dikes}
+# $region{NAME}{Adj}[]{L}
+
+our %adj;
+# $adj{EARLIER}{LATER}{Dikes}
+# $adj{EARLIER}{LATER}{L}[]
+# $adj{EARLIER}{LATER}{T}[]
+
+sub read_in () {
+  my $ccolour;
+  my $cregion;
+
+  while (<>) {
+    next if m{^\s*\#};
+    next unless m{\S};
+    s{\s+$}{} or confess;
+    if (m{^\w+}) {
+      $ccolour = $&;
+      next;
+    }
+    if (my ($name, $water) = m{^\t(\S.*\w|L)(?: \[(\d+)\])?$}) {
+      confess unless defined $ccolour;
+      confess "$name ?" if $region{$name};
+      $region{$name}{Colour} = $ccolour;
+      $region{$name}{Water} = $water;
+      $region{$name}{L} = $.;
+      $cregion = $name;
+      next;
+    }
+    if (my ($aref, $adikes) = m{^\t\t(\S.*[A-Za-z.]|L)(?: (\+\+?))?$}) {
+      my $adj = { Dikes => (length $adikes // 0), L => $. };
+      if ($aref =~ m{\.}) {
+       $adj->{Pattern} = $aref;
+       $aref =~ s{\-}{[^- ]*-}g;
+       $aref =~ s{\.+}{
+            length $& eq 1 ? qr{[^- ]* ?} :
+            length $& eq 2 ? qr{.*}       : confess "$aref"
+        }ge;
+       $adj->{Regexp} = $aref;
+      } else {
+       $adj->{Name} = $aref;
+      }
+      push @{ $region{$cregion}{Adj} }, $adj;
+      next;
+    }
+    confess "$_ ?";
+  }
+}
+
+sub unique_aref ($$) {
+  my ($ra, $adja) = @_;
+  my $re = $adja->{Regexp};
+  return $adja->{Name} unless defined $re;
+  my @cands;
+  foreach my $rb (sort keys %region) {
+    #print STDERR "?? $ra -> $re $rb ?\n";
+    foreach my $adjb (@{ $region{$rb}{Adj} }) {
+      my $adjbn = $adjb->{Name};
+      next unless defined $adjbn;
+      #print STDERR "?? $ra -> $re $rb ?? $adjbn\n";
+      next unless $adjbn eq $ra;
+      push @cands, [ $rb, "$region{$rb}{L},$adjb->{L}" ];
+    }
+  }
+  my @found = grep { $_->[0] =~ m{^$re$} } @cands;
+  my $pr = sub {
+    join ' / ', map { "$_->[0] ($_->[1])" } @_;
+  };
+  confess "$adja->{L} $adja->{Pattern} /$re/ | ".$pr->(@cands)
+      ." | ".$pr->(@found)." | ?"
+      unless @found==1;
+  my $r = $found[0][0];
+  #print STDERR "resolve $ra -> $adja->{Pattern} = $r\n";
+  return $r;
+}
+
+sub region_cmp {
+  ($a eq 'L' ) <=> ($b eq 'L' ) or
+  ($a eq 'NZ') <=> ($b eq 'NZ') or
+   $a          cmp  $b
+}
+
+sub resolve_arefs () {
+  #print Dumper(\%region);
+  foreach my $ra (sort keys %region) {
+    foreach my $adj (@{ $region{$ra}{Adj} }) {
+      next if defined $adj->{Name};
+      $adj->{ProspectiveName} = unique_aref $ra, $adj;
+    }
+  }
+  foreach my $ra (sort keys %region) {
+    foreach my $adj (@{ $region{$ra}{Adj} }) {
+      $adj->{Name} //= $adj->{ProspectiveName};
+    }
+  }
+  foreach my $ra (sort keys %region) {
+    foreach my $adj (@{ $region{$ra}{Adj} }) {
+      confess unless $adj->{Name} eq unique_aref $ra, $adj;
+    }
+  }
+}
+
+sub adjacencies () {
+  foreach my $ra (sort keys %region) {
+    my $adjs = $region{$ra}{Adj};
+    foreach my $adji (0..$#$adjs) {
+      my $adja = $adjs->[$adji];
+      my $rb = $adja->{Name};
+      my ($r0,$r1) = sort region_cmp ($ra,$rb);
+      push @{ $adj{$r0}{$r1}{L} }, $adja->{L};
+      push @{ $adj{$r0}{$r1}{T} }, substr($ra,0,1)."#".$adji;
+      my $e = $adj{$r0}{$r1};
+      $e->{Dikes} //= $adja->{Dikes};
+      confess "$r0 - $r1 | @{ $e->{L} } | $e->{Dikes} $adja->{Dikes} ?"
+         unless $e->{Dikes} == $adja->{Dikes};
+    }
+  }
+  my $ndikes = 0;
+  foreach my $r0 (sort keys %adj) {
+    foreach my $r1 (sort keys %{ $adj{$r0} }) {
+      my $e = $adj{$r0}{$r1};
+      confess "$r0 / $r1 : @{ $e->{L} } ?" unless @{ $e->{L} } == 2;
+      $ndikes += $e->{Dikes};
+    }
+  }
+  #print STDERR "total $ndikes dikes\n";
+}
+
+sub edge_id_to_other_id ($$) {
+  my ($ra, $adjia) = @_;
+  my $adjsa = $region{$ra}{Adj};
+  my $adja = $adjsa->[$adjia];
+  my $rb = $adja->{Name};
+  my $adjsb = $region{$rb}{Adj};
+  foreach my $adjib (0..$#$adjsb) {
+    my $adjb = $adjsb->[$adjib];
+    next unless $adjb->{Name} eq $ra;
+    # $adjb is the same edge seen from the other side
+    return ($rb, $adjib);
+  }
+  confess "$ra $adjia ?";
+}
+
+sub o { print @_ or die $!; }
+
+sub parse_input_graph () {
+  read_in();
+  resolve_arefs();
+  adjacencies();
+}
+
+1;