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