parse-input-graph

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