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