source: git/lib/afm2txf.pl @ 5311876

RELEASE/1.2debug-cidebug-ci-sanitisersstereowalls-data
Last change on this file since 5311876 was 72f37d2, checked in by Olly Betts <olly@…>, 14 years ago

lib/afm2txf.pl: Add support for -o option to specify output .txf
file.

git-svn-id: file:///home/survex-svn/survex/branches/survex-1_1@3412 4b37db11-9a0c-4f06-9ece-9ab7cdaee568

  • Property mode set to 100755
File size: 10.5 KB
Line 
1#!/usr/bin/perl -w
2
3# afm2txf.pl 0.2
4#
5# Generates .txf font textures from Type 1 fonts
6# Requirements: Ghostscript, ImageMagick
7#
8# Usage:
9#       afm2txf.pl [-o OUTPUT.txf] whatever.afm
10#
11# Changelog:
12#       0.2 (06/28/2002): Generate fonts with proper padding
13#       0.1 (06/28/2002): Initial version
14#
15# Copyright (C) 2002 Andrew James Ross
16# Copyright (C) 2010 Olly Betts
17#
18# This program is free software; you can redistribute it and/or modify
19# it under the terms of the GNU General Public License version 2 as
20# published by the Free Software Foundation.
21
22use strict;
23
24my $output;
25if (scalar @ARGV >= 1) {
26    my $arg = $ARGV[0];
27    if ($arg =~ s/^-o//) {
28        shift;
29        if ($arg eq '') {
30            if (scalar @ARGV == 0) {
31                die "-o needs an argument\n";
32            }
33            $output = shift;
34        } else {
35            $output = $arg;
36        }
37    }
38}
39
40my $METRICS = shift or die; # AFM file
41
42# Texture size
43my $TEXSIZ = 256;
44
45# Padding around each character, for mipmap separation
46my $PADDING = 4;
47
48# Antialiasing multiplier.  Should be 16 for production work.  As low
49# as 4 works well for testing.
50my $DOWNSAMPLE = 16;
51
52# The printable ISO-8859-1 characters (and space and hard space) and their
53# postscript glyph names.  We use names because not all postscript
54# fonts are encoded using ASCII.  AFM metrics generated by ttf2afm, in
55# fact, don't have any numerical character IDs at all.  In principle,
56# this mechanism will work for any 8 bit font encoding, you just have
57# to do the legwork of figuring out the name to ID mapping.
58my %CHARS = ('space'=>32, 'exclam'=>33, 'quotedbl'=>34,
59             'numbersign'=>35, 'dollar'=>36, 'percent'=>37,
60             'ampersand'=>38, 'quotesingle'=>39, 'parenleft'=>40,
61             'parenright'=>41, 'asterisk'=>42, 'plus'=>43,
62             'comma'=>44, 'hyphen'=>45, 'period'=>46, 'slash'=>47,
63             'zero'=>48, 'one'=>49, 'two'=>50, 'three'=>51,
64             'four'=>52, 'five'=>53, 'six'=>54, 'seven'=>55,
65             'eight'=>56, 'nine'=>57, 'colon'=>58, 'semicolon'=>59,
66             'less'=>60, 'equal'=>61, 'greater'=>62, 'question'=>63,
67             'at'=>64, 'A'=>65, 'B'=>66, 'C'=>67, 'D'=>68, 'E'=>69,
68             'F'=>70, 'G'=>71, 'H'=>72, 'I'=>73, 'J'=>74, 'K'=>75,
69             'L'=>76, 'M'=>77, 'N'=>78, 'O'=>79, 'P'=>80, 'Q'=>81,
70             'R'=>82, 'S'=>83, 'T'=>84, 'U'=>85, 'V'=>86, 'W'=>87,
71             'X'=>88, 'Y'=>89, 'Z'=>90, 'bracketleft'=>91,
72             'backslash'=>92, 'bracketright'=>93, 'asciicircum'=>94,
73             'underscore'=>95, 'quoteleft'=>96, 'a'=>97, 'b'=>98, 'c'=>99,
74             'd'=>100, 'e'=>101, 'f'=>102, 'g'=>103, 'h'=>104,
75             'i'=>105, 'j'=>106, 'k'=>107, 'l'=>108, 'm'=>109,
76             'n'=>110, 'o'=>111, 'p'=>112, 'q'=>113, 'r'=>114,
77             's'=>115, 't'=>116, 'u'=>117, 'v'=>118, 'w'=>119,
78             'x'=>120, 'y'=>121, 'z'=>122, 'braceleft'=>123,
79             'bar'=>124, 'braceright'=>125, 'asciitilde'=>126,
80             'space'=>160, 'exclamdown'=>161, 'cent'=>162, 'sterling'=>163,
81             'currency'=>164, 'yen'=>165, 'brokenbar'=>166, 'section'=>167,
82             'dieresis'=>168, 'copyright'=>169, 'ordfeminine'=>170, 'guillemotleft'=>171,
83             'logicalnot'=>172, 'hyphen'=>173, 'registered'=>174, 'macron'=>175,
84             'degree'=>176, 'plusminus'=>177, 'twosuperior'=>178, 'threesuperior'=>179,
85             'acute'=>180, 'mu'=>181, 'paragraph'=>182, 'bullet'=>183,
86             'cedilla'=>184, 'onesuperior'=>185, 'ordmasculine'=>186, 'guillemotright'=>187,
87             'onequarter'=>188, 'onehalf'=>189, 'threequarters'=>190, 'questiondown'=>191,
88             'Agrave'=>192, 'Aacute'=>193, 'Acircumflex'=>194, 'Atilde'=>195,
89             'Adieresis'=>196, 'Aring'=>197, 'AE'=>198, 'Ccedilla'=>199,
90             'Egrave'=>200, 'Eacute'=>201, 'Ecircumflex'=>202, 'Edieresis'=>203,
91             'Igrave'=>204, 'Iacute'=>205, 'Icircumflex'=>206, 'Idieresis'=>207,
92             'Eth'=>208, 'Ntilde'=>209, 'Ograve'=>210, 'Oacute'=>211,
93             'Ocircumflex'=>212, 'Otilde'=>213, 'Odieresis'=>214, 'multiply'=>215,
94             'Oslash'=>216, 'Ugrave'=>217, 'Uacute'=>218, 'Ucircumflex'=>219,
95             'Udieresis'=>220, 'Yacute'=>221, 'Thorn'=>222, 'germandbls'=>223,
96             'agrave'=>224, 'aacute'=>225, 'acircumflex'=>226, 'atilde'=>227,
97             'adieresis'=>228, 'aring'=>229, 'ae'=>230, 'ccedilla'=>231,
98             'egrave'=>232, 'eacute'=>233, 'ecircumflex'=>234, 'edieresis'=>235,
99             'igrave'=>236, 'iacute'=>237, 'icircumflex'=>238, 'idieresis'=>239,
100             'eth'=>240, 'ntilde'=>241, 'ograve'=>242, 'oacute'=>243,
101             'ocircumflex'=>244, 'otilde'=>245, 'odieresis'=>246, 'divide'=>247,
102             'oslash'=>248, 'ugrave'=>249, 'uacute'=>250, 'ucircumflex'=>251,
103             'udieresis'=>252, 'yacute'=>253, 'thorn'=>254, 'ydieresis'=>255
104             );
105
106my %metrics = ();
107my %positions = ();
108
109#
110# Parse the font metrics.  This is a 5 element array.  All numbers are
111# expressed as a fraction of the line spacing.
112# 0:    nominal width (distance to the next character)
113# 1, 2: Coordinates of the lower left corner of the bounding box,
114#       relative to the nominal position.
115# 3, 4: Size of the bounding box
116#
117print STDERR "Reading font metrics...\n";
118my $FONT;
119my @lines = `cat $METRICS`
120    or die "Couldn't read metrics";
121foreach my $m (grep {/^(C|FontName) /} @lines) {
122    chomp $m;
123    if($m =~ /^FontName ([^\s]*)/) { $FONT = $1; next; }
124
125    die "No name: $m" if $m !~ /N\s+([^\s]+)\s+;/;
126    my $name = $1;
127
128    die "No box: $m"
129        if $m !~ /B\s+([-0-9]+)\s+([-0-9]+)\s+([-0-9]+)\s+([-0-9]+)\s+;/;
130    my ($left, $bottom, $right, $top) = ($1/1000, $2/1000, $3/1000, $4/1000);
131
132    die "No width: $m" if $m !~ /WX\s+([-0-9]+)/;
133    my $nomwid = $1/1000; # nominal, not physical width!
134
135    # The coordinates of the corner relative to the character
136    # "position"
137    my ($x, $y) = (-$left, -$bottom);
138    my ($w, $h) = ($right-$left, $top-$bottom);
139
140    $metrics{$name} = [$nomwid, $x, $y, $w, $h];
141}
142
143die "No FontName found in metrics" if not defined $FONT;
144
145# Sanitise $FONT.
146$FONT =~ s!/!_!g;
147
148#
149# Find the height of the tallest character, and print some warnings
150#
151my $maxhgt = 0;
152foreach my $c (keys %CHARS) {
153    if(!defined $metrics{$c}) {
154        print STDERR "% WARNING: no metrics for char $c.  Skipping.\n";
155        next;
156    }
157    if($metrics{$c}->[4] > $maxhgt) { $maxhgt = $metrics{$c}->[4]; }
158}
159if($maxhgt == 0) {
160    print STDERR "No usable characters found.  Bailing out.\n";
161    exit 1;
162}
163
164#
165# Do the layout.  Keep increasing the row count until the characters
166# just fit.  This isn't terribly elegant, but it's simple.
167#
168print STDERR "Laying out";
169my $rows = 1;
170my $PS;
171my $LINEHGT;
172while(!defined ($PS = genPostscript($rows))) { $rows++; }
173print STDERR " ($rows rows)\n";
174
175#
176# Call ghostscript to render
177#
178print STDERR "Rendering Postscript...\n";
179my $res = $TEXSIZ * $DOWNSAMPLE;
180my $pid = open PS, "|gs -r$res -g${res}x${res} -sDEVICE=ppm -sOutputFile=\Q$FONT\E.ppm > /dev/null";
181die "Couldn't spawn ghostscript interpreter" if !defined $pid;
182print PS join("\n", @$PS), "\n";
183close PS;
184waitpid($pid, 0);
185
186#
187# Downsample with ImageMagick
188#
189print STDERR "Antialiasing image...\n";
190system("mogrify -geometry ${TEXSIZ}x${TEXSIZ} \Q$FONT\E.ppm") == 0
191    or die "Couldn't rescale $FONT.ppm";
192
193#
194# Generate the .txf file
195#
196print STDERR "Generating textured font file...\n";
197
198# Prune undefined glyphs
199foreach my $c (keys %metrics) {
200    delete $metrics{$c} if !defined $CHARS{$c};
201}
202
203sub round { sprintf "%.0f", $_[0] }
204$output = "$FONT.txf" unless defined $output;
205open TXF, '>', $output or die;
206print TXF pack "V", 0x667874ff;
207print TXF pack "V", 0x12345678;
208print TXF pack "V", 0;
209print TXF pack "V", $TEXSIZ;
210print TXF pack "V", $TEXSIZ;
211print TXF pack "V", round($TEXSIZ * $LINEHGT);
212print TXF pack "V", 0;
213print TXF pack "V", scalar(keys(%metrics));
214my @chars = sort { $CHARS{$a} <=> $CHARS{$b} } (keys %metrics);
215foreach my $c (@chars) {
216    my $m = $metrics{$c};
217    my $p = $positions{$c};
218    my $step = round($m->[0] * $LINEHGT * $TEXSIZ);
219
220    # Pad the bounding box, to handle areas that outside.  This can
221    # happen due to thick lines in the font path, or be an artifact of
222    # the downsampling.
223    my $w = round($m->[3] * $LINEHGT * $TEXSIZ + 2*$PADDING);
224    my $h = round($m->[4] * $LINEHGT * $TEXSIZ + 2*$PADDING);
225    my $xoff = -round($m->[1] * $LINEHGT * $TEXSIZ) - $PADDING;
226    my $yoff = -round($m->[2] * $LINEHGT * $TEXSIZ) - $PADDING;
227    my $x = round($p->[0] * $TEXSIZ - $PADDING);
228    my $y = round($p->[1] * $TEXSIZ - $PADDING);
229
230    print TXF pack "v", $CHARS{$c};
231    print TXF pack "C", $w;
232    print TXF pack "C", $h;
233    print TXF pack "c", $xoff;
234    print TXF pack "c", $yoff;
235    print TXF pack "C", $step;
236    print TXF pack "C", 0;
237    print TXF pack "v", $x;
238    print TXF pack "v", $y;
239}
240
241# Read in the .ppm file, dump the duplicate color values (ghostscript
242# won't generate pgm's) and write to the end of the .txf.  Remember to
243# swap the order of the rows; OpenGL textures are bottom-up.
244open PPM, "$FONT.ppm" or die;
245seek PPM, -3*$TEXSIZ*$TEXSIZ, 2 or die;
246my @rows = ();
247my $pixel;
248for(my $r=0; $r<$TEXSIZ; $r++) {
249    my @row = ();
250    for(my $c=0; $c<$TEXSIZ; $c++) {
251        read PPM, $pixel, 3 or die;
252        push @row, substr($pixel, 0, 1);
253    }
254    push @rows, \@row;
255}
256close PPM;
257for(my $r=(@rows - 1); $r>=0; $r--) {
258    print TXF join('', @{$rows[$r]});
259}
260close TXF;
261
262# Clean up
263unlink("$FONT.ppm");
264
265########################################################################
266########################################################################
267########################################################################
268
269sub genPostscript {
270    my $rows = shift;
271    my $rowhgt = 1/$rows;
272
273    my @PS = ();
274
275    # The canonical "point size" number, in texture space
276    $LINEHGT = ($rowhgt - 2*$PADDING/$TEXSIZ) / $maxhgt;
277
278    # Get to where we want.  Draw the whole thing in a 1 inch square at
279    # the bottom left of the "page".
280    push @PS, "72 72 scale";
281
282    # Fill the square with black
283    push @PS, "0 setgray";
284    push @PS, "-1 -1 moveto";
285    push @PS, "-1 1 lineto 1 1 lineto 1 -1 lineto";
286    push @PS, "closepath";
287    push @PS, "fill";
288
289    # Draw in white
290    push @PS, "1 setgray";
291
292    # Generate our PUSH @PS, font
293    push @PS, "/$FONT findfont $LINEHGT scalefont setfont";
294
295    my $x = $PADDING/$TEXSIZ;
296    my $y = 1 - $rowhgt + $PADDING/$TEXSIZ;
297    my @chars = sort { $CHARS{$a} <=> $CHARS{$b} } (keys %CHARS);
298    foreach my $c (@chars) {
299        my $m = $metrics{$c};
300        next if !defined $m;
301
302        my $id = sprintf "%2.2x", $CHARS{$c};
303
304        # No space?
305        my $w = $m->[3]*$LINEHGT;
306        if($x + $w + $PADDING/$TEXSIZ > 1) {
307            $x = $PADDING/$TEXSIZ;
308            $y -= $rowhgt;
309            return undef if $y < 0;
310        }
311
312        # Record where in the texture the box ended up
313        $positions{$c} = [$x, $y];
314
315        my $vx = $x + $m->[1]*$LINEHGT;
316        my $vy = $y + $m->[2]*$LINEHGT;
317
318        push @PS, "$vx $vy moveto";
319        push @PS, "<$id> show";
320
321        # Next box...
322        $x += $w + 2*$PADDING/$TEXSIZ;
323    }
324
325    push @PS, "showpage";
326
327    return \@PS;
328}
Note: See TracBrowser for help on using the repository browser.