libraries/afm/compile_afm.pl

   1 #!/usr/local/bin/perl -w
   2
   3 require 5.005;
   4 use strict;
   5
   6 # The glyps list can be downloaded from
   7 # http://partners.adobe.com/asn/developer/type/glyphlist.txt
   8 # This URL is from this page:
   9 # http://partners.adobe.com/asn/developer/type/unicodegn.html
  10 # which is refered from
  11 # http://partners.adobe.com/asn/developer/technotes/fonts.html
  12
  13 my $onlyHelvetica = 0;
  14
  15 my %globalName2Unicode;
  16 my %font_code = ();
  17
  18 my $indent0 = "";
  19 my $indent1 = "  ";
  20 my $indent2 = $indent1 x 3;
  21
  22 my $q = 0;
  23 my $qU = 0;
  24
  25 sub read_glyphlist
  26 {
  27   my $fn ="glyphlist.txt";
  28   open(FH, $fn)
  29   || die "Can't read $fn\n";
  30   my %seen = ();
  31   while (<FH>) {
  32     next if /^\s*#/;
  33     next unless /^([0-9A-F]{4});(\w+);/;
  34     my $unicode = 0 + hex($1);
  35     my $name = $2;
  36     next if ($globalName2Unicode{$name});
  37     $globalName2Unicode{$name} = $unicode;
  38   }
  39   close(FH);
  40 }
  41
  42 sub process_all_fonts
  43 {
  44   my $dir = ".";
  45   my $wc = "*.afm";
  46   $wc = "Helvetica.afm" if $onlyHelvetica;
  47   $wc = "ZapfDin.afm" if 0;
  48   $wc = "Helve*.afm" if 0;
  49   $wc = "Times-BoldItalic.afm" if 0;
  50   foreach my $fn (glob("$dir/$wc")) {
  51     process_font($fn);
  52   }
  53 }
  54
  55 sub process_font
  56 {
  57   my ($fn) = @_;
  58   print STDERR "Compiling afm file: $fn\n";
  59   my %fi = (); # font info
  60   my $c = "";
  61   $fi{C} = \$c;
  62   $fi{ligaturesR} = {};
  63   $fi{FontSpecificUnicodeNameToChar} = {};
  64   $fi{filename} = $fn;
  65   $fi{filename} =~ s/.*\///;
  66   open(FH, $fn) || die "Can't open $fn\n";
  67   print STDERR "Reads global font info\n" if $q;
  68   while (<FH>) {
  69     chomp;
  70     next if /^\s*$/ || /^\s*#/;
  71     last if /^StartCharMetrics/;
  72     next unless (/^(\S+)\s+(\S(.*\S)?)/);
  73     my $id = $1;
  74     my $value = $2;
  75     $value =~ s/\s+/ /g;
  76     $fi{"Afm$id"} = $value;
  77   }
  78   my $fontName = $fi{AfmFontName};
  79   $c .= "\n\n/* ". ("-" x 66) . "*/\n";
  80   $c .= "/* FontName: $fontName */\n";
  81   $c .= "/* FullName: $fi{AfmFullName} */\n";
  82   $c .= "/* FamilyName: $fi{AfmFamilyName} */\n";
  83   $fi{cName} = $fontName;
  84   $fi{cName} =~ s/\W/_/g;
  85   my %charMetrics = ();
  86   my %kerning = ();
  87   read_charmetrics(\%fi, \%charMetrics);
  88   while (<FH>) {
  89     read_kerning(\%fi, \%kerning) if /^StartKernPairs/;
  90   }
  91   if (0) {
  92     my @names = keys %charMetrics;
  93     print STDERR "Did read ", ($#names + 1), " font metrics\n";
  94   }
  95   write_font(\%fi, \%charMetrics, \%kerning);
  96 }
  97
  98 sub read_charmetrics
  99 {
 100   my ($fiR, $charMetricsR) = @_;
 101   print STDERR "Reads char metric info\n" if $q;
 102   my $isZapfDingbats = $$fiR{AfmFontName} eq "ZapfDingbats";
 103   my $ligaturesR = $$fiR{ligaturesR};
 104   my %ligatures = ();
 105   my %seenUnicodes = ();
 106   while (<FH>) {
 107     chomp;
 108     next if /^\s*$/ || /^\s*#/;
 109     last if /^EndCharMetrics/;
 110 #next unless /N S / || /N comma /;
 111 #next unless /N ([sfil]|fi) /;
 112 #print "$_\n";
 113     my $line = $_;
 114 # C 102 ; WX 333 ; N f ; B -169 -205 446 698 ; L i fi ; L l fl ;
 115     my ($width, $unicode, $name, @charLigatures);
 116     foreach (split/\s*;\s*/, $line) {
 117       if (/^C\s+(-?\d+)/) {
 118         $unicode = 0 + $1;
 119       } elsif (/^N\s+(\w+)/) {
 120         $name = $1;
 121       } elsif (/^WX?\s+(-?\d+)/) {
 122         $width = normalize_width($1, 0);
 123       } elsif (/^L\s+(\w+)\s+(\w+)/) {
 124         push(@charLigatures, $1, $2);
 125       }
 126     }
 127     if ($unicode < 0) {
 128       unless (defined $name) {
 129         print STDERR "Glyph missing name and code: $_\n";
 130         next;
 131       }
 132       $unicode = name2uni($fiR, $name);
 133       print STDERR "name2uni: $name -> $unicode\n" if $qU && 0;
 134     } elsif (defined $name) {
 135       my $std = $globalName2Unicode{$name};
 136       if (!defined $std) {
 137         print STDERR "Adds unicode mapping: ",
 138           "$name -> $unicode\n" if $qU;
 139         ${$$fiR{FontSpecificUnicodeNameToChar}}{$name} = $unicode;
 140       } else {
 141         $unicode = $std;
 142       }
 143     }
 144     if (!defined($unicode) || $unicode <= 0) {
 145       next if $isZapfDingbats && $name =~ /^a(\d+)$/;
 146       next if $$fiR{AfmFontName} eq "Symbol" && $name eq "apple";
 147       print STDERR "Glyph '$name' has unknown unicode: $_\n";
 148       next;
 149     }
 150     unless (defined $width) {
 151       print STDERR "Glyph '$name' missing width: $_\n";
 152       next;
 153     }
 154     if ($seenUnicodes{$unicode}) {
 155       print STDERR "Duplicate character: unicode = $unicode, ",
 156         "$name and ", $seenUnicodes{$unicode},
 157         " (might be due to Adobe charset remapping)\n";
 158       next;
 159     }
 160     $seenUnicodes{$unicode} = $name;
 161     my %c = ();
 162     $c{name} = $name;
 163     $c{unicode} = $unicode;
 164     $c{width} = $width;
 165     $$charMetricsR{$unicode} = \%c;
 166     $ligatures{$unicode} = \@charLigatures if $#charLigatures >= 0;
 167   }
 168   foreach my $unicode (keys %ligatures) {
 169     my $aR = $ligatures{$unicode};
 170     my $unicode2 = name2uni($fiR, $$aR[0]);
 171     my $unicode3 = name2uni($fiR, $$aR[1]);
 172     unless ($unicode2) {
 173       print STDERR "Missing ligature char 1: $$aR[0]\n";
 174       next;
 175     }
 176     unless ($unicode3) {
 177       print STDERR "Missing ligature char 2: $$aR[1]\n";
 178       next;
 179     }
 180     my $key = sprintf("%04d;%04d", $unicode, $unicode2);
 181     $$ligaturesR{$key} = $unicode3;
 182   }
 183 }
 184
 185 sub name2uni
 186 {
 187   my ($fiR, $name) = @_;
 188   my $fontMapR = $$fiR{FontSpecificUnicodeNameToChar};
 189   return $globalName2Unicode{$name} || $$fontMapR{$name};
 190 }
 191
 192 sub read_kerning
 193 {
 194   my ($fiR, $kerningR) = @_;
 195   print STDERR "Reads kerning info\n" if $q;
 196   while (<FH>) {
 197     chomp;
 198     next if /^\s*$/ || /^\s*#/;
 199     last if /^EndKernPairs/;
 200     unless (/^KPX\s+(\w+)\s+(\w+)\s+(-?\d+)\s*$/) {
 201       print STDERR "Can't parse kern spec: $_\n";
 202       next;
 203     }
 204     my $name1 = $1;
 205     my $name2 = $2;
 206     my $delta = normalize_width($3, 1);
 207     next unless $delta;
 208     my $unicode1 = name2uni($fiR, $name1);
 209     my $unicode2 = name2uni($fiR, $name2);
 210     unless ($unicode1 && $unicode2) {
 211       print "Unknown kern pair: $name1 and $name2\n";
 212       next;
 213     }
 214     my $charR = $$kerningR{$unicode1};
 215     unless (defined $charR) {
 216       my %c = ();
 217       $charR = \%c;
 218       $$kerningR{$unicode1} = $charR;
 219     }
 220     $$charR{$unicode2} = $delta;
 221   }
 222 }
 223
 224 sub write_font
 225 {
 226   my ($fiR, $charMetricsR, $kerningR) = @_;
 227   print STDERR "Writes font\n" if $q;
 228   my $cR = $$fiR{C};
 229   $$fiR{widthsA} = make_array();
 230   $$fiR{kerning_indexA} = make_array();
 231   $$fiR{kerning_dataA} = make_array();
 232   $$fiR{highchars_indexA} = make_array();
 233   $$fiR{ligaturesA} = make_array();
 234   write_font_metrics($fiR, $charMetricsR, $kerningR);
 235   write_ligatures($fiR);
 236   my $widths_count = array_size($$fiR{widthsA});
 237   my $kerning_index_count = array_size($$fiR{kerning_indexA});
 238   my $kerning_data_count = array_size($$fiR{kerning_dataA});
 239   my $highchars_count = array_size($$fiR{highchars_indexA});
 240   my $ligatures_count = array_size($$fiR{ligaturesA}) / 3;
 241   my $info_code = "";
 242   my $i2 = $indent2;
 243   my $packedSize = $widths_count + 2 * $kerning_index_count +
 244      $kerning_data_count + 2 * $highchars_count +
 245      3 * 2 * $ligatures_count;
 246   $info_code .= $indent1 . "{ /* $$fiR{filename}   $packedSize bytes */\n";
 247     $info_code .= $i2 . "\"$$fiR{AfmFontName}\",";
 248     $info_code .= " \"$$fiR{AfmFullName}\",\n";
 249     $info_code .= $i2 . $$fiR{widthsACName} . ",\n";
 250     $info_code .= $i2 . $$fiR{kerning_indexACName} . ",\n";
 251     $info_code .= $i2 . $$fiR{kerning_dataACName} . ",\n";
 252     $info_code .= $i2 . $$fiR{highchars_indexACName} . ", ";
 253     $info_code .= $highchars_count . ",\n";
 254     $info_code .= $i2 . $$fiR{ligaturesACName} . ", ";
 255     $info_code .= $ligatures_count;
 256     $info_code .= "},\n";
 257   $font_code{$$fiR{AfmFullName}} = { TABLES => $$cR, INFO => $info_code};
 258 }
 259
 260 sub write_font_metrics
 261 {
 262   my ($fiR, $charMetricsR, $kerningR) = @_;
 263   print STDERR "Writes font metrics\n" if $q;
 264   my $lastUnicode = 31;
 265   my $cR = $$fiR{C};
 266   my $widthsA = $$fiR{widthsA};
 267   my $kerning_indexA = $$fiR{kerning_indexA};
 268   my $kerning_dataA = $$fiR{kerning_dataA};
 269   my $highchars_indexA = $$fiR{highchars_indexA};
 270   my @uniArray = sort { $a <=> $b } keys %$charMetricsR;
 271   my $highchars_count = 0;
 272   my $had_kerning = 0;
 273   while (1) {
 274     my $fill = 0;
 275     if ($#uniArray < 0) {
 276       last if $lastUnicode > 126;
 277       $fill = 1;
 278     } elsif ($lastUnicode < 126 && $uniArray[0] > $lastUnicode + 1) {
 279       $fill = 1;
 280     }
 281     if ($fill) {
 282       $lastUnicode++;
 283 #print STDERR "fill for $lastUnicode, $#uniArray, $uniArray[0]\n";
 284       append_to_array($widthsA, 0);
 285       append_to_array($kerning_indexA, 0);
 286       next;
 287     }
 288     my $unicode = shift @uniArray;
 289     next if $unicode < 32;
 290     $lastUnicode = $unicode;
 291     my $metricsR = $$charMetricsR{$unicode};
 292     if ($unicode > 126) {
 293       append_to_array($highchars_indexA, $unicode);
 294       $highchars_count++;
 295     }
 296     my $m = $$metricsR{width};
 297     $m = "/* ".array_size($widthsA)."=$unicode */". $m if 0;
 298     append_to_array($widthsA, $m);
 299     my $kerningInfoR = $$kerningR{$unicode};
 300     my $kerning_index = 0;
 301     if (defined $kerningInfoR) {
 302       my @kerns = ();
 303       my $numKernings = 0;
 304       foreach my $unicode2 (sort { $a <=> $b } keys %$kerningInfoR) {
 305         my $delta = $$kerningInfoR{$unicode2};
 306         $numKernings++;
 307         append_escaped_16bit_int(\@kerns, $unicode2);
 308         push(@kerns, $delta);
 309         $had_kerning = 1;
 310       }
 311       $kerning_index = append_8bit_subarray($kerning_dataA, $numKernings, @kerns);
 312     }
 313     append_to_array($kerning_indexA, $kerning_index);
 314   }
 315   $$fiR{kerning_indexA} = make_array() if !$had_kerning;
 316   write_array($fiR, "widths", "afm_cuint8");
 317   write_array($fiR, "kerning_index", "afm_sint16");
 318   write_array($fiR, "kerning_data", "afm_cuint8");
 319   write_array($fiR, "highchars_index", "afm_cuint16");
 320 }
 321
 322 sub write_ligatures
 323 {
 324   my ($fiR) = @_;
 325   print STDERR "Writes font ligatures\n" if $q;
 326   my $ligaturesA = $$fiR{ligaturesA};
 327   my $ligaturesR = $$fiR{ligaturesR};
 328   foreach (sort keys %$ligaturesR) {
 329     unless (/^(\w{4});(\w{4})$/) {
 330       die "Invalid ligature key: $_";
 331     }
 332     append_to_array($ligaturesA, $1 + 0, $2 + 0, $$ligaturesR{$_});
 333   }
 334   write_array($fiR, "ligatures", "afm_cunicode");
 335 }
 336
 337 sub indent
 338 {
 339   my ($num) = @_;
 340   return "  " x $num;
 341 }
 342
 343 sub make_array
 344 {
 345   my @a = ();
 346   return \@a;
 347 }
 348
 349 sub append_to_array
 350 {
 351   my ($aR, @newElements) = @_;
 352   my $z1 = array_size($aR);
 353   push(@$aR, @newElements);
 354   my $z2 = array_size($aR);
 355   my $zz = $#newElements +1;
 356 }
 357
 358 sub append_8bit_subarray
 359 {
 360   my ($aR, $numItems, @newElements) = @_;
 361   push(@$aR, 42) if !array_size($aR); # initial dummy value
 362   die if $numItems > $#newElements + 1;
 363   my $idx = $#{$aR} + 1;
 364 #print "append_8bit_subarray ", ($#newElements+1), " = (", join(", ", @newElements), ") -> $idx\n";
 365   append_escaped_16bit_int($aR, $numItems);
 366   push(@$aR, @newElements);
 367   die "Can't handle that big sub array, sorry...\n" if $idx > 50000;
 368   return $idx;
 369 }
 370
 371 sub append_escaped_16bit_int
 372 {
 373   my ($aR, $count) = @_;
 374   die "Invalid count = 0\n" unless $count;
 375   if ($count >= 510) {
 376     push(@$aR, 1, int($count / 256), int($count % 256));
 377     print STDERR "full: $count\n" if 0;
 378   } elsif ($count >= 254) {
 379     push(@$aR, 0, $count - 254);
 380     print STDERR "semi: $count\n" if 0;
 381   } else {
 382     push(@$aR, $count + 1);
 383   }
 384 }
 385
 386 sub array_size
 387 {
 388   my ($aR) = @_;
 389   return $#{$aR} + 1;
 390 }
 391
 392 sub write_array
 393 {
 394   my ($fiR, $name, $type) = @_;
 395   my $aR = $$fiR{$name."A"};
 396   my $cName = $$fiR{cName};
 397   my $num = $#{$aR} + 1;
 398   my $array_name_key = $name."ACName";
 399   if ($num == 0) {
 400     $$fiR{$array_name_key} = "NULL";
 401     return;
 402   }
 403   my $cR = $$fiR{C};
 404   my $array_name = "afm_" . $cName . "_" . $name;
 405   $$fiR{$array_name_key} = $array_name;
 406   $$cR .= "static $type $array_name" . "[] = { /* $num */\n";
 407   my $line = $indent1;
 408   for (my $i = 0; $i < $num; $i++) {
 409     $line .= "," if $i > 0;
 410     if (length($line) > 65) {
 411       $line .= "\n";
 412       $$cR .= $line;
 413       $line = $indent1;
 414     }
 415     $line .= $$aR[$i];
 416   }
 417   $line .= "\n";
 418   $$cR .= $line;
 419   $$cR .= "};\n";
 420 }
 421
 422 sub normalize_width
 423 {
 424   my ($w, $signed) = @_;
 425   my $n = int(($w + 3) / 6);
 426   if ($signed) {
 427     $n = -128 if $n < -128;
 428     $n =  127 if $n >  127;
 429     $n =  256 + $n if $n < 0; # make unsigned.
 430   } else {
 431     $n =    0 if $n <    0;
 432     $n =  255 if $n >  255;
 433   }
 434   return $n;
 435 }
 436
 437 sub main
 438 {
 439   my $cfn = "../../src/rrd_afm_data.c";
 440   read_glyphlist();
 441   process_all_fonts();
 442   my @fonts = sort keys %font_code;
 443   unless ($#fonts >= 0) {
 444     die "You must have at least 1 font.\n";
 445   }
 446   open(CFILE, ">$cfn") || die "Can't create $cfn\n";
 447   print CFILE header($cfn);
 448   print CFILE ${$font_code{$_}}{TABLES} foreach @fonts;
 449   print CFILE "const afm_fontinfo afm_fontinfolist[] = {\n";
 450   print CFILE ${$font_code{$_}}{INFO} foreach @fonts;
 451   print CFILE $indent1 . "{ 0, 0, 0 }\n";
 452   print CFILE $indent0 . "};\n";
 453   print CFILE $indent0 . "const int afm_fontinfo_count = ",
 454     ($#fonts + 1), ";\n";
 455   close(CFILE);
 456   print STDERR "Compiled ", ($#fonts+1), " fonts.\n";
 457 }
 458
 459 sub header
 460 {
 461   my ($fn) = @_;
 462   $fn =~ s/.*\///;
 463   my $h = $fn;
 464   $h =~ s/\.c$/.h/;
 465   return <<"END";
 466 /****************************************************************************
 467  * RRDtool 1.1.x  Copyright Tobias Oetiker, 1997 - 2002
 468  ****************************************************************************
 469  * $fn  Encoded afm (Adobe Font Metrics) for selected fonts.
 470  ****************************************************************************
 471  *
 472  * THIS FILE IS AUTOGENERATED BY PERL. DO NOT EDIT.
 473  *
 474  ****************************************************************************/
 475
 476 #include "$h"
 477 #include <stdlib.h>
 478
 479 END
 480 }
 481
 482 main();