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