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