{$B-}

unit pathunit;

interface

const	pathlenunit = 50;
	maxpathlen = 10 * pathlenunit;
		(* 92 recommended for normal operation 
		   170 for longer paths with many characters *)

type t1cmd = 
	(callothersubr, callsubr, closepath, t1div, dotsection, endchar,
	 hlineto, hmoveto, hsbw, hstem, hstem3, hvcurveto, pop, return, 
	 rlineto, rmoveto, rrcurveto, sbw, seac, setcurrentpoint, 
	 vhcurveto, vlineto, vmoveto, vstem, vstem3);

const cmdcount = 25;
      cmdtab: array [1..cmdcount] of record
			cmd: t1cmd;
			str: string;
			case code1: byte of
			 12: (code2: byte)
	end = (
	(cmd: callothersubr; str: 'callothersubr'; code1: 12; code2: 16),
	(cmd: callsubr; str: 'callsubr'; code1: 10),
	(cmd: closepath; str: 'closepath'; code1: 9),
	(cmd: t1div; str: 'div'; code1: 12; code2: 12),
	(cmd: dotsection; str: 'dotsection'; code1: 12; code2: 0),
	(cmd: endchar; str: 'endchar'; code1: 14),
	(cmd: hlineto; str: 'hlineto'; code1: 6),
	(cmd: hmoveto; str: 'hmoveto'; code1: 22),
	(cmd: hsbw; str: 'hsbw'; code1: 13),
	(cmd: hstem; str: 'hstem'; code1: 1),
	(cmd: hstem3; str: 'hstem3'; code1: 12; code2: 2),
	(cmd: hvcurveto; str: 'hvcurveto'; code1: 31),
	(cmd: pop; str: 'pop'; code1: 12; code2: 17),
	(cmd: return; str: 'return'; code1: 11),
	(cmd: rlineto; str: 'rlineto'; code1: 5),
	(cmd: rmoveto; str: 'rmoveto'; code1: 21),
	(cmd: rrcurveto; str: 'rrcurveto'; code1: 8),
	(cmd: sbw; str: 'sbw'; code1: 12; code2: 7),
	(cmd: seac; str: 'seac'; code1: 12; code2: 6),
	(cmd: setcurrentpoint; str: 'setcurrentpoint'; code1: 12; code2: 33),
	(cmd: vhcurveto; str: 'vhcurveto'; code1: 30),
	(cmd: vlineto; str: 'vlineto'; code1: 7),
	(cmd: vmoveto; str: 'vmoveto'; code1: 4),
	(cmd: vstem; str: 'vstem'; code1: 3),
	(cmd: vstem3; str: 'vstem3'; code1: 12; code2: 1));

var cmdstring: array [t1cmd] of string;
var expand: Boolean;

type	commandpoi = ^ command;
	SubrTpointer = ^ SubrT;
	SubPathpointer = ^ SubPath;
	CharStrpointer = ^ CharStrT;
	command = record
			Subr: SubPathpointer;
			case Boolean of
			true (* if Subr = nil: *):
				(cmd: t1cmd;
				 paramnum: integer;
				 param: array [1..6] of integer;
				);
			false (* if Subr <> nil: *):
				(closed: Boolean;
				 offsetx, offsety: integer;
				)
		end;

	commandsarray0 = array [1..maxpathlen] of commandpoi;
	commandsarray1 = array [1..1 * pathlenunit] of commandpoi;
	commandsarray2 = array [1..2 * pathlenunit] of commandpoi;
	commandsarray3 = array [1..3 * pathlenunit] of commandpoi;
	commandsarray4 = array [1..4 * pathlenunit] of commandpoi;
	commandsarray5 = array [1..5 * pathlenunit] of commandpoi;
	commandsarray6 = array [1..6 * pathlenunit] of commandpoi;
	commandsarray7 = array [1..7 * pathlenunit] of commandpoi;
	commandsarray8 = array [1..8 * pathlenunit] of commandpoi;
	commandsarray9 = array [1..9 * pathlenunit] of commandpoi;

	varcommandspoi = record case byte of
			0: (cp0: ^commandsarray0);
			1: (cp1: ^commandsarray1);
			2: (cp2: ^commandsarray2);
			3: (cp3: ^commandsarray3);
			4: (cp4: ^commandsarray4);
			5: (cp5: ^commandsarray5);
			6: (cp6: ^commandsarray6);
			7: (cp7: ^commandsarray7);
			8: (cp8: ^commandsarray8);
			9: (cp9: ^commandsarray9);
			end;

	Path = object
		commands: varcommandspoi;
		pathlen: integer;
		mayuseothersubrs: Boolean;
		constructor ini;
		procedure appendtoken (var s: string);
		procedure clippath;
		procedure setdef (s: string); virtual;
		procedure splitpath;
		procedure cleanup;
		function usesothersubrs: Boolean;
	private
		procedure appendcommand (cmd: commandpoi);
		procedure delete (i: integer);
		function pathcmd (i: integer): t1cmd;
		function pathcomponent (i: integer): commandpoi;
		procedure getoffset (i: integer; var x, y: integer);
		procedure printpath (var out: text; checkzmove, printreturn: Boolean);
		function firstorlastcmd (i: integer; last: Boolean): t1cmd;
		procedure traceBBox (var x, y, llx, lly, urx, ury: integer; var errcmd: t1cmd);
	end;

	CharStrT = object (Path)
			name: string [30];
			function clearifempty: Boolean;
			procedure setname (n: string);
			procedure setdef (s: string); virtual;
			procedure print (var out: text);
			procedure copyhalf (var newc: CharStrT; newname: string);
			procedure downpath (var newc: CharStrT; newname: string);
			procedure copypath (var newc: CharStrT; newname: string);
			procedure compose (CS1, CS2: CharStrpointer; cc1, cc2, dx, dy: integer);
			procedure checkafm (checkBBox: Boolean);
		end;

	SubrT = object (Path)
			index: integer;
			procedure setindex (i: integer);
			procedure setdef (s: string); virtual;
			procedure print (var out: text);
		end;

	SubPath = object (SubrT)
			used: integer;
			closedunique, offsetunique, closed: Boolean;
			offsetx, offsety: integer;
			procedure checkunique (x, y: integer; cl: Boolean);
			procedure setdef (s: string); virtual;
			procedure printSubr (var out: text);
		end;

const	maxSubrs = 500;
var	Subrs: array [1..maxSubrs] of ^SubrT;
	Subrscount: integer;
	MoreSubrscount: integer;
	Subrstotal: integer;

procedure sortMoreSubrs;

procedure arrangeMoreSubrs (Subrscount: integer);

procedure printMoreSubrs (var out: text);

procedure printusedStat;

procedure swappaths (var c1, c2: CharStrT);

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

implementation

uses afm, data;

function getSubr (i: integer): SubrTpointer;
var k: integer;
    result: SubrTpointer;
begin
	result := nil;
	if Subrs [i + 1]^.index = i then result := Subrs [i + 1]
	else for k := 1 to Subrscount do
		if Subrs [k]^.index = i then result := Subrs [k];
	getSubr := result
end;

var	NP, ND: string (* name of Subr / CharString definition command *);

type comparison = (less, equal, greater);

function pathcompare (var p1, p2: SubPath): comparison;
var i: integer;
    result: comparison;
	function cmdcompare (var c1, c2: command): comparison;
	var i: integer;
	    result: comparison;
	begin
		if c1.Subr <> nil then
			if c2.Subr = nil then cmdcompare := less
			else cmdcompare := pathcompare (c1.Subr^, c2.Subr^)
		else if c2.Subr <> nil then cmdcompare := greater
		else if c1.cmd < c2.cmd then cmdcompare := less
		else if c1.cmd > c2.cmd then cmdcompare := greater
		else if c1.paramnum < c2.paramnum then cmdcompare := less
		else if c1.paramnum > c2.paramnum then cmdcompare := greater
		else begin
		    i := 1;
		    result := equal;
		    while (result = equal) and (i <= c1.paramnum) do begin
			if c1.param [i] > c2.param [i] then result := greater
			else if c1.param [i] < c2.param [i] then result := less;
			i := i + 1;
		    end;
		    cmdcompare := result
		end
	end;
begin
	if p1.pathlen < p2.pathlen then pathcompare := less
	else if p1.pathlen > p2.pathlen then pathcompare := greater
	else begin
		i := 1;
		result := equal;
		while (result = equal) and (i <= p1.pathlen) do begin
		    result := cmdcompare (p1.commands.cp0^[i]^, p2.commands.cp0^[i]^);
		    i := i + 1;
		end;
		pathcompare := result
	end
end;

(*
procedure sortMoreSubrs;
	procedure quicksort (l, r: integer);
	var i, j: integer; x, w: SubPathpointer;
	begin	i := l; j := r;
		x := a [(l + r) div 2];
		repeat
			while pathcompare (a [i]^, x^) = less do i := i + 1;
			while pathcompare (x^, a [j]^) = less do j := j - 1;
			if i <= j then begin
				w := a [i]; a [i] := a [j]; a [j] := w;
				i := i + 1; j := j - 1
			end
		until i > j;
		if l < j then quicksort (l, j);
		if i < r then quicksort (i, r)
	end;
begin
	quicksort (1, MoreSubrscount)
end;
*)
procedure sortMoreSubrs;
begin
end;

type SubPathtree = ^SubPathrec;
     SubPathrec = record SB: SubPathpointer;
			 left, right: SubPathtree
		  end;

var	MoreSubrs: SubPathtree;


procedure disposeSubPath (SP: SubPathpointer);
var i: integer;
begin
	for i := 1 to SP^.pathlen do begin
		if SP^.commands.cp0^[i]^.Subr <> nil
		   then disposeSubPath (SP^.commands.cp0^[i]^.Subr);
		dispose (SP^.commands.cp0^[i])
	end;
	dispose (SP)
end;

function insertSubPath (var SBp: SubPathtree; SP: SubPathpointer): SubPathpointer;
begin
	if SBp = nil then begin
		new (SBp); SBp^.left := nil; SBp^.right := nil;
		SBp^.SB := SP; MoreSubrscount := MoreSubrscount + 1;
		insertSubPath := SP
	end else if pathcompare (SP^, SBp^.SB^) = equal then begin
		SBp^.SB^.used := SBp^.SB^.used + 1;
		disposeSubPath (SP);
		insertSubPath := SBp^.SB
	end else if pathcompare (SP^, SBp^.SB^) = less then
		insertSubPath := insertSubPath (SBp^.left, SP)
	else	insertSubPath := insertSubPath (SBp^.right, SP)
end;

type PathProc = procedure (sp: SubPathpointer; var out: text);
     (* The second parameter and its dummy setting at several places
	of one of the two application cases below is due to the
	silly restriction of Turbo-Pascal which doesn't allow nested
	procedures to be passed as parameters as standard Pascal does. *)
procedure applyMoreSubrs (PP: PathProc; var out: text);
    procedure apply (SBp: SubPathtree);
    begin
	if SBp <> nil then begin
		apply (SBp^.left);
		PP (SBp^.SB, out);
		apply (SBp^.right)
	end
    end;
begin
     apply (MoreSubrs)
end;

const maxused = 50;
var usedStat: array [0..maxused] of integer;
    zeromoves: integer;

procedure Pindex (sp: SubPathpointer; (*dummy*) var out: text); far;
begin	if (sp^.used > 1) and (sp^.index < 0) then begin
		sp^.setindex (Subrstotal);
		Subrstotal := Subrstotal + 1;
	end;
	if sp^.used > maxused then
		usedStat [0] := usedStat [0] + 1
	else	usedStat [sp^.used] := usedStat [sp^.used] + 1
end;
procedure arrangeMoreSubrs (Subrscount: integer);
begin	Subrstotal := Subrscount;
	applyMoreSubrs (Pindex, (*dummy*) output)
end;

procedure Pprint (sp: SubPathpointer; var out: text); far;
begin	if sp^.used > 1 then
		sp^.printSubr (out)
end;
procedure printMoreSubrs (var out: text);
begin	applyMoreSubrs (Pprint, out)
end;

procedure printusedStat;
var i: integer;
begin
	writeln ('extracted Subrs use statistics:');
	writeln ('# used  # Subrs');
	for i := 1 to maxused do
	    if usedStat [i] > 0 then
		writeln (i: 6, usedStat [i]: 6);
	if usedStat [0] > 0 then
		writeln (' more:', usedStat [0]: 6);
	if zeromoves > 0 then
		writeln (' inserted ', zeromoves, ' zero move commands for ATM''s sake');
end;

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

function cmdstr (cmd: t1cmd): string;
begin	cmdstr := cmdstring [cmd] end;

function strcmd (var (* for some efficiency *) s: string): t1cmd;
var l, r, i: integer;
    cs: string;
begin	l := 1; r := cmdcount;
	repeat
		i := (l + r) div 2;
		cs := cmdtab [i].str;
		if s < cs then r := i - 1
		else if s > cs then l := i + 1
		else l := r + 1
	until l > r;
	if s = cs then strcmd := cmdtab [i].cmd
	else begin
		writeln ('% WARNING: unknown command "', s, '" detected');
		strcmd := endchar
	end
end;

procedure setNPND (var def: string; s: string);
begin	if def = '' then def := s
	else if s <> ''
		then if def <> s then writeln ('% WARNING: NP/ND command names differ')
end;


procedure printoffset (var out: text; x, y: integer);
begin
	if x <> 0 then
		if y <> 0 then writeln (out, '	', x, ' ', y, ' rmoveto')
		else writeln (out, '	', x, ' hmoveto')
	else if y <> 0 then writeln (out, '	', y, ' vmoveto')
	else begin (* atm (1.15) bug: also write zero move command *)
		zeromoves := zeromoves + 1;
		writeln (out, '	0 hmoveto')
	end
end;

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

var commandactive: Boolean;

constructor Path.ini;
begin	pathlen := 0;
	commandactive := false;
	mayuseothersubrs := true;
	new (commands.cp0)
end;

function Path.usesothersubrs: Boolean;
var i: integer;
    othersfound: Boolean;
    icmd: t1cmd;
    sub: ^SubrT;
begin
    if not mayuseothersubrs then usesothersubrs := false
    else begin
	i := 1;
	othersfound := false;
	while (i <= pathlen) and not othersfound do begin
		icmd := pathcmd (i);
		if icmd = callothersubr then othersfound := true
		else if icmd = callsubr then with commands.cp0^[i]^ do begin
			if Subr = nil
			then if paramnum = 0
				then sub := nil (* something like pop callsubr *)
				else sub := getSubr (param [paramnum])
			else sub := Subr;
			if sub <> nil then othersfound := sub^.usesothersubrs;
		end;
		i := i + 1;
	end;
	if not othersfound then mayuseothersubrs := false;
	usesothersubrs := othersfound
    end
end;

procedure Path.appendtoken (var (* for some efficiency *) s: string);
var i, c: integer;
begin	if not commandactive then begin
	    if pathlen < maxpathlen then begin
		pathlen := pathlen + 1;
		new (commands.cp0^[pathlen]);
		commands.cp0^[pathlen]^.paramnum := 0;
		commands.cp0^[pathlen]^.Subr := nil;
	    end else begin
		writeln ('ERROR: max. path length exceeded');
		halt
	    end
	end;
	val (s, i, c);
	if c = 0 then with commands.cp0^[pathlen]^ do begin
		paramnum := paramnum + 1;
		param [paramnum] := i;
		commandactive := true
	end else begin
		commands.cp0^[pathlen]^.cmd := strcmd (s);
		commandactive := false
	end
end;

procedure Path.clippath;
(* shortens path storage according to current pathlen *)
var longpath: varcommandspoi;
    i: integer;
begin
	longpath := commands;
	case (pathlen - 1) div pathlenunit + 1 of
	  1:	new (commands.cp1);
	  2:	new (commands.cp2);
	  3:	new (commands.cp3);
	  4:	new (commands.cp4);
	  5:	new (commands.cp5);
	  6:	new (commands.cp6);
	  7:	new (commands.cp7);
	  8:	new (commands.cp8);
	  9:	new (commands.cp9);
	  else	new (commands.cp0);
	end;
	for i := 1 to pathlen do commands.cp0^[i] := longpath.cp0^[i];
	dispose (longpath.cp0)
end;

procedure Path.appendcommand (cmd: commandpoi);
begin	if pathlen < maxpathlen then begin
		pathlen := pathlen + 1;
		new (commands.cp0^[pathlen]);
		commands.cp0^[pathlen]^ := cmd ^;
	end else begin
		writeln ('ERROR: max. path length exceeded');
		halt
	end
end;

procedure Path.delete (i: integer);
var k: integer;
begin
     pathlen := pathlen - 1;
     dispose (commands.cp0^[i]);
     for k := i to pathlen do commands.cp0^[k] := commands.cp0^[k + 1]
end;

procedure Path.cleanup;
var i, k: integer;
    prevcmd: t1cmd;
    x, y: integer;
begin
	i := 1;
	while i <= pathlen do begin
	    if i = 1 then prevcmd := pop (* dummy, just not a moveto *)
	    else prevcmd := commands.cp0^[i - 1]^.cmd;
	    case commands.cp0^[i]^.cmd of
		closepath: if prevcmd in [closepath, endchar, hmoveto, hsbw, 
					  return, rmoveto, sbw, vmoveto]
				then delete (i)
				else i := i + 1;
		hmoveto, rmoveto, vmoveto:
			if prevcmd in [hmoveto, rmoveto, vmoveto] then begin
			   x := 0; y := 0;
			   for k := i - 1 to i do with commands.cp0^[k]^ do
				case cmd of
				hmoveto: x := x + param [1];
				vmoveto: y := y + param [1];
				rmoveto: begin	x := x + param [1];
						y := y + param [2]
					 end
				end;
			   delete (i);
			   i := i - 1;
			   with commands.cp0^[i]^ do begin
				cmd := rmoveto;
				param [1] := x;
				param [2] := y;
				paramnum := 2;
			   end
			end else with commands.cp0^[i]^ do begin
			(*	if (param [1] = 0) and
			(*		((cmd <> rmoveto) or (param [2] = 0))
			(*	then delete (i)
			(*   don't delete (i): atm (1.15) has a bug
			(*	else *)
				if (cmd = rmoveto) and (param [2] = 0)
				then begin
					cmd := hmoveto;
					paramnum := 1;
				end else
				if (cmd = rmoveto) and (param [1] = 0)
				then begin
					cmd := vmoveto;
					param [1] := param [2];
					paramnum := 1;
				end else 
				if (cmd = vmoveto) and (param [1] = 0)
				then begin
					cmd := hmoveto;
				end else 
					i := i + 1
			end;
		rlineto: with commands.cp0^[i]^ do begin
				if param [1] = 0 (* 0 y rlineto *)
				then begin
					cmd := vlineto;
					param [1] := param [2];
					paramnum := 1;
				end else if param [2] = 0 (* x 0 rlineto *)
				then begin
					cmd := hlineto;
					paramnum := 1;
				end;
				i := i + 1
			end;
		rrcurveto: with commands.cp0^[i]^ do begin
				if (param [1] = 0) and (param [6] = 0)
				then begin
					cmd := vhcurveto;
					for k := 1 to 4 do
						param [k] := param [k + 1];
					paramnum := 4;
				end
				else if (param [2] = 0) and (param [5] = 0)
				then begin
					cmd := hvcurveto;
					param [2] := param [3];
					param [3] := param [4];
					param [4] := param [6];
					paramnum := 4;
				end;
				i := i + 1
			end;
		else	i := i + 1
	    end
	end
end;

const hintcmds = [hstem, hstem3, vstem, vstem3, dotsection];
      movecmds = [hmoveto, rmoveto, vmoveto];
      drawcmds = [hlineto, hvcurveto, rlineto,
		  rrcurveto, vhcurveto, vlineto];
      curvecmds = [hvcurveto, rrcurveto, vhcurveto];

function Path.pathcmd (i: integer): t1cmd;
begin
	if (i > pathlen) or (i < 1) then pathcmd := pop
	else if commands.cp0^[i]^.Subr = nil then pathcmd := commands.cp0^[i]^.cmd
	else pathcmd := callsubr
end;

function Path.pathcomponent (i: integer): commandpoi;
begin
	if (i > pathlen) or (i < 1) then pathcomponent := nil
	else pathcomponent := commands.cp0^[i]
end;

procedure Path.getoffset (i: integer; var x, y: integer);
begin
	if pathcmd (i) in movecmds then with commands.cp0^[i]^ do begin
	   case cmd of
		hmoveto: begin x := param [1]; y := 0 end;
		vmoveto: begin y := param [1]; x := 0 end;
		rmoveto: begin x := param [1]; y := param [2] end;
	   end
	end else begin
		x := 0; y := 0
	end
end;

procedure Path.splitpath;
var i, pathstart, k: integer;
    newSubr: ^SubPath;
    x, y: integer;

begin
	i := 1;
	while i <= pathlen do begin
		while (i <= pathlen) and 
			not (pathcmd (i) in drawcmds + hintcmds) do
			i := i + 1;
		if i <= pathlen then begin
		    pathstart := i;
		(* heuristics which sorts of command groups to build: *)
		    if pathcmd (pathstart) in hintcmds then
			repeat i := i + 1 until not (pathcmd (i) in hintcmds)
		    else begin (* pathcmd (pathstart) in drawcmds *)
		      	repeat i := i + 1 until not (pathcmd (i) in drawcmds);
		     (* if pathcmd (i) = closepath then i := i + 1; *)
		    end;
		    if (i - pathstart > 1) or 
			(pathcmd (pathstart) in curvecmds) then begin
			new (newSubr, ini);
			newSubr^.used := 1;
			newSubr^.index := -1;
			newSubr^.pathlen := i - pathstart;
			newSubr^.clippath;
			for k := 1 to newSubr^.pathlen do
			    newSubr^.commands.cp0^[k] := commands.cp0^[pathstart+k-1];
			pathlen := pathlen - i + pathstart + 1;
			for k := pathstart + 1 to pathlen do begin
			    commands.cp0^[k] := commands.cp0^[k - pathstart - 1 + i];
			    (* don't dispose them - they are still needed in the Subr *)
			end;
			new (commands.cp0^[pathstart]);
			newSubr := insertSubPath (MoreSubrs, newSubr);
			(* to replace newSubr by unique one on second use *)
			commands.cp0^[pathstart]^.Subr := newSubr;
			getoffset (pathstart - 1, x, y);
			commands.cp0^[pathstart]^.offsetx := x;
			commands.cp0^[pathstart]^.offsety := y;
			if pathcmd (pathstart + 1) = closepath then begin
				newSubr^.checkunique (x, y, true);
				delete (pathstart + 1);
				commands.cp0^[pathstart]^.closed := true
			end else begin
				newSubr^.checkunique (x, y, false);
				commands.cp0^[pathstart]^.closed := false
			end;
			if pathcmd (pathstart - 1) in movecmds then begin
				pathstart := pathstart - 1;
				delete (pathstart)
			end;
			i := pathstart + 1;
		    end
		end
	end
end;

function Path.firstorlastcmd (i: integer; last: Boolean): t1cmd;
var cmd: t1cmd;
    sub: ^SubrT;
begin
	cmd := pathcmd (i);
	if cmd = callsubr then with commands.cp0^[i]^ do begin
		if Subr = nil
		then if paramnum <> 1
			then sub := nil (* something like pop callsubr 
					   or n m callsubr *)
			else sub := getSubr (param [paramnum])
		else sub := Subr;
		if sub = nil
		then firstorlastcmd := rmoveto (* pretend it's alright *)
		else if last
		     then if sub^.pathcmd (sub^.pathlen) = return
			then firstorlastcmd :=	(* last of original Subr *)
				sub^.firstorlastcmd (sub^.pathlen - 1, true)
			else firstorlastcmd :=	(* last of extracted Subr *)
				sub^.firstorlastcmd (sub^.pathlen, true)
		     else firstorlastcmd := sub^.firstorlastcmd (1, false)
	end else firstorlastcmd := cmd
end;

procedure Path.printpath (var out: text; checkzmove, printreturn: Boolean);
const nozeromovecmds = drawcmds + movecmds
			+ [setcurrentpoint, callothersubr, dotsection];
var i, k: integer;
begin	for i := 1 to pathlen - ord (not printreturn) do
	  with commands.cp0^[i]^ do begin
	    if Subr = nil then begin
		if expand and (cmd = callsubr)
		and (paramnum >= 1) and (param [paramnum] >= 4) then begin
		    if paramnum > 1 then begin
			write (out, '	');
			for k := 1 to paramnum - 1 do begin
				write (out, param [k], ' ');
			end;
		    end;
		    getSubr (param [paramnum])^.printpath (out, false, false)
		end else begin
		  if checkzmove then
		    if firstorlastcmd (i, false) in drawcmds
		       then if not (firstorlastcmd (i - 1, true) in nozeromovecmds)
			  then printoffset (out, 0, 0);
		  write (out, '	');
		  for k := 1 to paramnum do begin
			write (out, param [k], ' ');
		  end;
		  writeln (out, cmdstr (cmd));
		end
	    end else if (Subr^.used > 1) and not expand then begin
		if (not Subr^.offsetunique)
		   or ((Subr^.offsetx = 0) and (Subr^.offsety = 0)) then
		   if Subr^.pathcmd (1) in drawcmds then
			if (offsetx <> 0) or (offsety <> 0)
			   or not (firstorlastcmd (i - 1, true) in nozeromovecmds)
			then printoffset (out, offsetx, offsety);
		writeln (out, '	', Subr^.index, ' callsubr');
		if closed and not Subr^.closedunique then writeln (out, '	closepath');
	    end	else begin
		if Subr^.pathcmd (1) in drawcmds then
		   if (offsetx <> 0) or (offsety <> 0)
			or not (firstorlastcmd (i - 1, true) in nozeromovecmds)
		   then printoffset (out, offsetx, offsety);
		Subr^.printpath (out, false, true);
		if closed then writeln (out, '	closepath');
	    end
	end
end;

function CharStrT.clearifempty: Boolean;
(* clippath must not have been called! *)
var i: integer;
    isempty: Boolean;
begin	isempty := true;
	i := 1;
	while (i <= pathlen) and isempty do begin
		if pathcmd (i) in drawcmds + [callsubr, callothersubr, seac]
			then isempty := false;
		i := i + 1;
	end;
	if isempty then
	   if (name = '/.notdef') or (pos ('space', name) > 0) or (pos ('blank', name) > 0)
	   then isempty := false
	   else begin
		for i := 1 to pathlen do dispose (commands.cp0^[i]);
		dispose (commands.cp0);
	   end;
	clearifempty := isempty
end;

procedure CharStrT.setname (n: string);
begin	name := n end;

procedure CharStrT.print (var out: text);
begin
	write (out, name, ' {');
	printpath (out, true, true);
	writeln (out, '	} ', ND)
end;

procedure CharStrT.setdef (s: string);
begin	setNPND (ND, s); clippath end;

procedure SubrT.setindex (i: integer);
begin	index := i end;

procedure SubrT.print (var out: text);
begin
	write (out, 'dup ', index, ' {');
	printpath (out, false, true);
	writeln (out, '	} ', NP)
end;

procedure Path.setdef (s: string);
begin	clippath end;

procedure SubPath.checkunique (x, y: integer; cl: Boolean);
begin
	if used <= 1 then begin
		offsetx := x; offsety := y; offsetunique := true;
		closed := cl; closedunique := true
	end else begin
		if (x <> offsetx) or (y <> offsety) then offsetunique := false;
		if cl <> closed then closedunique := false
	end
end;

procedure SubPath.setdef (s: string);
begin	clippath end;

procedure SubPath.printSubr (var out: text);
begin
	write (out, 'dup ', index, ' {');
	if offsetunique then
	   if pathcmd (1) in drawcmds then
	      if (offsetx <> 0) or (offsety <> 0) then
		 printoffset (out, offsetx, offsety);
	printpath (out, false, true);
	if closedunique and closed then writeln (out, '	closepath');
	writeln (out, '	return');
	writeln (out, '	} ', NP)
end;

procedure SubrT.setdef (s: string);
begin	setNPND (NP, s); clippath end;

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

function newafmcode (name: string): integer;
begin
	if stdenc then newafmcode := getSEcode (name)
	else newafmcode := -1
end;

procedure CharStrT.copyhalf (var newc: CharStrT; newname: string);
(* This is a heuristic attempt to generate single-part characters from 
   double-part ones, especially quote marks. It was designed for wfnboss 
   generated fonts which lack some single quote marks.
   The proceudre assumes that the path of the character to be split contains 
   exactly 2 move commands! *)
var i, m1, m2, x1, x2, y1, y2, widthsub: integer;
    C, WX, lx, ly, rx, ry: integer;
begin
	newc.setname (newname);
	i := 1;
	while (i <= pathlen) and not (pathcmd (i) in movecmds) do i := i + 1;
	m1 := i;
	repeat i := i + 1 until (i > pathlen) or (pathcmd (i) in movecmds);
	if i > pathlen then i := pathlen;
	m2 := i;
	getoffset (m1, x1, y1);
	getoffset (m2, x2, y2);
	for i := 1 to m2 - 1 do newc.appendcommand (commands.cp0^[i]);
	newc.appendcommand (commands.cp0^[pathlen]);
	newc.clippath;
	if x2 < 0 then begin
		(* first part of path was right part; shift it left *)
		with newc.commands.cp0^[m1]^ do begin
			cmd := rmoveto; (* might have been hmoveto or vmoveto *)
			paramnum := 2;
			param [1] := x1 + x2;
			param [2] := y1;
		end;
		widthsub := - x2;
	end else begin
		widthsub := x2;
	end;
	with newc.commands.cp0^[1]^ do (* reduce wx *)
		case cmd of
			hsbw: param [2] := param [2] - widthsub;
			sbw: param [3] := param [3] - widthsub;
		end;
	newc.cleanup;
	if afmopen then begin
		getafmchar (C, WX, name, lx, ly, rx, ry);
		putafmchar (newafmcode (newname), WX - widthsub, newc.name, lx, ly, rx - widthsub, ry);
	end
end;

procedure CharStrT.downpath (var newc: CharStrT; newname: string);
(* This is a heuristic attempt to generate base line quote marks from 
   upper quote marks *)
var i, m, x, y, heightsub: integer;
    C, WX, lx, ly, rx, ry: integer;
begin
	newc.setname (newname);
	i := 1;
	while (i <= pathlen) and not (pathcmd (i) in movecmds) do i := i + 1;
	m := i;
	getoffset (m, x, y);
	heightsub := y;	(* This might be more sophisticated *)
	for i := 1 to pathlen do newc.appendcommand (commands.cp0^[i]);
	newc.clippath;
	for i := 1 to m do
	    with newc.commands.cp0^[i]^ do
		case cmd of
			hmoveto: (* would only have to be handled
				    if we could derive non-zero down-shift 
				    values from this *);
			vmoveto: param [1] := param [1] - heightsub;
			rmoveto: param [2] := param [2] - heightsub;
			hstem: param [1] := param [1] - heightsub;
			hstem3: begin
				param [1] := param [1] - heightsub;
				param [3] := param [3] - heightsub;
				param [5] := param [5] - heightsub;
				end
			else ;
		end;
	newc.cleanup;
	if afmopen then begin
		getafmchar (C, WX, name, lx, ly, rx, ry);
		putafmchar (newafmcode (newname), WX, newc.name, lx, ly - heightsub, rx, ry - heightsub);
	end
end;

procedure CharStrT.copypath (var newc: CharStrT; newname: string);
var i, C, WX, lx, ly, rx, ry: integer;
begin
	newc.setname (newname);
	for i := 1 to pathlen do newc.appendcommand (commands.cp0^[i]);
	newc.clippath;
	newc.cleanup;
	if afmopen then begin
		getafmchar (C, WX, name, lx, ly, rx, ry);
		putafmchar (newafmcode (newname), WX, newc.name, lx, ly, rx, ry);
	end
end;

procedure CharStrT.compose (CS1, CS2: CharStrpointer; cc1, cc2, dx, dy: integer);
var seaccmd: commandpoi;
    WX, WX1, WX2, sbx1, sby1, sbx2, sby2: integer;
    C, llx1, lly1, urx1, ury1, llx2, lly2, urx2, ury2: integer;

  procedure getsb (CS: CharStrpointer; var sbx, sby: integer);
  begin
	sbx := CS^.pathcomponent (1)^.param [1];
	if CS^.pathcmd (1) = sbw
	then sby := CS^.pathcomponent (1)^.param [2]
	else sby := 0
  end;

  function getwidth (CS: CharStrpointer): integer;
  begin
	with CS^.pathcomponent (1)^ do case cmd of
		hsbw: getwidth := param [2];
		sbw: getwidth := param [3];
		else getwidth := 0
	end
  end;

begin
	appendcommand (CS1^.pathcomponent (1));
	WX1 := getwidth (CS1);
	WX := WX1;
	if length (CS2^.name) = 2 then begin
	   (* a letter appended to another *)
		WX2 := getwidth (CS2) + dx;
		if WX2 > WX1 then with pathcomponent (1)^ do begin
		   WX := WX2;
		   case cmd of
			hsbw: param [2] := WX;
			sbw: param [3] := WX;
		   end
		end
	end;
	new (seaccmd);
	getsb (CS1, sbx1, sby1);
	getsb (CS2, sbx2, sby2);
	with seaccmd^ do begin
		Subr := nil;
		cmd := seac;
		paramnum := 5;
		param [4] := cc1;
		param [5] := cc2;
		param [1] := sbx2;
		param [2] := dx + sbx2 - sbx1;
		param [3] := dy + sby2 - sby1;
	end;
	appendcommand (seaccmd);
	clippath;
	if afmopen then begin
		getafmchar (C, WX1, CS1^.name, llx1, lly1, urx1, ury1);
		getafmchar (C, WX2, CS2^.name, llx2, lly2, urx2, ury2);
		if llx2 + dx < llx1 then llx1 := llx2 + dx;
		if lly2 + dy < lly1 then lly1 := lly2 + dy;
		if urx2 + dx > urx1 then urx1 := urx2 + dx;
		if ury2 + dy > ury1 then ury1 := ury2 + dy;
		putafmchar (newafmcode (name), WX, name, llx1, lly1, urx1, ury1);
	end
end;

procedure swappaths (var c1, c2: CharStrT);
(* to fix wfnboss's exchange of bullet and periodcentered descriptions *)
var name: string; wx, wx1, wx2: integer;
begin
	name := c1.name;
	c1.name := c2.name;
	c2.name := name;
	if c1.commands.cp0^[1]^.cmd = hsbw then wx1 := 2 else wx1 := 3;
	if c2.commands.cp0^[1]^.cmd = hsbw then wx2 := 2 else wx2 := 3;
	wx := c1.commands.cp0^[1]^.param [wx1];
	c1.commands.cp0^[1]^.param [wx1] := c2.commands.cp0^[1]^.param [wx2];
	c2.commands.cp0^[1]^.param [wx2] := wx;
	(* the case that only one path has an sbw command
	   is not handled completely correct *)
	wx := c1.commands.cp0^[1]^.param [wx1 + 1];
	c1.commands.cp0^[1]^.param [wx1 + 1] := c2.commands.cp0^[1]^.param [wx2 + 1];
	c2.commands.cp0^[1]^.param [wx2 + 1] := wx;
end;

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

procedure Path.traceBBox (var x, y, llx, lly, urx, ury: integer; var errcmd: t1cmd);
var i: integer;
    x1, y1: integer;
  procedure newpoint (newx, newy: integer);
  begin
	x := newx;
	y := newy;
	if x < llx then llx := x
	else if x > urx then urx := x;
	if y < lly then lly := y
	else if y > ury then ury := y;
  end;
begin
     i := 1;
     while (i <= pathlen) do with pathcomponent (i) ^ do begin
	if Subr <> nil then Subr^.traceBBox (x, y, llx, lly, urx, ury, errcmd)
	else
	 case cmd of
	  callothersubr: errcmd := callothersubr;
	  callsubr: getSubr (param [paramnum])^.traceBBox (x, y, llx, lly, urx, ury, errcmd);
	  t1div: errcmd := t1div;
	  closepath, return, endchar, pop: ;
	  dotsection, hstem, hstem3, vstem, vstem3: ;
	  hsbw: x := param [1];
	  sbw: begin x := param [1]; y := param [2] end;
	  seac: begin	x1 := x; y1 := y; (* save current sidebearing point *)
			getCharString (StandardEncoding [param [4]])^.
				traceBBox (x, y, llx, lly, urx, ury, errcmd);
			x := x1 + param [2] - param [1];
			y := y1 + param [3] (* - sby (accent), hopefully 0 *);
			getCharString (StandardEncoding [param [5]])^.
				traceBBox (x, y, llx, lly, urx, ury, errcmd)
		end;
	  hlineto: newpoint (x + param [1], y);
	  hmoveto: newpoint (x + param [1], y);
	  rlineto: newpoint (x + param [1], y + param [2]);
	  rmoveto: newpoint (x + param [1], y + param [2]);
	  vlineto: newpoint (x, y + param [2]);
	  vmoveto: newpoint (x, y + param [2]);
	    (* with the curves, hope for horizontal and vertical tangents: *)
	  hvcurveto: newpoint (x + param [1] + param [2],
				y + param [3] + param [4]);
	  rrcurveto: newpoint (x + param [1] + param [3] + param [5],
				y + param [2] + param [4] + param [6]);
	  vhcurveto: newpoint (x + param [2] + param [4],
				y + param [1] + param [3]);
	  setcurrentpoint: if paramnum = 2 then begin
				x := param [1]; y := param [2]
			   end
			   else errcmd := setcurrentpoint;
	 end;
	 i := i + 1
     end
end;

procedure CharStrT.checkafm (checkBBox: Boolean);
(* Check afm entries for correct width and (optionally) 
   bounding box information. The latter procedure seems to be 
   currently a great rubbish. *)
var C, WX, llx, lly, urx, ury,
    oldWX, oldllx, oldlly, oldurx, oldury: integer;
    x, y: integer;
    errcmd: t1cmd;
    putit: Boolean;
begin
   if name <> '/.notdef' then begin
      if pathcmd (1) = hsbw
      then WX := pathcomponent (1)^.param [2]
      else if pathcmd (1) = sbw
      then WX := pathcomponent (1)^.param [3]
      else begin
	writeln ('% path error: first command not hsbw or sbw in character ', name);
	WX := 0;
      end;
      getafmchar (C, oldWX, name, oldllx, oldlly, oldurx, oldury);
      putit := false;

      if C = -2 then begin
	writeln ('% afm error: missing entry for character ', name);
	putit := true;
	C := newafmcode (name);
      end
      else if oldWX <> WX then begin
	writeln ('% afm error: wrong width for character ', name);
	putit := true;
      end;

      if checkBBox then begin
	llx := maxint;
	urx := - maxint;
	lly := maxint;
	ury := - maxint;
	x := 0;
	y := 0;
	errcmd := return;
	traceBBox (x, y, llx, lly, urx, ury, errcmd);
	if errcmd <> return then begin
		writeln ('% tracing BBox of ', name, ': cannot handle ', cmdstr (errcmd));
		llx := oldllx; lly := oldlly; urx := oldurx; ury := oldury;
	end
	else if C = -2 then putit := true
	else if abs (llx - oldllx) + abs (lly - oldlly)
		+ abs (urx - oldurx) + abs (ury - oldury) < 30
	then begin	(* keep old values *)
		llx := oldllx; lly := oldlly; urx := oldurx; ury := oldury;
	end
	else begin
		putit := true;
		writeln ('% adjusting afm BBox information for ', name);
	end;
      end
      else begin
	llx := oldllx; lly := oldlly; urx := oldurx; ury := oldury;
      end;

      if putit then putafmchar (C, WX, name, llx, lly, urx, ury);
   end
end;

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

var i: integer;
begin
	for i := 1 to cmdcount do with cmdtab [i] do
		cmdstring [cmd] := str;
	NP := ''; ND := '';
	MoreSubrscount := 0;
	MoreSubrs := nil;
	for i := 0 to maxused do usedStat [i] := 0;
	zeromoves := 0;
end.