parse-input-graph

   1 #!/usr/bin/perl -w
   2
   3 use strict;
   4 use Carp;
   5 use Data::Dumper;
   6
   7 our %region;
   8 # $region{NAME}{Colour}
   9 # $region{NAME}{Water}
  10 # $region{NAME}{L}
  11 # $region{NAME}{Adj}[]{Name}
  12 # $region{NAME}{Adj}[]{Pattern}
  13 # $region{NAME}{Adj}[]{Regexp}
  14 # $region{NAME}{Adj}[]{Dikes}
  15 # $region{NAME}{Adj}[]{L}
  16
  17 our %edges;
  18 # $edges{EARLIER}{LATER}{Dikes}
  19 # $edges{EARLIER}{LATER}{L}[]
  20
  21 sub read_in () {
  22   my $ccolour;
  23   my $cregion;
  24
  25   while (<>) {
  26     next if m{^\s*\#};
  27     next unless m{\S};
  28     s{\s+$}{} or confess;
  29     if (m{^\w+}) {
  30       $ccolour = $&;
  31       next;
  32     }
  33     if (my ($name, $water) = m{^\t(\S.*\w)(?: \[(\d+)\])?$}) {
  34       confess unless defined $ccolour;
  35       confess "$name ?" if $region{$name};
  36       $region{$name}{Colour} = $ccolour;
  37       $region{$name}{Water} = $water;
  38       $region{$name}{L} = $.;
  39       $cregion = $name;
  40       next;
  41     }
  42     if (my ($aref, $adikes) = m{^\t\t(\S.*[A-Za-z.])(?: (\+\+?))?$}) {
  43       my $adj = { Dikes => (length $adikes // 0), L => $. };
  44       if ($aref =~ m{\.}) {
  45         $adj->{Pattern} = $aref;
  46         $aref =~ s{\-}{[^- ]*-}g;
  47         $aref =~ s{\.+}{
  48             length $& eq 1 ? qr{[^- ]* ?} :
  49             length $& eq 2 ? qr{.*}       : confess "$aref"
  50         }ge;
  51         $adj->{Regexp} = $aref;
  52       } else {
  53         $adj->{Name} = $aref;
  54       }
  55       push @{ $region{$cregion}{Adj} }, $adj;
  56       next;
  57     }
  58     confess "$_ ?";
  59   }
  60 }
  61
  62 sub unique_aref ($$) {
  63   my ($ra, $adja) = @_;
  64   my $re = $adja->{Regexp};
  65   return $adja->{Name} unless defined $re;
  66   my @cands;
  67   foreach my $rb (sort keys %region) {
  68     #print STDERR "?? $ra -> $re $rb ?\n";
  69     foreach my $adjb (@{ $region{$rb}{Adj} }) {
  70       my $adjbn = $adjb->{Name};
  71       next unless defined $adjbn;
  72       #print STDERR "?? $ra -> $re $rb ?? $adjbn\n";
  73       next unless $adjbn eq $ra;
  74       push @cands, [ $rb, "$region{$rb}{L},$adjb->{L}" ];
  75     }
  76   }
  77   my @found = grep { $_->[0] =~ m{^$re$} } @cands;
  78   my $pr = sub {
  79     join ' / ', map { "$_->[0] ($_->[1])" } @_;
  80   };
  81   confess "$adja->{L} $adja->{Pattern} /$re/ | ".$pr->(@cands)
  82       ." | ".$pr->(@found)." | ?"
  83       unless @found==1;
  84   my $r = $found[0][0];
  85   print STDERR "resolve $ra -> $adja->{Pattern} = $r\n";
  86   return $r;
  87 }
  88
  89 sub resolve_arefs () {
  90   #print Dumper(\%region);
  91   foreach my $ra (sort keys %region) {
  92     foreach my $adj (@{ $region{$ra}{Adj} }) {
  93       next if defined $adj->{Name};
  94       $adj->{ProspectiveName} = unique_aref $ra, $adj;
  95     }
  96   }
  97   foreach my $ra (sort keys %region) {
  98     foreach my $adj (@{ $region{$ra}{Adj} }) {
  99       $adj->{Name} //= $adj->{ProspectiveName};
 100     }
 101   }
 102   foreach my $ra (sort keys %region) {
 103     foreach my $adj (@{ $region{$ra}{Adj} }) {
 104       confess unless $adj->{Name} eq unique_aref $ra, $adj;
 105     }
 106   }
 107 }
 108
 109 sub edges () {
 110   foreach my $ra (sort keys %region) {
 111     foreach my $adja (@{ $region{$ra}{Adj} }) {
 112       my $rb = $adja->{Name};
 113       my ($r0,$r1) = sort {
 114         ($a eq 'NZ') <=> ($b eq 'NZ') or
 115          $a          cmp  $b
 116       } ($ra,$rb);
 117       push @{ $edges{$r0}{$r1}{L} }, $adja->{L};
 118       my $e = $edges{$r0}{$r1};
 119       $e->{Dikes} //= $adja->{Dikes};
 120       confess "$r0 - $r1 | @{ $e->{L} } | $e->{Dikes} $adja->{Dikes} ?"
 121           unless $e->{Dikes} == $adja->{Dikes};
 122     }
 123   }
 124   my $ndikes = 0;
 125   foreach my $r0 (sort keys %edges) {
 126     foreach my $r1 (sort keys %{ $edges{$r0} }) {
 127       my $e = $edges{$r0}{$r1};
 128       confess "$r0 / $r1 : @{ $e->{L} } ?" unless @{ $e->{L} } == 2;
 129       $ndikes += $e->{Dikes};
 130     }
 131   }
 132   print STDERR "total $ndikes dikes\n";
 133 }
 134
 135 sub o { print @_ or die $!; }
 136
 137 sub output_dot () {
 138   o "strict graph \"map\" {\n";
 139   foreach my $r0 (sort keys %edges) {
 140     foreach my $r1 (sort keys %{ $edges{$r0} }) {
 141       my $e = $edges{$r0}{$r1};
 142       my $r1n = $r1;
 143       if ($r1 eq 'NZ') {
 144         $r1n = "_NZ $r0";
 145       }
 146       o "\"$r0\" -- \"$r1n\";\n";
 147     }
 148   }
 149   o "}\n";
 150 }
 151
 152 read_in();
 153 resolve_arefs();
 154 edges();
 155 output_dot();
 156
 157 # Local variables:
 158 # cperl-indent-level: 2
 159 # End.