summaryrefslogtreecommitdiff
path: root/fonts/utilities/t1tools/t1tidy/afm.pas
diff options
context:
space:
mode:
Diffstat (limited to 'fonts/utilities/t1tools/t1tidy/afm.pas')
-rw-r--r--fonts/utilities/t1tools/t1tidy/afm.pas361
1 files changed, 361 insertions, 0 deletions
diff --git a/fonts/utilities/t1tools/t1tidy/afm.pas b/fonts/utilities/t1tools/t1tidy/afm.pas
new file mode 100644
index 0000000000..676deeaafe
--- /dev/null
+++ b/fonts/utilities/t1tools/t1tidy/afm.pas
@@ -0,0 +1,361 @@
+unit afm;
+
+
+interface
+
+procedure openafm (var afmin, afmout: text);
+procedure closeafm (var afmin, afmout: text);
+
+procedure getafmchar (var C, WX: integer; name: string; var lx, ly, rx, ry: integer);
+procedure putafmchar (C, WX: integer; pname: string; lx, ly, rx, ry: integer);
+
+procedure opencc (var ccin: text);
+procedure composeCCs;
+
+
+implementation
+
+uses strtype, data, pathunit;
+
+function makeint (s: string): integer;
+var i, c: integer;
+begin
+ val (s, i, c);
+ makeint := i
+end;
+
+function intstr (i: integer): string;
+var s: string;
+begin
+ str (i, s);
+ intstr := s
+end;
+
+var line: strec;
+
+procedure readline (var f: text);
+(* accept DOS, Unix, and Mac line-ends *)
+var s: string;
+ c: char;
+begin
+ c := ' ';
+ s := '';
+ while not eoln (f) and (c <> #$0A) do begin
+ read (f, c);
+ if c <> #$0A then s := s + c
+ end;
+ if eoln (f) then readln (f);
+ line.ini (s)
+end;
+
+type ligpoi = ^ ligature;
+ ligature = record
+ second, ligname: string [30];
+ nextlig: ligpoi
+ end;
+ charmetrics = record
+ C: integer;
+ WX: integer;
+ N: string [30];
+ lx, ly, rx, ry: integer;
+ lig: ligpoi;
+ end;
+ charmetricspoi = ^ charmetrics;
+ composespec = record
+ name, name1, name2: string [30];
+ x1, y1, x2, y2: integer;
+ end;
+ composespecpoi = ^ composespec;
+
+const maxmetricsentry = 600;
+ maxcomposeentry = 300;
+var charentries: array [0..maxmetricsentry] of charmetricspoi;
+ (* 0..255 are encoded entries, those above are unencoded *)
+ composeentries: array [1..maxcomposeentry] of composespecpoi;
+ unencodedindex: integer;
+ afmopen: Boolean;
+ entrycount, composecount: integer;
+ CapHeight, XHeight, Ascender, Descender: Boolean;
+ afmintermediate: text;
+
+procedure parseCC (line: strec; fromafm: Boolean);
+(* parse a line like CC Aacute 2 ; PCC A 0 0 ; PCC acute 183 227 ; *)
+var composeentry: composespec;
+begin
+ with composeentry do begin
+ name := line.nexttoken;
+ if line.nexttoken <> '2' then begin
+ if fromafm (* or afmopen ? But then include StartComposites etc. *)
+ then writeln (afmintermediate, line.str);
+ end else begin
+ if fromafm (* or afmopen ? *)
+ then writeln (afmintermediate, line.str);
+ (* or re-generate entries? *)
+ line.gotonexttoken; line.gotonexttoken;
+ name1 := line.nexttoken;
+ x1 := makeint (line.nexttoken);
+ y1 := makeint (line.nexttoken);
+ line.gotonexttoken; line.gotonexttoken;
+ name2 := line.nexttoken;
+ x2 := makeint (line.nexttoken);
+ y2 := makeint (line.nexttoken);
+ composecount := composecount + 1;
+ new (composeentries [composecount]);
+ composeentries [composecount] ^ := composeentry;
+ end
+ end
+end;
+
+procedure openafm (var afmin, afmout: text);
+var charentry: charmetrics;
+ newmetric: charmetricspoi;
+ afmcmd: string;
+ FontBBoxlx, FontBBoxly, FontBBoxrx, FontBBoxry: integer;
+ i: integer;
+
+ function getligature: ligpoi;
+ var newlig: ligpoi;
+ begin
+ line.gotonexttoken;
+ if line.nexttoken = 'L' then begin
+ new (newlig);
+ newlig ^. second := line.nexttoken;
+ newlig ^. ligname := line.nexttoken;
+ newlig ^. nextlig := getligature;
+ getligature := newlig
+ end
+ else getligature := nil
+ end;
+
+begin
+ afmopen := true;
+ rewrite (afmout);
+ (* set defaults: *)
+ FontBBoxlx := 0;
+ FontBBoxly := 0;
+ FontBBoxrx := 0;
+ FontBBoxry := 0;
+ CapHeight := false;
+ XHeight := false;
+ Ascender := false;
+ Descender := false;
+ for i := 0 to maxmetricsentry do charentries [i] := nil;
+ unencodedindex := 255;
+
+ readline (afmin); afmcmd := line.firsttoken;
+ while afmcmd <> 'StartCharMetrics' do begin
+ writeln (afmout, line.str);
+ if afmcmd = 'FontBBox' then begin
+ FontBBoxlx := makeint (line.nexttoken);
+ FontBBoxly := makeint (line.nexttoken);
+ FontBBoxrx := makeint (line.nexttoken);
+ FontBBoxry := makeint (line.nexttoken);
+ end
+ else if afmcmd = 'CapHeight' then CapHeight := true
+ else if afmcmd = 'XHeight' then XHeight := true
+ else if afmcmd = 'Ascender' then Ascender := true
+ else if afmcmd = 'Descender' then Descender := true
+ ;
+ readline (afmin); afmcmd := line.firsttoken
+ end;
+ readline (afmin);
+ while line.nexttoken = 'C' do with charentry do begin
+ C := makeint (line.nexttoken);
+ line.gotonexttoken; line.gotonexttoken;
+ WX := makeint (line.nexttoken);
+ line.gotonexttoken; line.gotonexttoken;
+ N := line.nexttoken;
+ if N <> ';' (* name may be missing, e.g. with wfnboss's files *)
+ then begin
+ if stdenc then C := getSEcode ('/' + N);
+ entrycount := entrycount + 1;
+ line.gotonexttoken;
+ if line.nexttoken = 'B' then begin
+ lx := makeint (line.nexttoken);
+ ly := makeint (line.nexttoken);
+ rx := makeint (line.nexttoken);
+ ry := makeint (line.nexttoken);
+ end else begin
+ lx := FontBBoxlx;
+ ly := FontBBoxly;
+ rx := FontBBoxrx;
+ ry := FontBBoxry;
+ end;
+ lig := getligature;
+ if C = 0 then C := -1 (* makepfm doesn't like 0 *);
+ new (newmetric);
+ newmetric^ := charentry;
+ if C >= 0 then charentries [C] := newmetric
+ else begin
+ unencodedindex := unencodedindex + 1;
+ charentries [unencodedindex] := newmetric;
+ end;
+ end;
+ readline (afmin);
+ end;
+ makefilebuffer (afmintermediate, 'afminter.med');
+ repeat
+ writeln (afmintermediate, line.str);
+ if not eof (afmin) then readline (afmin);
+ until eof (afmin) or (line.firsttoken = 'CC');
+ if not eof (afmin) then
+ while line.firsttoken = 'CC' do begin
+ parseCC (line, true);
+ readline (afmin);
+ end;
+end;
+
+procedure opencc (var ccin: text);
+var s: string;
+ ccline: strec;
+begin
+ while not eof (ccin) do begin
+ readln (ccin, s);
+ ccline.ini (s);
+ if ccline.firsttoken = 'CC' then parseCC (ccline, false);
+ end
+end;
+
+procedure closeafm (var afmin, afmout: text);
+var c: char;
+ i: integer;
+
+ procedure writelig (lp: ligpoi);
+ begin
+ if lp <> nil then begin
+ write (afmout, ' L ', lp^.second, ' ', lp^.ligname, ' ;');
+ writelig (lp^.nextlig)
+ end
+ end;
+
+begin
+ if not CapHeight then if charentries [ord ('H')] <> nil then
+ writeln (afmout, 'CapHeight ', charentries [ord ('H')]^.ry);
+ if not XHeight then if charentries [ord ('x')] <> nil then
+ writeln (afmout, 'XHeight ', charentries [ord ('x')]^.ry);
+ if not Ascender then if charentries [ord ('d')] <> nil then
+ writeln (afmout, 'Ascender ', charentries [ord ('d')]^.ry);
+ if not Descender then if charentries [ord ('p')] <> nil then
+ writeln (afmout, 'Descender ', charentries [ord ('p')]^.ly);
+ writeln (afmout, 'StartCharMetrics ', entrycount);
+ for i := 0 to maxmetricsentry do if charentries [i] <> nil then
+ with charentries [i]^ do begin
+ write (afmout, 'C ', C, ' ; WX ', WX, ' ; N ', N,
+ ' ; B ', lx, ' ', ly, ' ', rx, ' ', ry, ' ;');
+ writelig (lig);
+ if (N = 'f') and (lig = nil) then begin
+ if getCharString ('/fi') <> nil then write (afmout, ' L i fi ;');
+ if getCharString ('/fl') <> nil then write (afmout, ' L l fl ;');
+ end;
+ writeln (afmout)
+ end;
+ getfilebuffer (afmintermediate, afmout);
+ writeln (afmout, line.str);
+ while not eof (afmin) do begin
+ read (afmin, c);
+ write (afmout, c);
+ end;
+ close (afmin);
+ close (afmout);
+end;
+
+function purename (s: string): string;
+begin
+ if pos ('/', s) = 1 then purename := copy (s, 2, length (s) - 1)
+ else purename := s
+end;
+
+procedure composeCCs;
+var i: integer;
+ cc1, cc2: integer;
+ CS1, CS2: CharStrpointer;
+ pname, pname1, pname2: string [30];
+begin
+ for i := 1 to composecount do with composeentries [i] ^ do begin
+ pname := '/' + name;
+ pname1 := '/' + name1;
+ pname2 := '/' + name2;
+ if getCharString (pname) = nil then
+ if (x1 = 0) and (y1 = 0) then begin
+ cc1 := getSEcode (pname1);
+ cc2 := getSEcode (pname2);
+ CS1 := getCharString (pname1);
+ CS2 := getCharString (pname2);
+ if (cc1 >= 0) and (cc2 >= 0)
+ and (CS1 <> nil) and (CS2 <> nil) then begin
+ CharStringscount := CharStringscount + 1;
+ new (CharStrings [CharStringscount], ini);
+ CharStrings [CharStringscount] ^ . setname (pname);
+ CharStrings [CharStringscount] ^ . compose
+ (CS1, CS2, cc1, cc2, x2, y2)
+ end
+ end
+ else writeln ('% cannot compose with first char offset')
+ end
+end;
+
+procedure getafmchar (var C, WX: integer; name: string; var lx, ly, rx, ry: integer);
+var i: integer;
+ N: string;
+begin
+ N := purename (name);
+ C := -2; (* error indication if not found *)
+ WX := 0;
+ lx := 0; ly := 0; rx := 0; ry := 0;
+ if afmopen then begin
+ for i := 0 to maxmetricsentry do if charentries [i] <> nil then
+ if charentries [i]^.N = N then begin
+ C := charentries [i]^.C;
+ WX := charentries [i]^.WX;
+ lx := charentries [i]^.lx;
+ ly := charentries [i]^.ly;
+ rx := charentries [i]^.rx;
+ ry := charentries [i]^.ry;
+ end
+ end
+end;
+
+procedure putafmchar (C, WX: integer; pname: string; lx, ly, rx, ry: integer);
+var index: integer;
+ name: string [30];
+ found: Boolean;
+begin
+ name := purename (pname);
+ if afmopen then begin
+ if C >= 0 then
+ if charentries [C] = nil then index := C
+ else if charentries [C]^.N = name then index := C
+ else C := -1;
+ if C < 0 then begin
+ index := 255; (* last encoded index *)
+ found := false;
+ repeat index := index + 1;
+ if index > unencodedindex then begin
+ found := true;
+ unencodedindex := index;
+ end else if charentries [index] <> nil
+ then if charentries [index]^.N = name
+ then found := true
+ until found
+ end;
+ if charentries [index] = nil then begin
+ entrycount := entrycount + 1;
+ new (charentries [index]);
+ charentries [index]^.N := name;
+ charentries [index]^.lig := nil;
+ end;
+ charentries [index]^.C := C;
+ charentries [index]^.WX := WX;
+ charentries [index]^.lx := lx;
+ charentries [index]^.ly := ly;
+ charentries [index]^.rx := rx;
+ charentries [index]^.ry := ry;
+ end
+end;
+
+begin
+ afmopen := false;
+ ccopen := false;
+ entrycount := 0;
+ composecount := 0;
+end.