layout/extractgraph

   1 #!/usr/bin/perl -w
   2 #
   3 # Reads the special comments in the subsegment encoding output from
   4 # layout, determines the segment graph, and outputs a description of
   5 # that graph.
   6
   7 # Approach/algorithm:
   8 #
   9 #  We read the segenco.ps and each time we find a `%L segmentpart'
  10 #  comment we add it to an annotated graph we construct.  Each node in
  11 #  the annotated graph is a tuple consisting of a loc and range of
  12 #  layer levels.  Each edge is a segment part from a %L comment.  Each
  13 #  node has a `front' and a `back', and each edget attach either to
  14 #  one or the other.
  15 #
  16 #  Only segment parts with certain layer kinds are processed: by
  17 #  default, only the empty layer kind.
  18 #
  19 #  When a loc is found in the input, as one end of a segmentpart, it
  20 #  is considered identical to a existing node (if its details are
  21 #  sufficiently similar) or creates a new node (if its details are
  22 #  sufficiently different).  If the segmentpart's end is considered
  23 #  identical to an existing node then the existing node's layer level
  24 #  range is extended, but the existing node's X Y and A are not
  25 #  modified.
  26 #
  27 #  A loc and layer level are compared with a node as follows:
  28 #
  29 #    The difference between each of the loc's details and the node's
  30 #    details is computed.  If any of the differences is at least the
  31 #    min clearance, then the loc/layerb is a new node.  Otherwise, all
  32 #    of the differences must be within the max tolerance and the
  33 #    loc/layer is the same as the node (coming out of the back if the
  34 #    180deg was added to make the angle difference).  Otherwise it is
  35 #    an error.
  36 #
  37 #    The detail differences are:
  38 #       Position difference: horizontal distance between loc and node
  39 #       Angle difference: difference betwen loc's and node's A, or
  40 #        difference minus 180deg between loc's and node's A, whichever
  41 #        is the smaller (both reduced mod 360deg to value with
  42 #        smallest magnitude).
  43 #       Level difference: 0 if layer level is within node's range
  44 #        or distance by which it is outside that range.
  45
  46 use strict qw(vars);
  47 use POSIX;
  48
  49 our %conf;
  50 $conf{MinClearLayer}= 6;
  51 $conf{MaxTolerLayer}= 4;
  52 $conf{MinClearDist}= 0.5;
  53 $conf{MaxTolerDist}= 0.05;
  54 $conf{MinClearAngle}= 5.0;
  55 $conf{MaxTolerAngle}= 0.5;
  56 $conf{LayerKinds}= ','; # comma-separated list as for split /\,/, ..., -1;
  57 $conf{EvenUnknownSegments}= 0;
  58
  59 our @layerkinds;
  60 @layerkinds= split /\,/, $conf{LayerKinds}, -1;
  61
  62 our @nodes;
  63 # $nodes[]{X}
  64 # $nodes[]{Y}
  65 # $nodes[]{A}
  66 # $nodes[]{LayerMin}
  67 # $nodes[]{LayerMax}
  68 # $nodes[]{"Edges$back"}[] = [ \$edges[], $far ]
  69
  70 our @edges;
  71 # $edges[]{"Node$far"}= [ \$nodes[], $back ]
  72 # $edges[]{Dist}
  73 # $edges[]{SubSegSpec}
  74
  75 our %segments;
  76 # $segments{$segname}{MovFeats}[$movfeatnum]{Name}
  77 # $segments{$segname}{MovFeats}[$movfeatnum]{Positions}
  78 # $segments{$segname}{MovFeatMap}{$movfeatname}= $movfeatnum
  79
  80 sub comment ($) {
  81     print "/* $_[0] */\n";
  82 }
  83
  84 sub sqr ($) { return $_[0]*$_[0]; }
  85
  86 sub find_node (@) {
  87     my ($lni,$isdest,$l,$x,$y,$a) = @_;
  88     my ($any_outside_toler, $any_outside_clear, $updlayer);
  89     my ($ni, $node, %diff, $back, $d, $k);
  90     $a -= 360.0 * floor($a / 360.0);
  91     for $node (@nodes) {
  92         $diff{Layer}= (($d = $l - $node->{LayerMin}) < 0 ? $d :
  93                        ($d = $l - $node->{LayerMax}) > 0 ? $d :
  94                        0);
  95         $diff{Dist}= sqrt(sqr($x - $node->{X}) +
  96                           sqr($y - $node->{Y}));
  97         $diff{Angle}= $a - $node->{A};                    # <-360,360>
  98         if ($diff{Angle} < 0) { $diff{Angle} += 360; }    # [0,360>
  99         $back= $diff{Angle} >= 90 && $diff{Angle} < 270;  # $back <=> [90,270>
 100         $back= !!$isdest != !!$back; # logical xor
 101         $back += 0;
 102         if ($back) { $diff{Angle} -= 180; }               # [0,90> or [270,360>
 103         if ($diff{Angle} > 180) { $diff{Angle} -= 360; }  # [-90,90>
 104         $any_outside_clear= 0;
 105         $any_outside_toler= 0;
 106         foreach $k (keys %diff) {
 107             if (abs($diff{$k}) >= $conf{"MinClear$k"}) {
 108                 $any_outside_clear=1; last;
 109             } elsif (abs($diff{$k}) <= $conf{"MaxToler$k"}) {
 110             } else {
 111                 $any_outside_toler=1;
 112             }
 113         }
 114         if ($any_outside_clear) {
 115         } elsif ($any_outside_toler) {
 116             die ("mismatch/clash:\n".
 117                  " $lni has L=$l XY=$x,$y A=$a\n".
 118                  " $node->{LineInfo} has ".
 119                  "L=$node->{LayerMin}..$node->{LayerMax}".
 120                  " XY=$node->{X},$node->{Y} A=$node->{A}\n ");
 121         } else {
 122             $updlayer= ($diff{Layer} < 0 ? "Min" :
 123                         $diff{Layer} > 0 ? "Max" :
 124                         '');
 125             if ($updlayer) {
 126                 $node->{"Layer$updlayer"}= $l;
 127                 $node->{LineInfo}.="($l<-$lni)";
 128             }
 129             comment("nodulated $lni ex.$node/$back ($x $y $a)");
 130             return ($node,$back);
 131         }
 132     }
 133     $node= { X => $x, Y => $y, A => $a,
 134              LayerMin => $l, LayerMax => $l, LineInfo => $lni };
 135     $back= 0;
 136     push @nodes, $node;
 137     comment("nodulated $lni new$node/$back ($x $y $a)");
 138     return ($node,$back);
 139 }
 140
 141 sub readin () {
 142     my ($layerkind, $level, $subsegspec, $numbers, @numbers, $dist);
 143     my ($node,$back,$far,@nodeinfo,@endnums,$edge);
 144     while (<>) {
 145         next unless m/^\%L /;
 146         die unless m/^\%L (\w+)\b/;
 147         next unless $1 eq 'segmentpart';
 148         die unless m/^\%L segmentpart ([A-Za-z_]*)(\d+) (\S+) ([-.eE0-9 ]+)$/;
 149         ($layerkind, $level, $subsegspec, $numbers) = ($1,$2,$3,$4);
 150         next unless grep { $layerkind eq $_ } @layerkinds;
 151         next unless $subsegspec =~ m,^[^/], or $conf{EvenUnknownSegments};
 152         @numbers = map { $_ + 0 } split / /, $numbers;
 153         $dist= shift @numbers;
 154         @numbers == 6 or die;
 155         $edge= { Dist => $dist, SubSegSpec => $subsegspec };
 156         for ($far=0; $far<2; $far++) {
 157             @endnums= @numbers[($far*3)..($far*3+2)];
 158             ($node,$back)= find_node("$.:$far",$far,$level,@endnums);
 159             $edge->{"Node$far"}= [ $node, $back ];
 160             push @{ $node->{"Edges$back"} }, [ $edge, $far ];
 161         }
 162         push @edges, $edge;
 163     }
 164 }
 165
 166 sub o ($@) {
 167     print join('',@_) or die $!;
 168 }
 169
 170 sub pr ($$) {
 171     my ($kind,$ref) = @_;
 172     $ref= "$ref";
 173     $ref =~ y/()/__/;
 174     return lc $ref.lc $kind;
 175 }
 176
 177 sub pr_edgeend ($) {
 178     my ($edgeend) = @_;
 179     my ($edge,$end) = @$edgeend;
 180     my ($endnum);
 181     $endnum= $end ^ !!($edge->{SubSegSpec} =~ m/^\-/);
 182     return pr(Edge,$edge).".ends[$endnum]";
 183 }
 184
 185 sub segments () {
 186     my ($edge, $sss);
 187     my ($segname, $movfeatpos, $movfeat, $movpos);
 188     my ($movfeatnum, $movfeatref);
 189     for $edge (@edges) {
 190         $sss= $edge->{SubSegSpec};
 191         $sss =~ m,^\-?(\w*)/(([A-Za-z]*)(\d*))$, or die "$sss ?";
 192         ($segname, $movfeatpos, $movfeat, $movpos) = ($1,$2,$3,$4);
 193         if (!exists $segments{$segname}) {
 194             $segments{$segname}= {
 195                 MovFeatMap => { '' => 0 },
 196                 MovFeats => [ { Name => '', Positions => 1 } ]
 197             };
 198         }
 199         $movfeatnum= $segments{$segname}{MovFeatMap}{$movfeat};
 200         if (!defined $movfeatnum) {
 201             $movfeatnum= @{ $segments{$segname}{MovFeats} };
 202             push @{ $segments{$segname}{MovFeats} },
 203                 { Name => $movfeat, Positions => 0 };
 204             $segments{$segname}{MovFeatMap}{$movfeat}= $movfeatnum;
 205         }
 206         $movfeatref= $segments{$segname}{MovFeats}[$movfeatnum];
 207         if (length $movfeat && $movpos >= $movfeatref->{Positions}) {
 208             $movfeatref->{Positions}= $movpos + 1;
 209         }
 210     }
 211 }
 212
 213 sub writeout () {
 214     my ($node, $edge, $i, $side, $sideedges);
 215     my ($end, $endnum, $sss, $reverse, $nodeside, $connectnum, $j, $edgeend);
 216     my ($segname, $segment, $movfeats, $movfeat, $delim);
 217     my ($movfeatpos, $movpos);
 218     o("\n");
 219     o("#include \"graph-data.h\"\n");
 220     for $node (@nodes) { o("static Node ",pr(Node,$node),";\n"); }
 221     for $edge (@edges) { o("static Edge ",pr(Edge,$edge),";\n"); }
 222     o("\n");
 223     for $segname (keys %segments) {
 224         $segment= $segments{$segname};
 225         $movfeats= $segment->{MovFeats};
 226         o("static MovFeat movfeats_$segname","[];\n");
 227         o("static Segment segment_$segname= {");
 228         o(" \"$segname\",");
 229         o(" ",scalar(@$movfeats),", movfeats_$segname");
 230         o(" };\n");
 231         o("static MovFeat movfeats_$segname","[]= {");
 232         $delim= "";
 233         for $movfeat (@$movfeats) {
 234             o("$delim\n");
 235             o("  { &segment_$segname, ");
 236             o(length $movfeat->{Name} ? "\"$movfeat->{Name}\"" : 0);
 237             o(", ", $movfeat->{Positions}+0);
 238             o(" }");
 239             $delim= ",";
 240         }
 241         o("\n};\n");
 242     }
 243     o("\n");
 244     for ($i=0; $i<@nodes; $i++) {
 245         $node= $nodes[$i];
 246         o("static Node ",pr(Node,$node),"= { \n");
 247         o("  ".($i>0 ? '&'.pr(Node,$nodes[$i-1]) : '0').
 248           ", ".($i<$#nodes ? '&'.pr(Node,$nodes[$i+1]) : '0'));
 249         o(", {");
 250         $delim= '';
 251         for ($side=0; $side<2; $side++) {
 252             o("$delim\n    { &".pr(Node,$node).", $side,");
 253             $sideedges= $node->{"Edges$side"};
 254             if (defined $sideedges && @$sideedges) {
 255                 o("\n      ",
 256                   '&'.pr_edgeend($sideedges->[0]),
 257                   ", ",
 258                   '&'.pr_edgeend($sideedges->[$#$sideedges]));
 259             } else {
 260                 o(' 0, 0');
 261             }
 262             o(" }");
 263             $delim= ',';
 264         }
 265         o("\n  }\n};\n");
 266     }
 267     o("\n");
 268     for $edge (@edges) {
 269         o("static Edge ",pr(Edge,$edge),"= {\n");
 270         o("  $edge->{Dist}, ");
 271         $sss= $edge->{SubSegSpec};
 272         $reverse= !!($sss =~ s/^\-//);
 273         if ($reverse) { o("/*reverse*/ "); }
 274         $sss =~ m,^(\w*)/(([A-Za-z]*)(\d*))$, or die;
 275         ($segname, $movfeatpos, $movfeat, $movpos) = ($1,$2,$3,$4);
 276         o("&movfeats_${segname}","[",
 277           $segments{$segname}{MovFeatMap}{$movfeat},
 278           "], ",
 279           (length $movfeat ? $movpos : 0),
 280           ", {");
 281         $delim= '';
 282         for ($endnum=0; $endnum<2; $endnum++) {
 283             $end= $endnum ^ $reverse;
 284             o("$delim\n    {");
 285             $nodeside= $edge->{"Node$end"};
 286             $node= $nodeside->[0]; $side= $nodeside->[1];
 287             $sideedges= $node->{"Edges$side"};
 288             undef $connectnum;
 289             for ($j=0; $j<@$sideedges; $j++) {
 290                 $edgeend= $sideedges->[$j];
 291                 if ($edgeend->[0] == $edge &&
 292                     $edgeend->[1] == $end) {
 293                     die if defined $connectnum;
 294                     $connectnum= $j;
 295                 }
 296             }
 297             die unless defined $connectnum;
 298             o(" ".($connectnum > 0 ?
 299                    '&'.pr_edgeend($sideedges->[$connectnum-1]) : '0'),
 300               ", ".($connectnum < $#$sideedges ?
 301                     '&'.pr_edgeend($sideedges->[$connectnum+1]) : '0'));
 302             o(",\n      &".pr(Edge,$edge),", $end, ",
 303               "&".pr(Node,$node).".sides[$side]");
 304             o(" }");
 305             $delim= ',';
 306         }
 307         o("\n  }\n};\n");
 308     }
 309     o("\n");
 310     o("NodeList all_nodes= { ",
 311       (@nodes ? '&'.pr(Node,$nodes[0]) : 0), ", ",
 312       (@nodes ? '&'.pr(Node,$nodes[$#nodes]) : 0),
 313       " };\n");
 314 }
 315
 316 o("/*autogenerated - do not edit*/\n\n");
 317 readin();
 318 segments();
 319 writeout();
 320
 321
 322 #    ($pts[0]{X}, $pts[0]{Y}, $pts[0]{A},
 323 #     $pts[1]{X}, $pts[1]{Y}, $pts[1]{A}) =
 324 #    $node[0]
 325
 326 #(\w+(?:(?:\/([A-Za-z]+)(\d+))?)?)