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
  48 our %conf;
  49 $conf{MinClearLayer}= 6;
  50 $conf{MaxTolerLayer}= 4;
  51 $conf{MinClearDist}= 0.5;
  52 $conf{MaxTolerDist}= 0.05;
  53 $conf{MinClearAngle}= 5.0;
  54 $conf{MaxTolerAngle}= 0.5;
  55 $conf{LayerKinds}= ','; # comma-separated list as for split /\,/, ..., -1;
  56 $conf{EvenUnknownSegments}= 0;
  57
  58 our @layerkinds;
  59 @layerkinds= split /\,/, $conf{LayerKinds}, -1;
  60
  61 our @nodes;
  62 # $nodes[]{X}
  63 # $nodes[]{Y}
  64 # $nodes[]{A}
  65 # $nodes[]{LayerMin}
  66 # $nodes[]{LayerMax}
  67 # $nodes[]{"Edges$back"}[] = [ \$edges[], $far ]
  68
  69 our @edges;
  70 # $edges[]{"Node$far"}= [ \$nodes[], $back ]
  71 # $edges[]{Dist}
  72 # $edges[]{SubSegSpec}
  73
  74 our %segments;
  75 # $segments{$segname}{MovFeats}[$movfeatnum]{Name}
  76 # $segments{$segname}{MovFeats}[$movfeatnum]{Positions}
  77 # $segments{$segname}{MovFeatMap}{$movfeatname}= $movfeatnum
  78
  79 sub comment ($) {
  80     print "/* $_[0] */\n";
  81 }
  82
  83 sub sqr ($) { return $_[0]*$_[0]; }
  84
  85 sub find_node (@) {
  86     my ($lni,$isdest,$l,$x,$y,$a) = @_;
  87     my ($any_outside_toler, $any_outside_clear, $updlayer);
  88     my ($ni, $node, %diff, $back, $d, $k);
  89     for $node (@nodes) {
  90         $diff{Layer}= (($d = $l - $node->{LayerMin}) < 0 ? $d :
  91                        ($d = $l - $node->{LayerMax}) > 0 ? $d :
  92                        0);
  93         $diff{Dist}= sqrt(sqr($x - $node->{X}) +
  94                           sqr($y - $node->{Y}));
  95         $diff{Angle}= $a - $node->{A};                    # <-360,360>
  96         if ($diff{Angle} < 0) { $diff{Angle} += 360; }    # [0,360>
  97         $back= $diff{Angle} >= 90 && $diff{Angle} < 270;  # $back <=> [90,270>
  98         $back= !!$isdest != !!$back; # logical xor
  99         $back += 0;
 100         if ($back) { $diff{Angle} -= 180; }               # [0,90> or [270,360>
 101         if ($diff{Angle} > 180) { $diff{Angle} -= 360; }  # [-90,90>
 102         $any_outside_clear= 0;
 103         $any_outside_toler= 0;
 104         foreach $k (keys %diff) {
 105             if (abs($diff{$k}) >= $conf{"MinClear$k"}) {
 106                 $any_outside_clear=1; last;
 107             } elsif (abs($diff{$k}) <= $conf{"MaxToler$k"}) {
 108             } else {
 109                 $any_outside_toler=1;
 110             }
 111         }
 112         if ($any_outside_clear) {
 113         } elsif ($any_outside_toler) {
 114             die ("mismatch/clash:\n".
 115                  " $lni has L=$l XY=$x,$y A=$a\n".
 116                  " $node->{LineInfo} has ".
 117                  "L=$node->{LayerMin}..$node->{LayerMax}".
 118                  " XY=$node->{X},$node->{Y} A=$node->{A}\n ");
 119         } else {
 120             $updlayer= ($diff{Layer} < 0 ? "Min" :
 121                         $diff{Layer} > 0 ? "Max" :
 122                         '');
 123             if ($updlayer) {
 124                 $node->{"Layer$updlayer"}= $l;
 125                 $node->{LineInfo}.="($l<-$lni)";
 126             }
 127             comment("nodulated $lni ex.$node/$back");
 128             return ($node,$back);
 129         }
 130     }
 131     $node= { X => $x, Y => $y, A => $a,
 132              LayerMin => $l, LayerMax => $l, LineInfo => $lni };
 133     $back= 0;
 134     push @nodes, $node;
 135     comment("nodulated $lni new$node/$back");
 136     return ($node,$back);
 137 }
 138
 139 sub readin () {
 140     my ($layerkind, $level, $subsegspec, $numbers, @numbers, $dist);
 141     my ($node,$back,$far,@nodeinfo,@endnums,$edge);
 142     while (<>) {
 143         next unless m/^\%L /;
 144         die unless m/^\%L (\w+)\b/;
 145         next unless $1 eq 'segmentpart';
 146         die unless m/^\%L segmentpart ([A-Za-z_]*)(\d+) (\S+) ([-.eE0-9 ]+)$/;
 147         ($layerkind, $level, $subsegspec, $numbers) = ($1,$2,$3,$4);
 148         next unless grep { $layerkind eq $_ } @layerkinds;
 149         next unless $subsegspec =~ m,^[^/], or $conf{EvenUnknownSegments};
 150         @numbers = map { $_ + 0 } split / /, $numbers;
 151         $dist= shift @numbers;
 152         @numbers == 6 or die;
 153         $edge= { Dist => $dist, SubSegSpec => $subsegspec };
 154         for ($far=0; $far<2; $far++) {
 155             @endnums= @numbers[($far*3)..($far*3+2)];
 156             ($node,$back)= find_node("$.:$far",$far,$level,@endnums);
 157             $edge->{"Node$far"}= [ $node, $back ];
 158             push @{ $node->{"Edges$back"} }, [ $edge, $far ];
 159         }
 160         push @edges, $edge;
 161     }
 162 }
 163
 164 sub o ($@) {
 165     print join('',@_) or die $!;
 166 }
 167
 168 sub pr ($$) {
 169     my ($kind,$ref) = @_;
 170     $ref= "$ref";
 171     $ref =~ y/()/__/;
 172     return lc $ref.lc $kind;
 173 }
 174
 175 sub pr_edgeend ($) {
 176     my ($edgeend) = @_;
 177     my ($edge,$end) = @$edgeend;
 178     my ($endnum);
 179     $endnum= $end ^ !!($edge->{SubSegSpec} =~ m/^\-/);
 180     return pr(Edge,$edge).".ends[$endnum]";
 181 }
 182
 183 sub segments () {
 184     my ($edge, $sss);
 185     my ($segname, $movfeatpos, $movfeat, $movpos);
 186     my ($movfeatnum, $movfeatref);
 187     for $edge (@edges) {
 188         $sss= $edge->{SubSegSpec};
 189         $sss =~ m,^\-?(\w*)/(([A-Za-z]*)(\d*))$, or die "$sss ?";
 190         ($segname, $movfeatpos, $movfeat, $movpos) = ($1,$2,$3,$4);
 191         if (!exists $segments{$segname}) {
 192             $segments{$segname}= {
 193                 MovFeatMap => { '' => 0 },
 194                 MovFeats => [ { Name => '', Positions => 1 } ]
 195             };
 196         }
 197         $movfeatnum= $segments{$segname}{MovFeatMap}{$movfeat};
 198         if (!defined $movfeatnum) {
 199             $movfeatnum= @{ $segments{$segname}{MovFeats} };
 200             push @{ $segments{$segname}{MovFeats} },
 201                 { Name => $movfeat, Positions => 0 };
 202             $segments{$segname}{MovFeatMap}{$movfeat}= $movfeatnum;
 203         }
 204         $movfeatref= $segments{$segname}{MovFeats}[$movfeatnum];
 205         if (length $movfeat && $movpos >= $movfeatref->{Positions}) {
 206             $movfeatref->{Positions}= $movpos + 1;
 207         }
 208     }
 209 }
 210
 211 sub writeout () {
 212     my ($node, $edge, $i, $side, $sideedges);
 213     my ($end, $endnum, $sss, $reverse, $nodeside, $connectnum, $j, $edgeend);
 214     my ($segname, $segment, $movfeats, $movfeat, $delim);
 215     my ($movfeatpos, $movpos);
 216     o("\n");
 217     o("#include \"graph-data.h\"\n");
 218     for $node (@nodes) { o("static Node ",pr(Node,$node),";\n"); }
 219     for $edge (@edges) { o("static Edge ",pr(Edge,$edge),";\n"); }
 220     o("\n");
 221     for $segname (keys %segments) {
 222         $segment= $segments{$segname};
 223         $movfeats= $segment->{MovFeats};
 224         o("static MovFeat movfeats_${segname}[];\n");
 225         o("static Segment segment_$segname= {");
 226         o(" \"$segname\",");
 227         o(" ",scalar(@$movfeats),", movfeats_$segname");
 228         o(" };\n");
 229         o("static MovFeat movfeats_${segname}[]= {");
 230         $delim= "";
 231         for $movfeat (@$movfeats) {
 232             o("$delim\n");
 233             o("  { &segment_$segname, ");
 234             o(length $movfeat->{Name} ? "\"$movfeat->{Name}\"" : 0);
 235             o(", ", $movfeat->{Positions}+0);
 236             o(" }");
 237             $delim= ",";
 238         }
 239         o("\n};\n");
 240     }
 241     o("\n");
 242     for ($i=0; $i<@nodes; $i++) {
 243         $node= $nodes[$i];
 244         o("static Node ",pr(Node,$node),"= { \n");
 245         o("  ".($i>0 ? '&'.pr(Node,$nodes[$i-1]) : '0').
 246           ", ".($i<$#nodes ? '&'.pr(Node,$nodes[$i+1]) : '0'));
 247         o(", {");
 248         $delim= '';
 249         for ($side=0; $side<2; $side++) {
 250             o("$delim\n    { &".pr(Node,$node).", $side,");
 251             $sideedges= $node->{"Edges$side"};
 252             if (defined $sideedges && @$sideedges) {
 253                 o("\n      ",
 254                   '&'.pr_edgeend($sideedges->[0]),
 255                   ", ",
 256                   '&'.pr_edgeend($sideedges->[$#$sideedges]));
 257             } else {
 258                 o(' 0, 0');
 259             }
 260             o(" }");
 261             $delim= ',';
 262         }
 263         o("\n  }\n};\n");
 264     }
 265     o("\n");
 266     for $edge (@edges) {
 267         o("static Edge ",pr(Edge,$edge),"= {\n");
 268         o("  $edge->{Dist}, ");
 269         $sss= $edge->{SubSegSpec};
 270         $reverse= !!($sss =~ s/^\-//);
 271         if ($reverse) { o("/*reverse*/ "); }
 272         $sss =~ m,^(\w*)/(([A-Za-z]*)(\d*))$, or die;
 273         ($segname, $movfeatpos, $movfeat, $movpos) = ($1,$2,$3,$4);
 274         o("&movfeats_${segname}[",
 275           $segments{$segname}{MovFeatMap}{$movfeat},
 276           "], ",
 277           (length $movfeat ? $movpos : 0),
 278           ", {");
 279         $delim= '';
 280         for ($endnum=0; $endnum<2; $endnum++) {
 281             $end= $endnum ^ $reverse;
 282             o("$delim\n    {");
 283             $nodeside= $edge->{"Node$end"};
 284             $node= $nodeside->[0]; $side= $nodeside->[1];
 285             $sideedges= $node->{"Edges$side"};
 286             undef $connectnum;
 287             for ($j=0; $j<@$sideedges; $j++) {
 288                 $edgeend= $sideedges->[$j];
 289                 if ($edgeend->[0] == $edge &&
 290                     $edgeend->[1] == $end) {
 291                     die if defined $connectnum;
 292                     $connectnum= $j;
 293                 }
 294             }
 295             die unless defined $connectnum;
 296             o(" ".($connectnum > 0 ?
 297                    '&'.pr_edgeend($sideedges->[$connectnum-1]) : '0'),
 298               ", ".($connectnum < $#$sideedges ?
 299                     '&'.pr_edgeend($sideedges->[$connectnum+1]) : '0'));
 300             o(",\n      &".pr(Edge,$edge),", $end, ",
 301               "&".pr(Node,$node).".sides[$side]");
 302             o(" }");
 303             $delim= ',';
 304         }
 305         o("\n  }\n};\n");
 306     }
 307     o("\n");
 308     o("Node *nodes_head= ",(@nodes ? '&'.pr(Node,$nodes[0]) : 0),";\n");
 309     o("Node *nodes_tail= ",(@nodes ? '&'.pr(Node,$nodes[$#nodes]) : 0),";\n");
 310 }
 311
 312 o("/*autogenerated - do not edit*/\n\n");
 313 readin();
 314 segments();
 315 writeout();
 316
 317
 318 #    ($pts[0]{X}, $pts[0]{Y}, $pts[0]{A},
 319 #     $pts[1]{X}, $pts[1]{Y}, $pts[1]{A}) =
 320 #    $node[0]
 321
 322 #(\w+(?:(?:\/([A-Za-z]+)(\d+))?)?)