program T1tidy;

uses Dos, pathunit, strtype, afm, data;

function makeint (s: string): integer;
var i, c: integer;
begin
	val (s, i, c);
	makeint := i
end;

function hex (c: char): integer;
begin
	if c < '0' then hex := 0
	else if c <= '9' then hex := ord (c) - ord ('0')
	else if upcase (c) < 'A' then hex := 0
	else if upcase (c) <= 'F' then hex := ord (upcase (c)) - ord ('A') + 10
	else hex := 0
end;

function intstr (i: longint): string;
var s: string;
begin
	str (i, s);
	intstr := s
end;

function basename (fn: string): string;
begin
	if pos ('.', fn) > 0 then
		basename := copy (fn, 1, pos ('.', fn) - 1)
	else basename := fn
end;

function isdir (fn: string): Boolean;
var f: file;
    a: word;
begin
	assign (f, fn);
	GetFAttr (f, a);
	isdir := (a and $10) <> 0
end;

(* main procedure: *)

procedure tidy (var infile, out: text);

const	maxintermediatelines = 40;

var	line, Subrsline, CharStringsline: strec;
	intermediatelines: array [1..maxintermediatelines] of string;
	linesafterOtherSubrs, linesafterSubrs: integer;

	blanklines: integer;
	i: integer;

(***************************************************************************)

	function eofile: Boolean;
	begin    eofile := eof (infile) end;

	procedure readline;
	var s: string;
	begin
		readln (infile, s);
		line.ini (s)
	end;

	function nexttoken: string;
	var r: string;
	begin
		r := line.nexttoken;
		while r = '' do begin
			readline;
			r := line.nexttoken
		end;
		nexttoken := r
	end;

	procedure readSubr;
	var s: string;
	    index: integer;
	begin
		Subrscount := Subrscount + 1;
		new (Subrs [Subrscount], ini);
		with Subrs [Subrscount] ^ do begin
		     index := makeint (nexttoken);
		     (* writeln ('% reading Subr ', index); *)
		     setindex (index);
		     if nexttoken <> '{' then writeln ('% missing { in Subr');
		     s := nexttoken;
		     while s <> '}'	(* and ... Fehlerabfang! *)
		     do begin
			if s = '' then writeln ('% empty line detected in Subr');
			appendtoken (s);
			s := nexttoken;
		     end;
		     if s <> '}' then writeln ('% missing } in Subr');
		     s := nexttoken;
		     if s = 'noaccess' then s := s + ' ' + nexttoken;
		     setdef (s);
		     cleanup
		end
	end;

	procedure readCharString;
	var s: string;
	begin
	     CharStringscount := CharStringscount + 1;
	     new (CharStrings [CharStringscount], ini);
	     with CharStrings [CharStringscount] ^ do begin
		s := line.lasttoken;
		if ttfix then
		   if (s [2] = 'G') and (length (s) = 4) then begin
			i := hex (s [3]) * 16 + hex (s [4]);
			if WinANSI [i] <> '/.notdef' then s := WinANSI [i]
		end;
		setname (s);
		if nexttoken <> '{' then writeln ('% missing { in CharString');
		s := nexttoken;
		while s <> '}'	(* and ... Fehlerabfang! *)
		do begin
			appendtoken (s);
			s := nexttoken;
		end;
		if s <> '}' then writeln ('% missing } in CharString');
		s := nexttoken;
		if s = 'noaccess' then s := s + ' ' + nexttoken;
		if clearifempty
		then begin
			dispose (CharStrings [CharStringscount]);
			CharStringscount := CharStringscount - 1
		 end
		else begin
			setdef (s);
			cleanup;
			if not generate and split then splitpath
		end
	     end
	end;

	procedure fixchars;

	  procedure halfchar (oldname, newname: string);
	  var CSold, CSnew: CharStrpointer;
	  begin
	    CSold := getCharString (oldname);
	    CSnew := getCharString (newname);
	    if (CSnew = nil) and (CSold <> nil) then begin
		new (CSnew, ini);
		CSold^.copyhalf (CSnew^, newname);
		CharStringscount := CharStringscount + 1;
		CharStrings [CharStringscount] := CSnew;
	    end
	  end;

	  procedure downchar (oldname, newname: string);
	  var CSold, CSnew: CharStrpointer;
	  begin
	    CSold := getCharString (oldname);
	    CSnew := getCharString (newname);
	    if (CSnew = nil) and (CSold <> nil) then begin
		new (CSnew, ini);
		CSold^.downpath (CSnew^, newname);
		CharStringscount := CharStringscount + 1;
		CharStrings [CharStringscount] := CSnew;
	    end
	  end;

	  procedure copychar (oldname, newname: string);
	  var CSold, CSnew: CharStrpointer;
	  begin
	    CSold := getCharString (oldname);
	    CSnew := getCharString (newname);
	    if (CSnew = nil) and (CSold <> nil) then begin
		new (CSnew, ini);
		CSold^.copypath (CSnew^, newname);
		CharStringscount := CharStringscount + 1;
		CharStrings [CharStringscount] := CSnew;
	    end
	  end;

	var CSbullet, CSperiodcentered: CharStrpointer;
	begin
		if verbose then writeln ('% generating missing characters');
		if corelfix then begin
			CSbullet := getCharString ('/bullet');
			CSperiodcentered := getCharString ('/periodcentered');
			if (CSbullet <> nil) and (CSperiodcentered <> nil) then
			   swappaths (CSbullet^, CSperiodcentered^);
		end;
		halfchar ('/quotedbl', '/quotesingle');
		downchar ('/quotedblright', '/quotedblbase');
		halfchar ('/quotedblbase', '/quotesinglbase');
		halfchar ('/quotedblleft', '/quoteleft');
		halfchar ('/quotedblright', '/quoteright');
		downchar ('/quoteright', '/quotesinglbase');
		halfchar ('/guillemotleft', '/guilsinglleft');
		halfchar ('/guillemotright', '/guilsinglright');
		copychar ('/less', '/guilsinglleft');
		copychar ('/greater', '/guilsinglright');
		if getCharString ('/endash') <> nil
		then copychar ('/endash', '/minus')
		else copychar ('/hyphen', '/minus');
		copychar ('/slash', '/fraction');
		copychar ('/bar', '/brokenbar');
		copychar ('/asciitilde', '/tilde');
		copychar ('/asciicircum', '/circumflex');
		copychar ('/degree', '/ring');

		if afmopen or ccopen then begin
			if verbose then writeln ('% generating composed characters');
			composeCCs;
		end
	end;

var	uidfile: text; UniqueID, OtherSubrsfilepos: longint;
	OtherSubrs: text;
	savedOtherSubrs: Boolean;
	s: string;
	OtherSubrslevel: integer;
	OtherSubrsup, OtherSubrsdown: string;

begin	(* tidy *)
	Subrscount := 0;
	linesafterOtherSubrs := 0;
	savedOtherSubrs := false;
	linesafterSubrs := 0;
	CharStringscount := 0;
	UniqueID := 0;

	readline;
	(* i := line.posof ('FontType1-1.0');
	(* if i > 0 then line.replace (i, i + 12, 'PS-AdobeFont-1.0'); *)
	blanklines := 0;
	while not eofile and not line.findtoken ('/Subrs')
			 and not line.findtoken ('/OtherSubrs')
			 and not line.findtoken ('/CharStrings') do begin
	  if line.str <> '' then
	     if line.firsttoken = '' then blanklines := blanklines + 1
	     else begin
		if line.hasprefix ('/FontName') then
			writeln ('% FontName: ', line.nthtoken (2));
		if corelfix then begin
			(* The following modification, if desired at all, 
			   would have to be accompanied with metrics 
			   adjustment in the .afm file *)
		   (*	if line.hasprefix ('/FontMatrix') then begin
			    if line.findtoken ('0.001000')
				then line.replacelasttoken ('0.000950');
			    if line.findtoken ('0.001000')
				then line.replacelasttoken ('0.000950');
			end;
		   *)
			if line.hasprefix ('/UniqueID') then
			   if line.findtoken ('4221071') then begin
			      if UniqueID = 0 then begin
				assign (uidfile, 'UniqueID.int');
				(*$I-*) reset (uidfile) (*$I+*);
				if IOresult = 0 then read (uidfile, UniqueID)
				else UniqueID := 4221071;
				UniqueID := UniqueID + 1;
				rewrite (uidfile);
				write (uidfile, UniqueID);
				close (uidfile);
			      end;
			      line.replacelasttoken (intstr (UniqueID));
			   end
		end;
		if stdenc then begin
		   if line.findtoken ('/Encoding') then begin
			while not line.findtoken ('def') do begin
				stdenc := false;
				readline;
			end;
			line.ini ('/Encoding StandardEncoding def');
			if verbose and not stdenc then
			   writeln ('% replacing encoding vector with StandardEncoding')
		   end
		end;
		writeln (out, line.str);
	     end;
	     readline;
	end;
	if blanklines > 0 then begin
		writeln ('% ', blanklines, ' blank lines removed');
	end;
	if line.findtoken ('/OtherSubrs') then begin
		(* Borland unwisely prohibited filepos / seek on text files, 
		   so we must save the OtherSubrs part in an intermediate 
		   file to paste it in again if needed. *)
		if getenv ('TEMP') <> ''
		then	assign (OtherSubrs, getenv ('TEMP') + '\other.sub')
		else	assign (OtherSubrs, 'other.sub');
		rewrite (OtherSubrs);
		OtherSubrslevel := 1;
		OtherSubrsup := '';
		repeat	s := line.nexttoken;
			if s = '' then begin
				writeln (OtherSubrs, line.str);
				readline;
			end else if OtherSubrsup = '' then begin
				OtherSubrsup := s;
				if s = '[' then OtherSubrsdown := ']'
				else OtherSubrsdown := '}';
			end else if s = OtherSubrsup then
				OtherSubrslevel := OtherSubrslevel + 1
			else if s = OtherSubrsdown then
				OtherSubrslevel := OtherSubrslevel - 1;
		until OtherSubrslevel = 0;
		writeln (OtherSubrs, line.str);
		reset (OtherSubrs);
		savedOtherSubrs := true;

		readline;
		while not eofile and not line.findtoken ('/Subrs')
				 and not line.findtoken ('/CharStrings') do begin
			if not line.empty then begin
			   linesafterOtherSubrs := linesafterOtherSubrs + 1;
			   intermediatelines [linesafterOtherSubrs] := line.str;
			end;
			readline
		end;
	end;
	if line.findtoken ('/Subrs') then begin
		if verbose then writeln ('% reading Subrs');
		Subrsline := line;
		readline;
		while nexttoken = 'dup' do readSubr;
	end else
		writeln ('% /Subrs not found');

	linesafterSubrs := linesafterOtherSubrs;
	while not eofile and not line.findtoken ('/CharStrings') do begin
		if not line.empty then begin
		   linesafterSubrs := linesafterSubrs + 1;
		   intermediatelines [linesafterSubrs] := line.str;
		end;
		readline
	end;
	if line.findtoken ('/CharStrings') then begin
		if verbose then writeln ('% reading CharStrings');
		CharStringsline := line;
		readline;
		while pos ('/', nexttoken) = 1 do begin
			readCharString;
			(* readline; *)
		end;
	end else
		writeln ('% /CharStrings not found');

	i := 1;
	while noOtherSubrs and (i <= CharStringscount) do begin
		noOtherSubrs := not CharStrings [i]^.usesothersubrs;
		i := i + 1
	end;
	(* Borland unwisely prohibited filepos / seek on text files
		if noOtherSubrs then seek (out, OtherSubrsfilepos);
	*)
	if savedOtherSubrs then begin
		if noOtherSubrs
		then writeln ('% unused /OtherSubrs removed')
		else while not eof (OtherSubrs) do begin
			readln (OtherSubrs, s);
			writeln (out, s)
		end;
		close (OtherSubrs);
		erase (OtherSubrs);
	end;
	for i := 1 to linesafterOtherSubrs do
		writeln (out, intermediatelines [i]);

    if Subrscount > 0 then begin
    (* re-structure Subrs and CharStrings: *)
	(* if verbose then write ('% cleaning junk operations - '); *)
	(* for i := 1 to Subrscount do Subrs [i]^.cleanup; *)
	(* for i := 1 to CharStringscount do CharStrings [i]^.cleanup; *)
	if generate then begin
		if verbose then write ('% generating missing chars - ');
		fixchars;
	end;
	if generate and split then begin
	   if verbose then write ('% splitting paths - ');
	   for i := 1 to CharStringscount do CharStrings [i]^.splitpath; (**)
	end;
    (* sort and number subroutines, collect statistics *)
	sortMoreSubrs;
	if verbose then writeln ('% arranging new subpaths');
	arrangeMoreSubrs (Subrscount);

    (* output Subrs: *)
	if expand then begin
		Subrstotal := 4;
		Subrscount := 4 (* assume they sit on the first positions *)
	end;
	Subrsline.gotonexttoken;
	Subrsline.replacelasttoken (intstr (Subrstotal));
	writeln (out, Subrsline.str);
	begin	(* writeln (out, '% Subrs: -------'); *)
		if verbose then write ('% writing previous Subrs - ');
		for i := 1 to Subrscount do
			Subrs [i]^.print (out);
		if not expand then begin
			if verbose then writeln ('% writing new Subrs');
			printMoreSubrs (out)
		end
	end;

	for i := linesafterOtherSubrs + 1 to linesafterSubrs do
		writeln (out, intermediatelines [i]);
    end;

    if afmcheck and afmopen then begin
	if verbose then writeln ('% checking afm measure information');
	for i := 1 to CharStringscount do CharStrings [i]^.checkafm (false);
    end;

    if CharStringscount > 0 then begin
    (* output CharStrings: *)
	CharStringsline.gotonexttoken;
	CharStringsline.replacelasttoken (intstr (CharStringscount));
	writeln (out, CharStringsline.str);
	begin	(* writeln (out, '% CharStrings: -------'); *)
		if verbose then writeln ('% writing CharStrings');
		for i := 1 to CharStringscount do
			CharStrings [i]^.print (out)
	end;
    end;

	while not eofile do begin
		writeln (out, line.str);
		readline;
	end;
	write (out, line.str);
	writeln (out);
end;

var	infile, out, afmin, ccin, afmout: text;
	fontfile, fontname: string;
	paramindex, i: integer;
	option: string;
	optionvalue: Boolean;

	function isoption: Boolean;
	begin	if paramindex > paramcount then isoption := false
		else begin
			option := paramstr (paramindex);
			if length (option) = 0 then isoption := false
			else isoption := option [1] in ['-', '+', '/']
		end
	end;
begin
	corelfix := false;
	generate := true;
	split := true;
	ttfix := true;
	verbose := true;
	stdenc := true;
	noOtherSubrs := true;
	afmcheck := true;
	expand := false;
	paramindex := 1;
	while isoption do begin
		optionvalue := true;
		for i := 1 to length (option) do
		    case option [i] of
			'+': optionvalue := true;
			'-': optionvalue := false;
			'c': corelfix := optionvalue;
			'g': generate := optionvalue;
			's': split := optionvalue;
			't': ttfix := optionvalue;
			'v': verbose := optionvalue;
			'e': stdenc := optionvalue;
			'o': noOtherSubrs := optionvalue;
			'a': afmcheck := optionvalue;
			'x': expand := optionvalue;
		    end;
		if corelfix then generate := true;
		if expand then split := false;
		paramindex := paramindex + 1
	end;

	if paramindex <= paramcount then begin
	   fontfile := paramstr (paramindex);
	   fontname := basename (fontfile);
	   assign (infile, fontfile); reset (infile);
	   assign (afmin, fontname + '.afm');
	   assign (ccin, fontname + '.cc');

	   paramindex := paramindex + 1;
	   if paramindex <= paramcount then begin
		if isdir (paramstr (paramindex)) then begin
			fontfile := paramstr (paramindex) + '\' + fontfile;
			fontname := paramstr (paramindex) + '\' + fontname;
		end else begin
			fontfile := paramstr (paramindex);
			fontname := basename (fontfile);
		end;
		assign (out, fontfile);
		assign (afmout, fontname + '.afm');
	   end else begin
		assign (out, '' (* use standard output *));
		assign (afmout, fontname + '.af$');
	   end;
	   (*$I-*) reset (afmin) (*$I+*);
	   afmopen := IOresult = 0;
	   if afmopen then begin
		if verbose then writeln ('% reading afm information');
		openafm (afmin, afmout);
	   end;
	   (*$I-*) reset (ccin) (*$I+*);
	   ccopen := IOresult = 0;
	   if ccopen then begin
		if verbose then writeln ('% reading compose information');
		opencc (ccin);
		close (ccin);
	   end;

	   rewrite (out);
	   tidy (infile, out);
	   close (out);

	   if afmopen then begin
		if verbose then writeln ('% finishing afm file');
		closeafm (afmin, afmout);
	   end;
	   close (infile)
	end else tidy (input, output);
	printusedstat;
end.