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.