summaryrefslogtreecommitdiff
path: root/fonts/utilities/t1tools/t1tidy/pathunit.pas
diff options
context:
space:
mode:
Diffstat (limited to 'fonts/utilities/t1tools/t1tidy/pathunit.pas')
-rw-r--r--fonts/utilities/t1tools/t1tidy/pathunit.pas1135
1 files changed, 1135 insertions, 0 deletions
diff --git a/fonts/utilities/t1tools/t1tidy/pathunit.pas b/fonts/utilities/t1tools/t1tidy/pathunit.pas
new file mode 100644
index 0000000000..3751a07540
--- /dev/null
+++ b/fonts/utilities/t1tools/t1tidy/pathunit.pas
@@ -0,0 +1,1135 @@
+{$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.