DIRECTORY
Atom USING [GetPName],
Basics USING [CompareCard, Comparison, LongNumber],
CardTab USING [Create, EachPairAction, Fetch, Insert, Pairs, Ref, Store, Update, UpdateAction],
ImagerBox USING [Extents],
ImagerFDBuild USING [CharacterDescription, CharacterDescriptionCell, CharacterDescriptionRep, CharacterDescriptions, FDTable, FDTableRep],
ImagerFDTypeface USING [CharInfo, CharInfoRun, CharInfoRunRep, CharInfoRunSeq, CharInfoRunSeqRep, CharRunEntry, CharRuns, CharRunsRep, CharSet, Data, DataRep, FromStream, OverflowCharInfoSeq, OverflowCharInfoSeqRep, OverflowIndex, password, RealCode, RealSeq, RealSeqRep, TransformationSeq, TransformationSeqRep, TypefaceCell, TypefaceCellSeq, TypefaceCellSeqRep, TypefaceIndex, VerboseCharInfo, VerboseCharInfoRep],
ImagerSys USING [OpenInputFile, OpenOutputFile],
ImagerTransformation USING [Equal, Factor, FactoredTransformation, Scale, Transformation],
IO USING [Close, PutByte, PutRope, STREAM],
List USING [CompareProc, Length, Sort],
Prop USING [PropList],
Real USING [Fix, FScale, Round],
RefTab USING [Create, EachPairAction, EqualProc, Fetch, GetSize, HashProc, Insert, Pairs, Ref, Update, UpdateAction],
Rope USING [ROPE, Size],
SymTab USING [Create, Ref, Update, UpdateAction],
Vector2 USING [VEC];
Canonicalization
RealTab: TYPE = CardTab.Ref;
RealAssoc: TYPE = RECORD [real: REAL, card: CARD, subsume: REF RealAssoc ¬ NIL];
RealAssocCompare: List.CompareProc = {
[ref1: REF ANY, ref2: REF ANY] RETURNS [Basics.Comparison]
a: REF RealAssoc = NARROW[ref1];
b: REF RealAssoc = NARROW[ref2];
RETURN [Basics.CompareCard[b.card, a.card]] -- sort in decreasing order by cardinal.
};
CountReal:
PROC [realTab: RealTab, real:
REAL] = {
Inner: CardTab.UpdateAction = {
[found: BOOL, val: CardTab.Val] RETURNS [op: CardTab.UpdateOperation ← none, new: CardTab.Val ← NIL]
IF found
THEN { c: REF RealAssoc = NARROW[val]; c.card ¬ c.card + 1 }
ELSE { RETURN [op: store, new: NEW [RealAssoc ¬ [real: real, card: 1]]] };
};
CardTab.Update[x: realTab, key: LOOPHOLE[real], action: Inner];
};
CommonReals: TYPE = REF CommonRealsRep;
CommonRealsRep:
TYPE =
RECORD [
realToIndex: RealTab,
realForCode: RealSeq
];
FindCommonReals:
PROC [realTab: RealTab, tolerance:
REAL ¬ 0.0, max: RealCode ¬ 255]
RETURNS [CommonReals] = {
list: LIST OF REF ANY ¬ NIL;
ans: CommonReals ¬ NEW[CommonRealsRep];
EachEntry: CardTab.EachPairAction = {
[key: CardTab.Key, val: CardTab.Val] RETURNS [quit: BOOL ← FALSE]
list ¬ CONS[val, list];
};
[] ¬ CardTab.Pairs[x: realTab, action: EachEntry];
IF tolerance # 0.0
THEN {
A very simple cluster analysis.
new: LIST OF REF ANY ¬ NIL;
clusterStart: REF RealAssoc ¬ NIL;
RealAssocOrderCompare: List.CompareProc = {
[ref1: REF ANY, ref2: REF ANY] RETURNS [Basics.Comparison]
a: REF RealAssoc = NARROW[ref1];
b: REF RealAssoc = NARROW[ref2];
RETURN [CompareReal[b.real, a.real]] -- sort by decreasing order
};
CloseEnough:
PROC [a, b:
REAL]
RETURNS [
BOOL] = {
IF (a>0) # (b>0) THEN RETURN [FALSE];
RETURN [ABS[a-b] <= tolerance]
};
list ¬ List.Sort[list: list, compareProc: RealAssocOrderCompare];
FOR tail:
LIST
OF
REF
ANY ¬ list, tail.rest
UNTIL tail =
NIL
DO
this: REF RealAssoc = NARROW[tail.first];
IF clusterStart =
NIL
THEN {clusterStart ¬ this}
ELSE {
IF CloseEnough[this.real, clusterStart.real]
THEN {
this.subsume ¬ clusterStart.subsume;
clusterStart.subsume ¬ this;
clusterStart.card ¬ clusterStart.card + this.card;
}
ELSE {
new ¬ CONS[clusterStart, new];
clusterStart ¬ this;
};
};
ENDLOOP;
IF clusterStart # NIL THEN {new ¬ CONS[clusterStart, new]; clusterStart ¬ NIL };
list ¬ new;
};
list ¬ List.Sort[list: list, compareProc: RealAssocCompare];
ans.realToIndex ¬ CardTab.Create[];
ans.realForCode ¬ NEW[RealSeqRep[MIN[List.Length[list], max+1]]];
FOR i: RealCode
IN [0..ans.realForCode.size)
DO
r: REF RealAssoc = NARROW[list.first];
ans.realForCode[i] ¬ r.real;
FOR a:
REF RealAssoc ¬ r, a.subsume
UNTIL a =
NIL
DO
IF NOT CardTab.Insert[x: ans.realToIndex, key: LOOPHOLE[a.real], val: NEW[RealAssoc ¬ [real: r.real, card: i]]] THEN ERROR;
ENDLOOP;
list ¬ list.rest;
ENDLOOP;
RETURN [ans]
};
GetRealCode:
PROC [commonReals: CommonReals, real:
REAL]
RETURNS [
INT] = {
found: BOOL; val: REF;
[found, val] ¬ CardTab.Fetch[x: commonReals.realToIndex, key: LOOPHOLE[real]];
RETURN [IF found THEN INT[NARROW[val, REF RealAssoc].card] ELSE -1]
};
SetArrayTable: TYPE = REF SetArrayTableRep;
SetArrayTableRep: TYPE = ARRAY CharSet OF REF ARRAY BYTE OF CharacterDescriptions ¬ ALL[NIL];
BuildSetArrayTable:
PROC [fdTable: FDTable]
RETURNS [SetArrayTable] = {
setArrayTable: SetArrayTable ¬ NEW[SetArrayTableRep];
EachChar: CardTab.EachPairAction = {
[key: CardTab.Key, val: CardTab.Val] RETURNS [quit: BOOL ← FALSE]
set: CharSet = key / 256;
code: BYTE = key MOD 256;
IF setArrayTable[set] = NIL THEN setArrayTable[set] ¬ NEW[ARRAY BYTE OF CharacterDescriptions ¬ ALL[NIL]];
IF setArrayTable[set][code] # NIL THEN ERROR;
setArrayTable[set][code] ¬ NARROW[val];
};
[] ¬ CardTab.Pairs[x: fdTable.cardTab, action: EachChar];
RETURN [setArrayTable];
};
Compatible:
PROC [a, b: CharacterDescriptions]
RETURNS [
BOOL] = {
UNTIL (a =
NIL)
OR (b =
NIL)
OR (a = b)
DO
ac: CharacterDescription = a.first;
bc: CharacterDescription = b.first;
IF a = b THEN RETURN [TRUE];
IF
NOT (
ac.typefaceCell=bc.typefaceCell AND
ac.charToDevice=bc.charToDevice AND
ac.xcCodeDelta=bc.xcCodeDelta AND
ac.bits=bc.bits AND
ac.placement=bc.placement
) THEN RETURN [FALSE];
a ¬ a.rest;
b ¬ b.rest;
ENDLOOP;
RETURN [a = b]
};
RunProc:
TYPE =
PROC [start, end:
CARD, constant:
BOOL];
ForEachRun:
PROC [setArrayTable: SetArrayTable, runProc: RunProc] = {
To qualify as a run, the character descriptions must:
have contiguous, defined character codes
have the same character set
have the same set of charToDeviceTransformations
have the same typefaceCell, xcCodeDelta, amplified, correction, placement
prevCDS: CharacterDescriptions ¬ NIL;
startCode: CARD ¬ CARD.LAST;
finalCode: CARD ¬ 0;
constant: BOOL ¬ FALSE;
FOR set: CharSet
IN CharSet
DO
IF setArrayTable[set] #
NIL
THEN {
t: REF ARRAY BYTE OF CharacterDescriptions ¬ setArrayTable[set];
FOR code:
BYTE
IN
BYTE
DO
cds: CharacterDescriptions ¬ t[code];
IF
NOT Compatible[cds, prevCDS]
THEN {
IF startCode <= finalCode
THEN {
runProc[startCode, finalCode.SUCC, constant];
startCode ¬ CARD.LAST;
finalCode ¬ 0;
prevCDS ¬ NIL;
constant ¬ TRUE;
};
};
IF cds #
NIL
THEN {
card: CARD = set*256+code;
IF prevCDS # NIL AND prevCDS # cds THEN constant ¬ FALSE;
prevCDS ¬ cds;
startCode ¬ MIN[startCode, card];
finalCode ¬ MAX[finalCode, card];
};
ENDLOOP;
IF startCode <= finalCode
THEN {
runProc[startCode, finalCode.SUCC, constant];
startCode ¬ CARD.LAST;
finalCode ¬ 0;
};
};
ENDLOOP;
};
CommonItems: TYPE = REF CommonItemsRep;
CommonItemsRep:
TYPE =
RECORD [
leftExtents: CommonReals,
rightExtents: CommonReals,
descents: CommonReals,
ascents: CommonReals,
escapements: CommonReals,
placements: FactoredSeq,
placementTab: RefTab.Ref,
typefaces: TypefaceCellSeq,
typefaceTab: RefTab.Ref
];
CommonItemsFromSetArrayTable:
PROC [setArrayTable: SetArrayTable]
RETURNS [CommonItems] = {
leftExtentCount: RealTab = CardTab.Create[];
rightExtentCount: RealTab = CardTab.Create[];
descentCount: RealTab = CardTab.Create[];
ascentCount: RealTab = CardTab.Create[];
escapementCount: RealTab = CardTab.Create[];
typefaceTab: RefTab.Ref = RefTab.Create[];
placementTab: RefTab.Ref = RefTab.Create[equal: TransformationEqual, hash: TransformationHash];
result: CommonItems = NEW[CommonItemsRep];
nTypefaceCells: NAT ¬ 0;
UpdateTypefaceTab: RefTab.UpdateAction = {
[found: BOOL, val: RefTab.Val] RETURNS [op: RefTab.UpdateOperation ← none, new: RefTab.Val ← NIL]
IF
NOT found
THEN {
new ¬ NEW[INT ¬ nTypefaceCells];
op ¬ store;
nTypefaceCells ¬ nTypefaceCells + 1;
};
};
EachRun:
PROC [start, end:
CARD, constant:
BOOL] = {
set: CharSet = start / 256;
a: REF ARRAY BYTE OF CharacterDescriptions = setArrayTable[set];
base: CARD = set * 256;
IF constant THEN end ¬ start+1;
FOR c:
CARD
IN [start..end)
DO
FOR tail: CharacterDescriptions ¬ a[c - base], tail.rest
UNTIL tail =
NIL
DO
cd: CharacterDescription = tail.first;
placement: Transformation = NonNilT[cd.placement];
RefTab.Update[x: typefaceTab, key: cd.typefaceCell, action: UpdateTypefaceTab];
[] ¬ RefTab.Insert[x: placementTab, key: placement, val: placement];
CountReal[leftExtentCount, cd.extents.leftExtent];
CountReal[rightExtentCount, cd.extents.rightExtent];
CountReal[descentCount, cd.extents.descent];
CountReal[ascentCount, cd.extents.ascent];
CountReal[escapementCount, cd.escapement.x];
CountReal[escapementCount, cd.escapement.y];
ENDLOOP;
ENDLOOP;
};
StuffTypefaceIndex: RefTab.EachPairAction = {
[key: RefTab.Key, val: RefTab.Val] RETURNS [quit: BOOL ← FALSE]
index: REF INT = NARROW[val];
result.typefaces[index] ¬ NARROW[key];
};
ForEachRun[setArrayTable, EachRun];
result.leftExtents ¬ FindCommonReals[leftExtentCount, extentTolerance, 254];
result.rightExtents ¬ FindCommonReals[rightExtentCount, extentTolerance];
result.descents ¬ FindCommonReals[descentCount, extentTolerance];
result.ascents ¬ FindCommonReals[ascentCount, extentTolerance];
result.escapements ¬ FindCommonReals[escapementCount, escapementTolerance];
result.typefaces ¬ NEW[TypefaceCellSeqRep[nTypefaceCells]];
[] ¬ RefTab.Pairs[x: typefaceTab, action: StuffTypefaceIndex];
result.typefaceTab ¬ typefaceTab;
result.placements ¬ SortTransformations[placementTab];
result.placementTab ¬ RefTab.Create[equal: TransformationEqual, hash: TransformationHash];
FOR i:
NAT
IN [0..result.placements.size)
DO
[] ¬ RefTab.Insert[x: result.placementTab, key: result.placements[i].m, val: NEW[INT ¬ i]];
ENDLOOP;
RETURN [result]
};
GetTypefaceIndex:
PROC [common: CommonItems, typefaceCell: TypefaceCell]
RETURNS [TypefaceIndex] = {
i: REF INT = NARROW[RefTab.Fetch[common.typefaceTab, typefaceCell].val];
RETURN [i]
};
GetPlacementCode:
PROC [common: CommonItems, m: Transformation]
RETURNS [
CARDINAL] = {
i: REF INT = NARROW[RefTab.Fetch[common.placementTab, NonNilT[m]].val];
RETURN [i];
};
FDTypefaceDataFromCanonicalizedFDTable:
PUBLIC
PROC [fdTable: FDTable]
RETURNS [data: Data] = {
nt: NAT = fdTable.charToDeviceTransformations.size;
setArrayTable: SetArrayTable = BuildSetArrayTable[fdTable];
common: CommonItems = CommonItemsFromSetArrayTable[setArrayTable];
lastRuns: CharRuns ¬ NIL;
charInfoRunTab: RefTab.Ref = RefTab.Create[equal: CharInfoRunEqual, hash: CharInfoRunHash];
nCharInfoRuns: INT ¬ 0;
StuffCharInfoRunSeq: RefTab.EachPairAction = {
[key: RefTab.Key, val: RefTab.Val] RETURNS [quit: BOOL ← FALSE]
charInfoRun: CharInfoRun = NARROW[key];
refInt: REF INT = NARROW[val];
data.charInfoRunSeq[refInt] ¬ charInfoRun;
};
EachRun:
PROC [start, end:
CARD, constant:
BOOL] = {
set: CharSet = start / 256;
a: REF ARRAY BYTE OF CharacterDescriptions = setArrayTable[set];
base: CARD = set * 256;
charRunCell: CharRuns = NEW[CharRunsRep[nt]];
charInfoRunSeq: CharInfoRunSeq = NEW[CharInfoRunSeqRep[nt]]; -- scratch storage
charRunCell.bc ¬ start-base;
charRunCell.ec ¬ end-1-base;
IF data.setTable[set] =
NIL
THEN data.setTable[set] ¬ lastRuns ¬ charRunCell
ELSE lastRuns ¬ lastRuns.link ¬ charRunCell; -- append to end of run list
IF constant
THEN {
i: NAT ¬ 0;
FOR tail: CharacterDescriptions ¬ a[start - base], tail.rest
UNTIL tail =
NIL
DO
cd: CharacterDescription = tail.first;
charInfoRun: REF CharInfoRunRep ¬ NEW[CharInfoRunRep[1]];
UNTIL cd.charToDevice = fdTable.charToDeviceTransformations[i] DO i ¬ i + 1 ENDLOOP;
charRunCell[i].typefaceIndex ¬ GetTypefaceIndex[common, cd.typefaceCell];
charInfoRunSeq[i] ¬ charInfoRun;
charInfoRun.xcCodeDelta ¬ cd.xcCodeDelta;
charInfoRun.bits ¬ cd.bits;
charInfoRun.placementCode ¬ GetPlacementCode[common, cd.placement];
TRUSTED {charInfoRun[0] ¬ CharInfoFromCD[cd]};
ENDLOOP;
}
ELSE {
FOR c:
CARD
IN [start..end)
DO
i: NAT ¬ 0;
FOR tail: CharacterDescriptions ¬ a[c - base], tail.rest
UNTIL tail =
NIL
DO
cd: CharacterDescription = tail.first;
charInfoSeq: REF CharInfoRunRep ¬ NIL;
UNTIL cd.charToDevice = fdTable.charToDeviceTransformations[i] DO i ¬ i + 1 ENDLOOP;
IF charInfoRunSeq[i] =
NIL
THEN {
charRunCell[i].typefaceIndex ¬ GetTypefaceIndex[common, cd.typefaceCell];
charInfoRunSeq[i] ¬ charInfoSeq ¬ NEW[CharInfoRunRep[end-start]];
charInfoSeq.xcCodeDelta ¬ cd.xcCodeDelta;
charInfoSeq.bits ¬ cd.bits;
charInfoSeq.placementCode ¬ GetPlacementCode[common, cd.placement];
}
ELSE charInfoSeq ¬ charInfoRunSeq[i];
TRUSTED { charInfoSeq[c - start] ¬ CharInfoFromCD[cd] };
ENDLOOP;
ENDLOOP;
};
FOR i:
NAT
IN [0..nt)
DO
IF charInfoRunSeq[i] #
NIL
THEN {
NoteCharInfoRun: RefTab.UpdateAction = {
[found: BOOL, val: RefTab.Val] RETURNS [op: RefTab.UpdateOperation ← none, new: RefTab.Val ← NIL]
IF
NOT found
THEN {
op ¬ store;
new ¬ NEW[INT ¬ nCharInfoRuns];
nCharInfoRuns ¬ nCharInfoRuns + 1;
};
};
RefTab.Update[x: charInfoRunTab, key: charInfoRunSeq[i], action: NoteCharInfoRun];
};
ENDLOOP;
FOR i:
NAT
IN [0..nt)
DO
IF charInfoRunSeq[i] #
NIL
THEN {
charRunCell[0].typefaceIndex ¬ charRunCell[i].typefaceIndex;
charInfoRunSeq[0] ¬ charInfoRunSeq[i];
EXIT;
};
ENDLOOP;
IF charInfoRunSeq[0] = NIL THEN ERROR; -- oops, this should not have been a run.
FOR i:
NAT
IN [0..nt)
DO
IF charInfoRunSeq[i] =
NIL
THEN {
charRunCell[i].typefaceIndex ¬ charRunCell[0].typefaceIndex;
charInfoRunSeq[i] ¬ charInfoRunSeq[0];
};
ENDLOOP;
FOR i:
NAT
IN [0..nt)
DO
refInt: REF INT = NARROW[RefTab.Fetch[charInfoRunTab, charInfoRunSeq[i]].val];
charRunCell[i].charInfoRunIndex ¬ refInt;
ENDLOOP;
};
overflowList: LIST OF VerboseCharInfo ¬ NIL;
nOver: NAT ¬ 0;
CharInfoFromCD:
PROC [
cd: CharacterDescription]
RETURNS [CharInfo] = {
codeLeftExtent: INT = GetRealCode[common.leftExtents, cd.extents.leftExtent];
codeRightExtent: INT = GetRealCode[common.rightExtents, cd.extents.rightExtent];
codeDescent: INT = GetRealCode[common.descents, cd.extents.descent];
codeAscent: INT = GetRealCode[common.ascents, cd.extents.ascent];
codeEscapementX: INT = GetRealCode[common.escapements, cd.escapement.x];
codeEscapementY: INT = GetRealCode[common.escapements, cd.escapement.y];
data.fontExtents.leftExtent ¬ MAX[data.fontExtents.leftExtent, cd.extents.leftExtent];
data.fontExtents.rightExtent ¬ MAX[data.fontExtents.rightExtent, cd.extents.rightExtent];
data.fontExtents.descent ¬ MAX[data.fontExtents.descent, cd.extents.descent];
data.fontExtents.ascent ¬ MAX[data.fontExtents.ascent, cd.extents.ascent];
IF
MIN[codeEscapementY, codeEscapementX, codeLeftExtent, codeRightExtent, codeDescent, codeAscent] >= 0
AND cd.propList =
NIL
THEN {
RETURN [[short[
leftExtent: codeLeftExtent,
rightExtent: codeRightExtent,
descent: codeDescent,
ascent: codeAscent,
escapementX: codeEscapementX,
escapementY: codeEscapementY]]]
}
ELSE {
overflowIndex: OverflowIndex = nOver;
vc: VerboseCharInfo =
NEW[VerboseCharInfoRep ¬ [
extents: cd.extents,
escapement: cd.escapement,
propList: cd.propList
]];
overflowList ¬ CONS[vc, overflowList];
nOver ¬ nOver+1;
RETURN [[verbose[overflowIndex]]]
};
};
data ¬ NEW[DataRep];
data.fontExtents ¬ [-10000.0, -10000.0, -10000.0, -10000.0];
ForEachRun[setArrayTable, EachRun];
data.charInfoRunSeq ¬ NEW[CharInfoRunSeqRep[nCharInfoRuns]];
[] ¬ RefTab.Pairs[x: charInfoRunTab, action: StuffCharInfoRunSeq];
data.charToDeviceTransformations ¬ fdTable.charToDeviceTransformations;
data.commonLeftExtents ¬ common.leftExtents.realForCode;
data.commonRightExtents ¬ common.rightExtents.realForCode;
data.commonDescents ¬ common.descents.realForCode;
data.commonAscents ¬ common.ascents.realForCode;
data.commonEscapements ¬ common.escapements.realForCode;
data.typefaceCellSeq ¬ common.typefaces;
data.placementTransformations ¬ NEW[TransformationSeqRep[common.placements.size]];
FOR i:
NAT
IN [0..common.placements.size)
DO
data.placementTransformations[i] ¬ common.placements[i].m;
ENDLOOP;
data.propList ¬ fdTable.propList;
data.overflowCharInfoSeq ¬ NEW[OverflowCharInfoSeqRep[nOver]];
FOR i: OverflowIndex
DECREASING
IN [0..nOver)
DO
data.overflowCharInfoSeq[i] ¬ overflowList.first;
overflowList ¬ overflowList.rest;
ENDLOOP;
IF data.fontExtents.ascent < -data.fontExtents.descent THEN data.fontExtents ¬ [0.0, 0.0, 0.0, 0.0];
};
RawHash:
UNSAFE
PROC [p:
LONG
POINTER
TO
CARDINAL, bytes:
INT]
RETURNS [hash:
CARDINAL ¬ 31415] =
UNCHECKED {
IF p #
NIL
THEN
WHILE (bytes ¬ bytes -
BYTES[
WORD]) >= 0
DO
hash ¬ hash + hash*128 + p;
p ¬ p + SIZE[WORD];
ENDLOOP;
};
CharacterDescriptionHash: RefTab.HashProc =
TRUSTED {
[key: RefTab.Key] RETURNS [CARDINAL]
a: CharacterDescription = NARROW[key];
hash: CARDINAL = RawHash[LOOPHOLE[a], BYTES[CharacterDescriptionRep]];
RETURN [hash]
};
CharacterDescriptionEqual: RefTab.EqualProc = {
-- [key1, key2: Key] RETURNS [BOOL]
a1: CharacterDescription = NARROW[key1];
a2: CharacterDescription = NARROW[key2];
RETURN [a1 = a2]
};
CharacterDescriptionsHash: RefTab.HashProc =
TRUSTED {
[key: RefTab.Key] RETURNS [CARDINAL]
c: CharacterDescriptions = NARROW[key];
a: ARRAY [0..2) OF REF ¬ [c.first, c.rest];
p: LONG POINTER TO ARRAY [0..2) OF REF = @a;
hash: CARDINAL = RawHash[LOOPHOLE[p], BYTES[ARRAY [0..2) OF REF]];
RETURN [hash]
};
CharacterDescriptionsEqual: RefTab.EqualProc = {
-- [key1, key2: Key] RETURNS [BOOL]
a1: CharacterDescriptions = NARROW[key1];
a2: CharacterDescriptions = NARROW[key2];
RETURN [a1 = a2]
};
TransformationHash: RefTab.HashProc =
TRUSTED {
[key: RefTab.Key] RETURNS [CARDINAL]
m: Transformation = NARROW[key];
IF m =
NIL
THEN RETURN [13]
ELSE {
a: ARRAY [0..6) OF REAL ¬ [ABS[m.a], ABS[m.b], ABS[m.c], ABS[m.d], ABS[m.e], ABS[m.f]];
p: LONG POINTER TO ARRAY [0..6) OF REAL = @a;
hash: CARDINAL = RawHash[LOOPHOLE[p], BYTES[ARRAY [0..6) OF REAL]];
RETURN [hash]
};
};
TransformationEqual: RefTab.EqualProc = {
-- [key1, key2: Key] RETURNS [BOOL]
a1: Transformation = NARROW[key1];
a2: Transformation = NARROW[key2];
RETURN [(a1=NIL AND a2=NIL) OR ImagerTransformation.Equal[a1, a2]]
};
CharInfoRunHash: RefTab.HashProc =
TRUSTED {
[key: RefTab.Key] RETURNS [CARDINAL]
charInfoRun: CharInfoRun = NARROW[key];
hash: CARDINAL = RawHash[LOOPHOLE[charInfoRun], BYTES[CharInfoRunRep[charInfoRun.size]]];
RETURN [hash]
};
CharInfoRunEqual: RefTab.EqualProc =
TRUSTED {
-- [key1, key2: Key] RETURNS [BOOL]
a1: CharInfoRun = NARROW[key1];
a2: CharInfoRun = NARROW[key2];
IF
NOT (
a1.size = a2.size AND
a1.xcCodeDelta = a2.xcCodeDelta AND
a1.bits = a2.bits AND
a1.placementCode = a2.placementCode
) THEN RETURN [FALSE];
FOR i:
NAT
IN [0..a1.size)
DO
c1: CharInfo = a1[i];
c2: CharInfo = a2[i];
Golly, these variant records are ugly!
WITH c1: c1
SELECT
FROM
short => {
WITH c2: c2
SELECT
FROM
short => {
IF c1 # c2 THEN RETURN [FALSE];
};
ENDCASE => RETURN [FALSE];
};
verbose => {
WITH c2: c2
SELECT
FROM
verbose => {
IF c1 # c2 THEN RETURN [FALSE];
};
ENDCASE => RETURN [FALSE];
};
ENDCASE => ERROR;
ENDLOOP;
RETURN [TRUE];
};
MapCharacterDescriptions:
PROC [fdTable: FDTable, proc:
PROC [cd: CharacterDescription]
RETURNS [CharacterDescription]] = {
EachPair: CardTab.EachPairAction = {
[key: CardTab.Key, val: CardTab.Val] RETURNS [quit: BOOL ← FALSE]
FOR tail: CharacterDescriptions ¬
NARROW[val], tail.rest
UNTIL tail =
NIL
DO
tail.first ¬ proc[tail.first];
ENDLOOP;
};
[] ¬ CardTab.Pairs[x: fdTable.cardTab, action: EachPair];
};
identity: Transformation = ImagerTransformation.Scale[1];
NonNilT:
PROC [m: Transformation]
RETURNS [Transformation] = {
RETURN [IF m = NIL THEN identity ELSE m]
};
Canonicalize:
PUBLIC
PROC [fdTable: FDTable] = {
mTab: RefTab.Ref = RefTab.Create[equal: TransformationEqual, hash: TransformationHash];
charToDeviceTab: RefTab.Ref = RefTab.Create[];
cdTab: RefTab.Ref = RefTab.Create[equal: CharacterDescriptionEqual, hash: CharacterDescriptionHash];
tfTab: SymTab.Ref = SymTab.Create[case: FALSE];
CanonicalizeTypefaceCell:
PROC [typefaceCell: TypefaceCell]
RETURNS [TypefaceCell] = {
UpdateTF: SymTab.UpdateAction = {
[found: BOOL, val: SymTab.Val] RETURNS [op: SymTab.UpdateOperation ← none, new: SymTab.Val ← NIL]
IF
NOT found
THEN RETURN [store, typefaceCell]
ELSE {
canon: TypefaceCell = NARROW[val];
IF canon = typefaceCell THEN RETURN;
IF canon.typeface =
NIL
AND typefaceCell.typeface #
NIL
THEN {
canon ¬ typefaceCell;
};
typefaceCell ¬ canon;
};
};
IF typefaceCell.typeface #
NIL
THEN {
typefaceCell.fontName ¬ typefaceCell.typeface.name;
typefaceCell.createDate ¬ typefaceCell.typeface.created;
typefaceCell.type ¬ typefaceCell.typeface.class.type;
};
IF typefaceCell.fontName = NIL THEN ERROR; -- can't do anonymous fonts
SymTab.Update[x: tfTab, key: typefaceCell.fontName, action: UpdateTF];
RETURN [typefaceCell];
};
CanonicalizeTransformation:
PROC [m: Transformation]
RETURNS [Transformation] = {
UpdateTransformation: RefTab.UpdateAction = {
[found: BOOL, val: RefTab.Val] RETURNS [op: RefTab.UpdateOperation ← none, new: RefTab.Val ← NIL]
IF found THEN m ¬ NARROW[val] ELSE RETURN [store, m]
};
m ¬ NonNilT[m];
RefTab.Update[x: mTab, key: m, action: UpdateTransformation];
RETURN [m]
};
CanonicalizeCharacterDescription:
PROC [cd: CharacterDescription]
RETURNS [CharacterDescription] = {
UpdateCD: RefTab.UpdateAction = {
[found: BOOL, val: RefTab.Val] RETURNS [op: RefTab.UpdateOperation ← none, new: RefTab.Val ← NIL]
IF found
THEN { cd ¬ NARROW[val] }
ELSE RETURN [store, cd];
};
cd.charToDevice ¬ CanonicalizeTransformation[cd.charToDevice];
[] ¬ RefTab.Insert[charToDeviceTab, cd.charToDevice, cd.charToDevice];
cd.typefaceCell ¬ CanonicalizeTypefaceCell[cd.typefaceCell];
cd.placement ¬ CanonicalizeTransformation[IF cd.placement = NIL THEN identity ELSE cd.placement];
RefTab.Update[x: cdTab, key: cd, action: UpdateCD];
RETURN [cd];
};
cdsTab: RefTab.Ref = RefTab.Create[equal: CharacterDescriptionsEqual, hash: CharacterDescriptionsHash];
CanonicalizeCharacterDescriptions:
PROC [cds: CharacterDescriptions]
RETURNS [CharacterDescriptions] = {
UpdateCDS: RefTab.UpdateAction = {
[found: BOOL, val: RefTab.Val] RETURNS [op: RefTab.UpdateOperation ← none, new: RefTab.Val ← NIL]
IF found THEN cds ¬ NARROW[val] ELSE RETURN [store, cds]
};
IF cds = NIL THEN RETURN [NIL];
cds.rest ¬ CanonicalizeCharacterDescriptions[cds.rest];
RefTab.Update[x: cdsTab, key: cds, action: UpdateCDS];
RETURN [cds];
};
ftSeq: FactoredSeq ¬ NIL;
TransformationIndex:
PROC [m: Transformation]
RETURNS [
NAT] = {
FOR i:
NAT
IN [0..ftSeq.size)
DO
IF ftSeq[i].m = m THEN RETURN [i];
ENDLOOP;
ERROR;
};
CDCellSeqRep: TYPE = RECORD[SEQUENCE size: NAT OF CharacterDescriptions];
cdCells: REF CDCellSeqRep ¬ NIL;
CDsInOrder:
PROC [cds: CharacterDescriptions]
RETURNS [
BOOL] = {
i: NAT ¬ 0;
FOR tail: CharacterDescriptions ¬ cds, tail.rest
UNTIL tail =
NIL
DO
DO
IF i >= ftSeq.size THEN RETURN [FALSE];
IF tail.first.charToDevice = ftSeq[i].m THEN {i ¬ i + 1; EXIT};
i ¬ i + 1;
ENDLOOP;
ENDLOOP;
RETURN [TRUE]
};
SortCharacterDescriptions: CardTab.EachPairAction = {
[key: CardTab.Key, val: CardTab.Val] RETURNS [quit: BOOL ← FALSE]
cds: CharacterDescriptions ¬ NARROW[val];
result: CharacterDescriptions ¬ NIL;
IF CDsInOrder[cds] THEN RETURN;
FOR i:
NAT
IN [0..cdCells.size)
DO
cdCells[i] ¬ NIL;
ENDLOOP;
FOR tail: CharacterDescriptions ¬ cds, tail.rest
UNTIL tail =
NIL
DO
j: NAT = TransformationIndex[tail.first.charToDevice];
cdCells[j] ¬ NEW[CharacterDescriptionCell ¬ [first: tail.first, rest: cdCells[j]]]; -- don't reuse list cell; it may be shared!
ENDLOOP;
FOR i:
NAT
DECREASING
IN [0..cdCells.size)
DO
cell: CharacterDescriptions ¬ cdCells[i];
IF cell #
NIL
THEN {
WHILE cell.rest #
NIL
AND cell.first = cell.rest.first
DO
-- Exact duplicates are OK
cell ¬ cell.rest;
ENDLOOP;
IF cell.rest #
NIL
THEN {
tieBreaker: CharacterDescription ¬ SIGNAL Conflict[key, cell];
cell ¬ NEW[CharacterDescriptionCell ¬ [first: tieBreaker, rest: NIL]];
IF cell.first.charToDevice # ftSeq[i].m THEN ERROR;
};
cell.rest ¬ result;
result ¬ cell;
};
ENDLOOP;
[] ¬ CardTab.Store[x: fdTable.cardTab, key: key, val: result];
};
CanonicalizeEachCharacterDescriptionList: CardTab.EachPairAction = {
[key: CardTab.Key, val: CardTab.Val] RETURNS [quit: BOOL ← FALSE]
cds: CharacterDescriptions = NARROW[val];
IF
NOT RefTab.Fetch[x: cdsTab, key: cds].found
THEN {
canon: CharacterDescriptions = CanonicalizeCharacterDescriptions[cds];
IF canon # cds THEN [] ¬ CardTab.Store[x: fdTable.cardTab, key: key, val: canon];
};
};
MapCharacterDescriptions[fdTable, CanonicalizeCharacterDescription];
ftSeq ¬ SortTransformations[charToDeviceTab];
cdCells ¬ NEW[CDCellSeqRep[ftSeq.size]];
[] ¬ CardTab.Pairs[x: fdTable.cardTab, action: SortCharacterDescriptions];
[] ¬ CardTab.Pairs[x: fdTable.cardTab, action: CanonicalizeEachCharacterDescriptionList];
fdTable.charToDeviceTransformations ¬ NEW[TransformationSeqRep[ftSeq.size]];
FOR i:
NAT
IN [0..ftSeq.size)
DO
fdTable.charToDeviceTransformations[i] ¬ ftSeq[i].m;
ENDLOOP;
};
Factored: TYPE ~ REF FactoredRep;
FactoredRep:
TYPE ~
RECORD [
f: ImagerTransformation.FactoredTransformation,
m: ImagerTransformation.Transformation
];
FactoredSeq: TYPE ~ REF FactoredSeqRep;
FactoredSeqRep:
TYPE ~
RECORD [
SEQUENCE size:
NAT
OF Factored];
nullFactored: Factored =
NEW [FactoredRep ¬ [ImagerTransformation.Factor[identity],
NIL]];
SortTransformations:
PROC [mTab: RefTab.Ref]
RETURNS [FactoredSeq] = {
n: NAT = RefTab.GetSize[mTab];
ftSeq: FactoredSeq ¬ NEW[FactoredSeqRep[n]];
len: NAT ¬ 0;
SortedInsert: RefTab.EachPairAction = {
[key: RefTab.Key, val: RefTab.Val] RETURNS [quit: BOOL ← FALSE]
m: Transformation ¬ NARROW[val];
f: Factored ¬ IF m = NIL THEN nullFactored ELSE NEW [FactoredRep ¬ [ImagerTransformation.Factor[m], m]];
FOR i:
NAT
IN [0..len)
DO
t: Factored ¬ ftSeq[i];
SELECT FactoredCompare[f, t]
FROM
less => {ftSeq[i] ¬ f; f ¬ t};
equal => Debug[f, t]; -- should be unique; else CanonicalizeTransformation is broken, or perhaps floating-point funnies got us. Treat like greater for production, though, since we don't want to die here.
greater => NULL;
ENDCASE => ERROR;
ENDLOOP;
ftSeq[len] ¬ f;
len ¬ len + 1;
};
[] ¬ RefTab.Pairs[x: mTab, action: SortedInsert];
RETURN [ftSeq]
};
Debug:
PROC [a, b:
REF] ~ {
ENABLE
ABORTED =>
CONTINUE;
ERROR };
FactoredCompare:
PROC [b, a: Factored]
RETURNS [c: Basics.Comparison ¬ less] = {
Defines the sort-order for charToDeviceTransformations.
Note the parameters are [b, a] to end up sorting by decreasing size.
Differ:
PROC [s, t:
REAL]
RETURNS [
BOOL] =
INLINE {
c ¬ CompareReal[s, t];
RETURN [c # equal]
};
IF a = NIL THEN RETURN [IF b = NIL THEN equal ELSE greater];
IF b = NIL THEN RETURN [less];
IF Differ[
MAX[
ABS[a.f.s.x],
ABS[a.f.s.y]],
MAX[
ABS[b.f.s.x],
ABS[b.f.s.y]]]
OR
Differ[a.f.r1+a.f.r2, b.f.r1+b.f.r2] OR
Differ[a.f.s.x, b.f.s.x] OR
Differ[a.f.s.y, b.f.s.y] OR
Differ[a.f.r1, b.f.r1] OR
Differ[a.f.r2, b.f.r2] OR
Differ[a.f.t.x, b.f.t.x] OR
Differ[a.f.t.y, b.f.t.y] THEN RETURN;
IF ImagerTransformation.Equal[a.m, b.m] THEN RETURN[equal];
RETURN [greater] -- Note: in this case, the transformations are so close to equal that the factored representations are the same, due to floating-point fuzz. We return "greater" to disambiguate the sort.
};
Output
Write:
PUBLIC
PROC [fdTable: FDTable, filename: Rope.
ROPE] = {
Canonicalize[fdTable];
WriteFDTypefaceData[FDTypefaceDataFromCanonicalizedFDTable[fdTable], filename];
};
WriteFDTypefaceData:
PUBLIC
PROC [data: ImagerFDTypeface.Data, filename: Rope.
ROPE] = {
stream: IO.STREAM = ImagerSys.OpenOutputFile[fileName: filename];
WriteFDTypefaceDataToStream[data, stream];
IO.Close[stream];
};
WriteFDTypefaceData
ToStream:
PROC [data: Data, stream:
IO.
STREAM] = {
nSets: NAT ¬ 0;
PutCARD32[stream, password];
Begin[stream];
PutExtents[stream, data.fontExtents];
End[stream];
PutRealSeq[stream, data.commonLeftExtents];
PutRealSeq[stream, data.commonRightExtents];
PutRealSeq[stream, data.commonDescents];
PutRealSeq[stream, data.commonAscents];
PutRealSeq[stream, data.commonEscapements];
PutTransformationSeq[stream, data.charToDeviceTransformations];
PutTypefaceCellSeq[stream, data.typefaceCellSeq];
PutTransformationSeq[stream, data.placementTransformations];
PutCharInfoRunSeq[stream, data.charInfoRunSeq];
PutOverflowCharInfoSeq[stream, data.overflowCharInfoSeq];
PutPropList[stream, data.propList];
FOR c: CharSet
IN CharSet
DO
charRuns: CharRuns = data.setTable[c];
IF charRuns #
NIL
THEN {
nSets ¬ nSets+1;
};
ENDLOOP;
PutCount[stream, nSets];
FOR c: CharSet
IN CharSet
DO
charRuns: CharRuns = data.setTable[c];
IF charRuns #
NIL
THEN {
PutCount[stream, c];
Begin[stream];
PutCharRuns[stream, charRuns];
End[stream];
};
ENDLOOP;
};
PutExtents:
PROC [stream:
IO.
STREAM, extents: ImagerBox.Extents] = {
PutREAL[stream, extents.leftExtent];
PutREAL[stream, extents.rightExtent];
PutREAL[stream, extents.descent];
PutREAL[stream, extents.ascent];
};
PutRealSeq:
PROC [stream:
IO.
STREAM, s: RealSeq] = {
PutCount[stream, s.size];
FOR i:
NAT
IN [0..s.size)
DO
Begin[stream];
PutREAL[stream, s[i]];
End[stream];
ENDLOOP;
};
PutTransformationSeq:
PROC [stream:
IO.
STREAM, s: TransformationSeq] = {
PutCount[stream, s.size];
FOR i:
NAT
IN [0..s.size)
DO
Begin[stream];
PutTransformation[stream, s[i]];
End[stream];
ENDLOOP;
};
PutTransformation:
PROC [stream:
IO.
STREAM, m: Transformation] = {
IF m =
NIL
THEN PutCount[stream, 0]
ELSE {
PutCount[stream, 6];
PutREAL[stream, m.a];
PutREAL[stream, m.b];
PutREAL[stream, m.c];
PutREAL[stream, m.d];
PutREAL[stream, m.e];
PutREAL[stream, m.f];
};
};
PutTypefaceCellSeq:
PROC [stream:
IO.
STREAM, s: TypefaceCellSeq] = {
PutCount[stream, s.size];
FOR i:
NAT
IN [0..s.size)
DO
Begin[stream];
PutTypefaceCell[stream, s[i]];
End[stream];
ENDLOOP;
};
PutCharInfoRunSeq:
PROC [stream:
IO.
STREAM, s: CharInfoRunSeq] = {
PutCount[stream, s.size];
FOR i:
NAT
IN [0..s.size)
DO
Begin[stream];
PutCharInfoRun[stream, s[i]];
End[stream];
ENDLOOP;
};
PutTypefaceCell:
PROC [stream:
IO.
STREAM, s: TypefaceCell] = {
PutCARD32[stream, LOOPHOLE[s.createDate]];
PutIdentifier[stream, s.fontName];
PutIdentifier[stream, Atom.GetPName[s.type]];
};
PutOverflowCharInfoSeq:
PROC [stream:
IO.
STREAM, s: OverflowCharInfoSeq] = {
PutCount[stream, s.size];
FOR i:
NAT
IN [0..s.size)
DO
Begin[stream];
PutVerboseCharInfo[stream, s[i]];
End[stream];
ENDLOOP;
};
PutVerboseCharInfo:
PROC [stream:
IO.
STREAM, s: VerboseCharInfo] = {
PutExtents[stream, s.extents];
PutVEC[stream, s.escapement];
PutPropList[stream, s.propList];
};
PutVEC:
PROC [stream:
IO.
STREAM, v: Vector2.
VEC] = {
PutREAL[stream, v.x];
PutREAL[stream, v.y];
};
PutPropList:
PROC [stream:
IO.
STREAM, props: Prop.PropList] = {
IF props =
NIL
THEN PutCount[stream, 0]
ELSE ERROR; -- unimplemented
};
PutCharInfoRun:
PROC [stream:
IO.
STREAM, charInfoRun: CharInfoRun] = {
PutInteger[stream, charInfoRun.xcCodeDelta];
PutBYTE[stream, ORD[charInfoRun.bits.correction]*2+ORD[charInfoRun.bits.amplified]];
PutCount[stream, charInfoRun.placementCode];
PutCount[stream, charInfoRun.size];
FOR i:
NAT
IN [0..charInfoRun
.size)
DO
Begin[stream];
WITH charInfoRun[i]
SELECT
FROM
info: CharInfo.short => {
PutBYTE[stream, info.leftExtent]; -- cannot be 255, to discriminate from verbose
PutBYTE[stream, info.rightExtent];
PutBYTE[stream, info.descent];
PutBYTE[stream, info.ascent];
PutBYTE[stream, info.escapementX];
PutBYTE[stream, info.escapementY];
};
info: CharInfo.verbose => {
PutBYTE[stream, 255]; -- CharInfo.short.leftExtent is never 255
PutCount[stream, info.overflowIndex];
};
ENDCASE => ERROR;
End[stream];
ENDLOOP;
};
PutCharRuns:
PROC [stream:
IO.
STREAM, charRuns: CharRuns] = {
count: CARD ¬ 0;
FOR tail: CharRuns ¬ charRuns, tail.link
UNTIL tail =
NIL
DO
count ¬ count + 1;
ENDLOOP;
PutCount[stream, count];
FOR this: CharRuns ¬ charRuns, this.link
UNTIL this =
NIL
DO
Begin[stream];
PutBYTE[stream, this.bc];
PutBYTE[stream, this.ec];
FOR i:
NAT
IN [0..this.nt)
DO
charRunEntry: CharRunEntry = this[i];
Begin[stream];
PutCount[stream, charRunEntry.typefaceIndex];
PutCount[stream, charRunEntry.charInfoRunIndex];
End[stream];
ENDLOOP;
End[stream];
ENDLOOP;
};