Parse.pm

   1
   2 package Parse;
   3
   4 use strict;
   5 use Carp;
   6 use Graph;
   7
   8 use Exporter;
   9
  10 our @ISA = qw(Exporter);
  11 our @EXPORT = qw(parse_input_graph o plag_prs %region);
  12
  13 our %region;
  14 # $region{NAME}{Colour}
  15 # $region{NAME}{Water}
  16 # $region{NAME}{Name}
  17 # $region{NAME}{L} # line number
  18 # $region{NAME}{Adj}[]{Name}
  19 # $region{NAME}{Adj}[]{Pattern}
  20 # $region{NAME}{Adj}[]{Regexp}
  21 # $region{NAME}{Adj}[]{Dikes}
  22 # $region{NAME}{Adj}[]{L}
  23
  24 our %adj;
  25 # $adj{EARLIER}{LATER}{Dikes}
  26 # $adj{EARLIER}{LATER}{L}[]
  27 # $adj{EARLIER}{LATER}{T}[]
  28
  29 sub read_in () {
  30   my $ccolour;
  31   my $cregion;
  32
  33   while (<>) {
  34     next if m{^\s*\#};
  35     next unless m{\S};
  36     s{\s+$}{} or confess;
  37     if (m{^\w+}) {
  38       $ccolour = $&;
  39       next;
  40     }
  41     if (my ($name, $water) = m{^\t(\S.*\w|L)(?: \[(\d+)\])?$}) {
  42       confess unless defined $ccolour;
  43       confess "$name ?" if $region{$name};
  44       $region{$name}{Colour} = $ccolour;
  45       $region{$name}{Water} = $water;
  46       $region{$name}{L} = $.;
  47       $cregion = $name;
  48       next;
  49     }
  50     if (my ($aref, $adikes) = m{^\t\t(\S.*[A-Za-z.]|L)(?: (\+\+?))?$}) {
  51       my $adj = { Dikes => (length $adikes // 0), L => $. };
  52       if ($aref =~ m{\.}) {
  53         $adj->{Pattern} = $aref;
  54         $aref =~ s{\-}{[^- ]*-}g;
  55         $aref =~ s{\.+}{
  56             length $& eq 1 ? qr{[^- ]* ?} :
  57             length $& eq 2 ? qr{.*}       : confess "$aref"
  58         }ge;
  59         $adj->{Regexp} = $aref;
  60       } else {
  61         $adj->{Name} = $aref;
  62       }
  63       push @{ $region{$cregion}{Adj} }, $adj;
  64       next;
  65     }
  66     confess "$_ ?";
  67   }
  68 }
  69
  70 sub unique_aref ($$) {
  71   my ($ra, $adja) = @_;
  72   my $re = $adja->{Regexp};
  73   return $adja->{Name} unless defined $re;
  74   my @cands;
  75   foreach my $rb (sort keys %region) {
  76     #print STDERR "?? $ra -> $re $rb ?\n";
  77     foreach my $adjb (@{ $region{$rb}{Adj} }) {
  78       my $adjbn = $adjb->{Name};
  79       next unless defined $adjbn;
  80       #print STDERR "?? $ra -> $re $rb ?? $adjbn\n";
  81       next unless $adjbn eq $ra;
  82       push @cands, [ $rb, "$region{$rb}{L},$adjb->{L}" ];
  83     }
  84   }
  85   my @found = grep { $_->[0] =~ m{^$re$} } @cands;
  86   my $pr = sub {
  87     join ' / ', map { "$_->[0] ($_->[1])" } @_;
  88   };
  89   confess "$adja->{L} $adja->{Pattern} /$re/ | ".$pr->(@cands)
  90       ." | ".$pr->(@found)." | ?"
  91       unless @found==1;
  92   my $r = $found[0][0];
  93   #print STDERR "resolve $ra -> $adja->{Pattern} = $r\n";
  94   return $r;
  95 }
  96
  97 sub region_cmp {
  98   ($a eq 'L' ) <=> ($b eq 'L' ) or
  99   ($a eq 'NZ') <=> ($b eq 'NZ') or
 100    $a          cmp  $b
 101 }
 102
 103 sub resolve_arefs () {
 104   #print Dumper(\%region);
 105   foreach my $ra (sort keys %region) {
 106     foreach my $adj (@{ $region{$ra}{Adj} }) {
 107       next if defined $adj->{Name};
 108       $adj->{ProspectiveName} = unique_aref $ra, $adj;
 109     }
 110   }
 111   foreach my $ra (sort keys %region) {
 112     foreach my $adj (@{ $region{$ra}{Adj} }) {
 113       $adj->{Name} //= $adj->{ProspectiveName};
 114     }
 115   }
 116   foreach my $ra (sort keys %region) {
 117     foreach my $adj (@{ $region{$ra}{Adj} }) {
 118       confess unless $adj->{Name} eq unique_aref $ra, $adj;
 119     }
 120   }
 121 }
 122
 123 sub adjacencies () {
 124   foreach my $ra (sort keys %region) {
 125     my $adjs = $region{$ra}{Adj};
 126     foreach my $adji (0..$#$adjs) {
 127       my $adja = $adjs->[$adji];
 128       my $rb = $adja->{Name};
 129       my ($r0,$r1) = sort region_cmp ($ra,$rb);
 130       push @{ $adj{$r0}{$r1}{L} }, $adja->{L};
 131       push @{ $adj{$r0}{$r1}{T} }, substr($ra,0,1)."#".$adji;
 132       my $e = $adj{$r0}{$r1};
 133       $e->{Dikes} //= $adja->{Dikes};
 134       confess "$r0 - $r1 | @{ $e->{L} } | $e->{Dikes} $adja->{Dikes} ?"
 135           unless $e->{Dikes} == $adja->{Dikes};
 136     }
 137   }
 138   my $ndikes = 0;
 139   foreach my $r0 (sort keys %adj) {
 140     foreach my $r1 (sort keys %{ $adj{$r0} }) {
 141       my $e = $adj{$r0}{$r1};
 142       confess "$r0 / $r1 : @{ $e->{L} } ?" unless @{ $e->{L} } == 2;
 143       $ndikes += $e->{Dikes};
 144     }
 145   }
 146   #print STDERR "total $ndikes dikes\n";
 147 }
 148
 149 sub names () {
 150   foreach my $r (sort keys %region) {
 151     $region{$r}{Name} = $r;
 152   }
 153 }
 154
 155 sub edge_id_to_other_id ($$) {
 156   my ($ra, $adjia) = @_;
 157   my $adjsa = $region{$ra}{Adj};
 158   my $adja = $adjsa->[$adjia];
 159   my $rb = $adja->{Name};
 160   my $adjsb = $region{$rb}{Adj};
 161   foreach my $adjib (0..$#$adjsb) {
 162     my $adjb = $adjsb->[$adjib];
 163     next unless $adjb->{Name} eq $ra;
 164     # $adjb is the same edge seen from the other side
 165     return ($rb, $adjib);
 166   }
 167   confess "$ra $adjia ?";
 168 }
 169
 170 sub o { print @_ or die $!; }
 171
 172 sub plag_prs ($) {
 173     my ($t) = @_;
 174     $t = $` if $t =~ m/\n/;
 175     $t =~ s/ //g;
 176     $t =~ s/-//g;
 177     return "$t";
 178 }
 179
 180 sub parse_input_graph () {
 181   read_in();
 182   resolve_arefs();
 183   adjacencies();
 184   names();
 185 }
 186
 187 1;