generate-board

   1 #!/usr/bin/perl -w
   2
   3 use strict;
   4 use Carp;
   5 use Data::Dumper;
   6 use Math::GSL::Vector;
   7 use Math::GSL::Matrix qw/:all/;
   8 use Math::GSL::Const;
   9 use Math::GSL::CBLAS qw/:all/;
  10 use Math::GSL::Machine qw/:all/;
  11
  12 use POSIX qw(M_PI);
  13
  14 BEGIN { unshift @INC, qw(.); }
  15
  16 our %c;
  17 require 'misc-data.pl';
  18
  19 use Parse;
  20
  21 our $facesf;
  22 our %vxname2pos; # $vxname2pos{VXNAME} = Math::GSL::Vector
  23
  24 sub TAU { M_PI * 2.0; }
  25 sub MM2PT { 72.0 / 25.4; }
  26
  27 # ----- region names from plag, incl. reverse mapping -----
  28
  29 our %prs2region;
  30
  31 sub prep_region_rmap () {
  32   foreach my $rn (keys %region) {
  33     my $prs = plag_prs($rn);
  34     die if $prs2region{$prs};
  35     $prs2region{$prs} = $rn;
  36   }
  37
  38   # bodgery for the sea and land
  39   $prs2region{'NZ | L'} = 'NZ';
  40   $prs2region{'L | NZ'} = 'NZ';
  41 }
  42
  43 our $sre = qr{(?:(\")|(?=\w))(.*)\1$}; # 2 captures, $2 is the name
  44
  45 sub prs2r ($) { $prs2region{$_[0]} // confess "@_ ?" }
  46 sub prs2rr ($) { $region{prs2r($_[0])} }
  47
  48 #----- file reader for plag output -----
  49
  50 sub read_faces () {
  51   # Sets
  52   #  $region{NAME}{Adj}[]{Ends}[]{VxName}
  53   #  $region{NAME}{Adj}[]{Ends}[]{Pos}
  54   #  $region{NAME}{Polygon}{Pos}
  55   #  $region{NAME}{Special}
  56   #
  57   # also incidentally
  58   #  $region{NAME}{Adj}[]{Ends}[]{Adjoins}
  59   #  $region{NAME}{Polygon}{Adjoins}
  60   # which should be ignored
  61
  62   open P, "<", $facesf or die $!;
  63   while (<P>) { last if m/^\&faces$/; }
  64   my $rr;
  65   my @edges;
  66   my $process_rr = sub {
  67     my $last_ai;
  68     if ($rr->{Name} eq 'NZ') {
  69       # We combined L and NZ; now we must split them again
  70       # in fact, we just throw away L entirely.
  71       # Here, when processing NZ, we keep only vertices that
  72       # are part of NZ.
  73       @edges = grep {
  74         my $evxname = $_->{VxName};
  75         my @eregions = split / \| ?/, $evxname;
  76         grep { $_ eq 'NZ' } @eregions
  77       } @edges;
  78     }
  79     $rr->{Polygon} = [ @edges ];
  80     if ($rr->{Name} ne 'NZ') {
  81       for my $ei (0..$#edges) {
  82         my $ej = $ei % @edges;
  83         if (!defined $last_ai) {
  84           my $ai;
  85           for my $ai (0..$#{ $rr->{Adj} }) {
  86             next unless $rr->{Adj}[$ai]{Name} eq $edges[$ei]{Adjoins};
  87             $last_ai = $ai+1;
  88           }
  89           confess $edges[$ei]{Adjoins}.' ?' unless defined $last_ai;
  90         }
  91         my $ai = ($last_ai-1+@edges) % @edges;
  92         $last_ai = $ai;
  93         my $adj = $rr->{Adj}[$ai];
  94         confess Dumper($rr, \@edges, $ei, $ej, $adj, $last_ai, $ai)." ?"
  95             unless $adj->{Name} eq $edges[$ei]{Adjoins};
  96
  97         for my $endi (0..1) {
  98           $adj->{Ends}[$endi] = $edges[ ($ei + $endi) % @edges ];
  99         }
 100       }
 101     }
 102     @edges = ();
 103     $rr = undef;
 104   };
 105   my $vxname;
 106   for (;;) {
 107     $!=0; $_=<P> // confess $!;
 108     last if m/^\&$/;
 109     if (m/^$sre$/) {
 110       my $new_face= $2;
 111       $process_rr->() if $rr;
 112       $rr= prs2rr($new_face);
 113     } elsif (m/^\s+$sre$/) {
 114       confess unless $rr;
 115       $vxname = $2;
 116       push @edges, { VxName => $vxname };
 117     } elsif (m/^\s+\^adjoins\s+$sre$/) {
 118       $edges[-1]{Adjoins} = prs2r($2);
 119     } elsif (m/^\s+\^\@([-e.0-9]+)\,([-e.0-9]+)$/) {
 120       my $pos = Math::GSL::Vector->new([$1,$2]);
 121       confess unless defined $vxname;
 122       $edges[-1]{Pos} = $pos;
 123       $vxname2pos{$vxname} = $pos;
 124     }
 125   }
 126   $process_rr->();
 127
 128   $region{$_}{Special} = 1 foreach qw(NZ L);
 129 }
 130
 131 #----- geometry mangling -----
 132
 133 sub calculate_centres () {
 134   # Sets
 135   #  $region{NAME}{Centre}
 136   foreach my $rr (values %region) {
 137     next if $rr->{Special};
 138     my $poly = $rr->{Polygon};
 139     my $sum = Math::GSL::Vector->new(2);
 140     $sum += $_->{Pos} foreach @$poly;
 141     $rr->{Centre} = $sum * (1.0 / @$poly);
 142   }
 143 }
 144
 145 sub for_each_pos ($) {
 146   my ($f) = @_;
 147   foreach my $rr (values %region) {
 148     $f->( \ $rr->{Centre} );
 149     foreach my $vertex (@{ $rr->{Polygon} }) {
 150       $f->( \ $vertex->{Pos} );
 151     }
 152   }
 153 }
 154
 155 sub transform_coordinates () {
 156   # Adjusts coordinates in graph to be [0,0] .. top right (scaled)
 157   # until it's all in PostScript points
 158   my @or = map { $region{$_}{Centre} } $c{OrientRegions};
 159   my $dir = $or[1] - $or[0];
 160   my $theta = atan2 $dir->[1], $dir->[0];
 161   my $rotateby = (90 - $c{OrientBearing}) * TAU - $theta;
 162   $rotateby += TAU*2;
 163   $rotateby %= TAU;
 164   my $s = sin($rotateby);
 165   my $c = cos($rotateby);
 166   my $transform = Math::GSL::Matrix->new([[  $c,  $s ],
 167                                           [ -$s,  $c ]]);
 168   my @lims;
 169   foreach my $topend (qw(0 1)) {
 170     my $v = $topend ? $GSL_DBL_MAX : $GSL_DBL_MIN;
 171     push @lims, Math::GSL::new([$v,$v]);
 172   }
 173   for_each_pos(sub {
 174     my ($pr) = @_;
 175     my $y = Math::GSL::Vector->new(2);
 176     gsl_blas_dgemv($CblasNoTrans, 1.0, $transform, $$pr, 0., $y) or confess;
 177     gsl_blas_dcopy($$pr, $y) or confess;
 178     foreach my $topend (qw(0 1)) {
 179       foreach my $xy (qw(0 1)) {
 180         my $now = $y->get($xy);
 181         my $lim = $lims[$topend]->get($xy);
 182         next if $topend ? ($now <= $lim) : ($now >= $lim);
 183         $lims[$topend]->set($xy, $now);
 184       }
 185     }
 186   });
 187   my $translate = -$lims[0];
 188   print STDERR "translate $translate\n";
 189   my $scale = $c{GraphScale} * MM2PT;
 190   for_each_pos(sub {
 191     my ($pr) = @_;
 192     gsl_vector_add($$pr, $translate) or confess;
 193     gsl_vector_scale($$pr, $scale) or confess;
 194   });
 195 }
 196
 197 #----- main program -----
 198
 199 ($facesf, @ARGV) = @ARGV or die;
 200 parse_input_graph();
 201 prep_region_rmap();
 202 read_faces();
 203 calculate_centres();
 204 transform_coordinates();
 205
 206 print Dumper(\%region);
 207
 208 # Local variables:
 209 # cperl-indent-level: 2
 210 # End.