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 sub read_in () {
  18   my $ccolour;
  19   my $cregion;
  20
  21   while (<>) {
  22     next if m{^\s*\#};
  23     next unless m{\S};
  24     s{\s+$}{} or confess;
  25     if (m{^\w+}) {
  26       $ccolour = $&;
  27       next;
  28     }
  29     if (my ($name, $water) = m{^\t(\S.*\w)(?: \[(\d+)\])?$}) {
  30       confess unless defined $ccolour;
  31       confess "$name ?" if $region{$name};
  32       $region{$name}{Colour} = $ccolour;
  33       $region{$name}{Water} = $water;
  34       $region{$name}{L} = $.;
  35       $cregion = $name;
  36       next;
  37     }
  38     if (my ($aref, $adykes) = m{^\t\t(\S.*[A-Za-z.])(?: (\+\+?))?$}) {
  39       my $adj = { Dykes => length $adykes, L => $. };
  40       if ($aref =~ m{\.}) {
  41         $adj->{Pattern} = $aref;
  42         $aref =~ s{\-}{[^- ]*-}g;
  43         $aref =~ s{\.}{[^- ]* ?}g;
  44         $adj->{Regexp} = $aref;
  45       } else {
  46         $adj->{Name} = $aref;
  47       }
  48       push @{ $region{$cregion}{Adj} }, $adj;
  49       next;
  50     }
  51     confess "$_ ?";
  52   }
  53 }
  54
  55 sub unique_aref ($$) {
  56   my ($ra, $adja) = @_;
  57   my $re = $adja->{Regexp};
  58   return $adja->{Name} unless defined $re;
  59   my @cands;
  60   foreach my $rb (sort keys %region) {
  61     #print STDERR "?? $ra -> $re $rb ?\n";
  62     foreach my $adjb (@{ $region{$rb}{Adj} }) {
  63       my $adjbn = $adjb->{Name};
  64       next unless defined $adjbn;
  65       #print STDERR "?? $ra -> $re $rb ?? $adjbn\n";
  66       next unless $adjbn eq $ra;
  67       push @cands, $rb;
  68     }
  69   }
  70   my @found = grep { m{^$re$} } @cands;
  71   local $" = ' / ';
  72   confess "$adja->{L} $adja->{Pattern} /$re/ | @cands | @found | ?"
  73       unless @found==1;
  74   print "resolve $ra -> $adja->{Pattern} = @found\n";
  75   return $found[1];
  76 }
  77
  78 sub resolve_arefs () {
  79   #print Dumper(\%region);
  80   foreach my $ra (sort keys %region) {
  81     foreach my $adj (@{ $region{$ra}{Adj} }) {
  82       next if defined $adj->{Name};
  83       $adj->{ProspectiveName} = unique_aref $ra, $adj;
  84     }
  85   }
  86   foreach my $ra (sort keys %region) {
  87     foreach my $adj (@{ $region{$ra}{Adj} }) {
  88       $adj->{Name} //= $adj->{ProspectiveName};
  89     }
  90   }
  91   foreach my $ra (sort keys %region) {
  92     foreach my $adj (@{ $region{$ra}{Adj} }) {
  93       confess unless $adj->{Name} eq unique_aref $ra, $adj;
  94     }
  95   }
  96 }
  97
  98 read_in();
  99 resolve_arefs();
 100
 101 # Local variables:
 102 # cperl-indent-level: 2
 103 # End.