source: git/lib/afm2txf.pl @ fb5791d

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

lib/afm2txf.pl: Add GPL script for creating txf files.

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

  • Property mode set to 100755
File size: 8.4 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 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#
17# This program is free software; you can redistribute it and/or modify
18# it under the terms of the GNU General Public License version 2 as
19# published by the Free Software Foundation.
20
21use strict;
22
23my $METRICS = shift or die; # AFM file
24
25# Texture size
26my $TEXSIZ = 256;
27
28# Padding around each character, for mipmap separation
29my $PADDING = 4;
30
31# Antialiasing multiplier.  Should be 16 for production work.  As low
32# as 4 works well for testing.
33my $DOWNSAMPLE = 16;
34
35# The 94 printable ASCII characters (and the space) and their
36# postscript glyph names.  We use names because not all postscript
37# fonts are encoded using ASCII.  AFM metrics generated by ttf2afm, in
38# fact, don't have any numerical character IDs at all.  In principle,
39# this mechanism will work for any 8 bit font encoding, you just have
40# to do the legwork of figuring out the name to ID mapping.
41my %CHARS = ('space'=>32, 'exclam'=>33, 'quotedbl'=>34,
42             'numbersign'=>35, 'dollar'=>36, 'percent'=>37,
43             'ampersand'=>38, 'quotesingle'=>39, 'parenleft'=>40,
44             'parenright'=>41, 'asterisk'=>42, 'plus'=>43,
45             'comma'=>44, 'hyphen'=>45, 'period'=>46, 'slash'=>47,
46             'zero'=>48, 'one'=>49, 'two'=>50, 'three'=>51,
47             'four'=>52, 'five'=>53, 'six'=>54, 'seven'=>55,
48             'eight'=>56, 'nine'=>57, 'colon'=>58, 'semicolon'=>59,
49             'less'=>60, 'equal'=>61, 'greater'=>62, 'question'=>63,
50             'at'=>64, 'A'=>65, 'B'=>66, 'C'=>67, 'D'=>68, 'E'=>69,
51             'F'=>70, 'G'=>71, 'H'=>72, 'I'=>73, 'J'=>74, 'K'=>75,
52             'L'=>76, 'M'=>77, 'N'=>78, 'O'=>79, 'P'=>80, 'Q'=>81,
53             'R'=>82, 'S'=>83, 'T'=>84, 'U'=>85, 'V'=>86, 'W'=>87,
54             'X'=>88, 'Y'=>89, 'Z'=>90, 'bracketleft'=>91,
55             'backslash'=>92, 'bracketright'=>93, 'asciicircum'=>94,
56             'underscore'=>95, 'grave'=>96, 'a'=>97, 'b'=>98, 'c'=>99,
57             'd'=>100, 'e'=>101, 'f'=>102, 'g'=>103, 'h'=>104,
58             'i'=>105, 'j'=>106, 'k'=>107, 'l'=>108, 'm'=>109,
59             'n'=>110, 'o'=>111, 'p'=>112, 'q'=>113, 'r'=>114,
60             's'=>115, 't'=>116, 'u'=>117, 'v'=>118, 'w'=>119,
61             'x'=>120, 'y'=>121, 'z'=>122, 'braceleft'=>123,
62             'bar'=>124, 'braceright'=>125, 'asciitilde'=>126);
63
64my %metrics = ();
65my %positions = ();
66
67#
68# Parse the font metrics.  This is a 5 element array.  All numbers are
69# expressed as a fraction of the line spacing.
70# 0:    nominal width (distance to the next character)
71# 1, 2: Coordinates of the lower left corner of the bounding box,
72#       relative to the nominal position.
73# 3, 4: Size of the bounding box
74#
75print STDERR "Reading font metrics...\n";
76my $FONT;
77my @lines = `cat $METRICS`
78    or die "Couldn't read metrics";
79foreach my $m (grep {/^(C|FontName) /} @lines) {
80    chomp $m;
81    if($m =~ /^FontName ([^\s]*)/) { $FONT = $1; next; }
82
83    die "No name: $m" if $m !~ /N\s+([^\s]+)\s+;/;
84    my $name = $1;
85
86    die "No box: $m"
87        if $m !~ /B\s+([-0-9]+)\s+([-0-9]+)\s+([-0-9]+)\s+([-0-9]+)\s+;/;
88    my ($left, $bottom, $right, $top) = ($1/1000, $2/1000, $3/1000, $4/1000);
89
90    die "No width: $m" if $m !~ /WX\s+([-0-9]+)/;
91    my $nomwid = $1/1000; # nominal, not physical width!
92
93    # The coordinates of the corner relative to the character
94    # "position"
95    my ($x, $y) = (-$left, -$bottom);
96    my ($w, $h) = ($right-$left, $top-$bottom);
97   
98    $metrics{$name} = [$nomwid, $x, $y, $w, $h];
99}
100
101die "No FontName found in metrics" if not defined $FONT;
102
103#
104# Find the height of the tallest character, and print some warnings
105#
106my $maxhgt = 0;
107foreach my $c (keys %CHARS) {
108    if(!defined $metrics{$c}) {
109        print STDERR "% WARNING: no metrics for char $c.  Skipping.\n";
110        next;
111    }
112    if($metrics{$c}->[4] > $maxhgt) { $maxhgt = $metrics{$c}->[4]; }
113}
114if($maxhgt == 0) {
115    print STDERR "No usable characters found.  Bailing out.\n";
116    exit 1;
117}
118
119#
120# Do the layout.  Keep increasing the row count until the characters
121# just fit.  This isn't terribly elegant, but it's simple.
122#
123print STDERR "Laying out";
124my $rows = 1;
125my $PS;
126my $LINEHGT;
127while(!defined ($PS = genPostscript($rows))) { $rows++; }
128print STDERR " ($rows rows)\n";
129
130#
131# Call ghostscript to render
132#
133print STDERR "Rendering Postscript...\n";
134my $res = $TEXSIZ * $DOWNSAMPLE;
135my $pid = open PS, "|gs -r$res -g${res}x${res} -sDEVICE=ppm -sOutputFile=$FONT.ppm > /dev/null";
136die "Couldn't spawn ghostscript interpreter" if !defined $pid;
137print PS join("\n", @$PS), "\n";
138close PS;
139waitpid($pid, 0);
140
141#
142# Downsample with ImageMagick
143#
144print STDERR "Antialiasing image...\n";
145system("mogrify -geometry ${TEXSIZ}x${TEXSIZ} $FONT.ppm") == 0
146    or die "Couldn't rescale $FONT.ppm";
147
148#
149# Generate the .txf file
150#
151print STDERR "Generating textured font file...\n";
152
153# Prune undefined glyphs
154foreach my $c (keys %metrics) {
155    delete $metrics{$c} if !defined $CHARS{$c};
156}
157
158sub round { sprintf "%.0f", $_[0] }
159open TXF, ">$FONT.txf" or die;
160print TXF pack "V", 0x667874ff;
161print TXF pack "V", 0x12345678;
162print TXF pack "V", 0;
163print TXF pack "V", $TEXSIZ;
164print TXF pack "V", $TEXSIZ;
165print TXF pack "V", round($TEXSIZ * $LINEHGT);
166print TXF pack "V", 0;
167print TXF pack "V", scalar(keys(%metrics));
168my @chars = sort { $CHARS{$a} <=> $CHARS{$b} } (keys %metrics);
169foreach my $c (@chars) {
170    my $m = $metrics{$c};
171    my $p = $positions{$c};
172    my $step = round($m->[0] * $LINEHGT * $TEXSIZ);
173
174    # Pad the bounding box, to handle areas that outside.  This can
175    # happen due to thick lines in the font path, or be an artifact of
176    # the downsampling.
177    my $w = round($m->[3] * $LINEHGT * $TEXSIZ + 2*$PADDING);
178    my $h = round($m->[4] * $LINEHGT * $TEXSIZ + 2*$PADDING);
179    my $xoff = -round($m->[1] * $LINEHGT * $TEXSIZ - $PADDING);
180    my $yoff = -round($m->[2] * $LINEHGT * $TEXSIZ - $PADDING);
181    my $x = round($p->[0] * $TEXSIZ - $PADDING);
182    my $y = round($p->[1] * $TEXSIZ - $PADDING);
183
184    print TXF pack "v", $CHARS{$c};
185    print TXF pack "C", $w;
186    print TXF pack "C", $h;
187    print TXF pack "c", $xoff;
188    print TXF pack "c", $yoff;
189    print TXF pack "C", $step;
190    print TXF pack "C", 0;
191    print TXF pack "v", $x;
192    print TXF pack "v", $y;
193}
194
195# Read in the .ppm file, dump the duplicate color values (ghostscript
196# won't generate pgm's) and write to the end of the .txf.  Remember to
197# swap the order of the rows; OpenGL textures are bottom-up.
198open PPM, "$FONT.ppm" or die;
199seek PPM, -3*$TEXSIZ*$TEXSIZ, 2 or die;
200my @rows = ();
201my $pixel;
202for(my $r=0; $r<$TEXSIZ; $r++) {
203    my @row = ();
204    for(my $c=0; $c<$TEXSIZ; $c++) {
205        read PPM, $pixel, 3 or die;
206        push @row, substr($pixel, 0, 1);
207    }
208    push @rows, \@row;
209}
210close PPM;
211for(my $r=(@rows - 1); $r>=0; $r--) {
212    print TXF join('', @{$rows[$r]});
213}
214close TXF;
215
216# Clean up
217#system("rm $FONT.ppm");
218
219########################################################################
220########################################################################
221########################################################################
222
223sub genPostscript {
224    my $rows = shift;
225    my $rowhgt = 1/$rows;
226
227    my @PS = ();
228   
229    # The canonical "point size" number, in texture space
230    $LINEHGT = ($rowhgt - 2*$PADDING/$TEXSIZ) / $maxhgt;
231
232    # Get to where we want.  Draw the whole thing in a 1 inch square at
233    # the bottom left of the "page".
234    push @PS, "72 72 scale";
235   
236    # Fill the square with black
237    push @PS, "0 setgray";
238    push @PS, "-1 -1 moveto";
239    push @PS, "-1 1 lineto 1 1 lineto 1 -1 lineto";
240    push @PS, "closepath";
241    push @PS, "fill";
242
243    # Draw in white
244    push @PS, "1 setgray";
245   
246    # Generate our PUSH @PS, font
247    push @PS, "/$FONT findfont $LINEHGT scalefont setfont";
248   
249    my $x = $PADDING/$TEXSIZ;
250    my $y = 1 - $rowhgt + $PADDING/$TEXSIZ;
251    my @chars = sort { $CHARS{$a} <=> $CHARS{$b} } (keys %CHARS);
252    foreach my $c (@chars) {
253        my $m = $metrics{$c};
254        next if !defined $m;
255
256        my $id = sprintf "%2.2x", $CHARS{$c};
257       
258        # No space?
259        my $w = $m->[3]*$LINEHGT;
260        if($x + $w + $PADDING/$TEXSIZ > 1) {
261            $x = $PADDING/$TEXSIZ;
262            $y -= $rowhgt;
263            return undef if $y < 0;
264        }
265
266        # Record where in the texture the box ended up
267        $positions{$c} = [$x, $y];
268
269        my $vx = $x + $m->[1]*$LINEHGT;
270        my $vy = $y + $m->[2]*$LINEHGT;
271       
272        push @PS, "$vx $vy moveto";
273        push @PS, "<$id> show";
274       
275        # Next box...
276        $x += $w + 2*$PADDING/$TEXSIZ;
277    }
278   
279    push @PS, "showpage";
280
281    return \@PS;
282}
283
Note: See TracBrowser for help on using the repository browser.