<<>> <> <> <> <> <> <<>> 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]; ImagerFDBuildImpl: CEDAR PROGRAM IMPORTS ImagerFDTypeface, Atom, Basics, CardTab, ImagerTransformation, ImagerSys, IO, SymTab, List, Real, Rope, RefTab EXPORTS ImagerFDBuild ~ BEGIN OPEN ImagerFDBuild, ImagerFDTypeface; ROPE: TYPE ~ Rope.ROPE; Transformation: TYPE ~ ImagerTransformation.Transformation; Conflict: PUBLIC SIGNAL [charCode: CARD, cds: CharacterDescriptions] RETURNS [CharacterDescription] = CODE; <> CompareReal: PROC [a, b: REAL] RETURNS [Basics.Comparison] = { RETURN [SELECT TRUE FROM a < b => less, a = b => equal, ENDCASE => greater] }; <> extentTolerance: REAL Ź 0.02; -- error allowed for extents (fraction of em) escapementTolerance: REAL Ź 1.0/10000.0; -- error allowed for escapements (fraction of em) Create: PUBLIC PROC RETURNS [FDTable] = { RETURN [NEW[FDTableRep Ź [cardTab: CardTab.Create[]]]] }; Insert: PUBLIC PROC [fdTable: FDTable, code: CARD, cd: CharacterDescriptionRep] = { Inner: CardTab.UpdateAction = { <<[found: BOOL, val: CardTab.Val] RETURNS [op: CardTab.UpdateOperation _ none, new: CardTab.Val _ NIL]>> newCDs: CharacterDescriptions = NEW[CharacterDescriptionCell Ź [first: NEW[CharacterDescriptionRep Ź cd], rest: NARROW[val]]]; RETURN [store, newCDs] }; CardTab.Update[x: fdTable.cardTab, key: code, action: Inner]; fdTable.charToDeviceTransformations Ź NIL; }; FetchList: PUBLIC PROC [fdTable: FDTable, code: CARD] RETURNS [CharacterDescriptions] = { RETURN [NARROW[CardTab.Fetch[fdTable.cardTab, code].val]] }; StoreList: PUBLIC PROC [fdTable: FDTable, code: CARD, cds: CharacterDescriptions] = { [] Ź CardTab.Store[x: fdTable.cardTab, key: code, val: cds]; fdTable.charToDeviceTransformations Ź NIL; }; <> 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 { <> 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] = { <> <> <> <> <> 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]; <> 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] = { <> <> 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. }; <> Read: PUBLIC PROC [filename: Rope.ROPE] RETURNS [fdTable: FDTable] = { stream: IO.STREAM = ImagerSys.OpenInputFile[fileName: filename]; data: Data = FromStream[stream]; fdTable Ź FDTableFromFDTypefaceData[data]; IO.Close[stream]; }; FDTableFromFDTypefaceData: PUBLIC PROC [data: Data] RETURNS [FDTable] = { fdTable: FDTable = Create[]; FOR set: CharSet IN CharSet DO FOR charRuns: CharRuns Ź data.setTable[set], charRuns.link UNTIL charRuns = NIL DO offset: CARD = set * 256; FOR tc: NAT IN [0..charRuns.nt) DO charRunEntry: CharRunEntry = charRuns[tc]; charInfoRun: CharInfoRun = data.charInfoRunSeq[charRunEntry.charInfoRunIndex]; cdr: CharacterDescriptionRep Ź [ typefaceCell: data.typefaceCellSeq[charRunEntry.typefaceIndex], charToDevice: data.charToDeviceTransformations[tc], xcCodeDelta: charInfoRun.xcCodeDelta, bits: charInfoRun.bits, escapement: [0, 0], extents: [0, 0, 0, 0], placement: data.placementTransformations[charInfoRun.placementCode] ]; delta: NAT = IF charInfoRun.size = 1 THEN 0 ELSE 1; i: NAT Ź 0; FOR code: BYTE IN [charRuns.bc..charRuns.ec] DO WITH charInfoRun[i] SELECT FROM info: CharInfo.short => { cdr.escapement.x Ź data.commonEscapements[info.escapementX]; cdr.escapement.y Ź data.commonEscapements[info.escapementY]; cdr.extents.leftExtent Ź data.commonLeftExtents[info.leftExtent]; cdr.extents.rightExtent Ź data.commonRightExtents[info.rightExtent]; cdr.extents.descent Ź data.commonDescents[info.descent]; cdr.extents.ascent Ź data.commonAscents[info.ascent]; cdr.propList Ź NIL; }; info: CharInfo.verbose => { v: VerboseCharInfo = data.overflowCharInfoSeq[info.overflowIndex]; cdr.escapement Ź v.escapement; cdr.extents Ź v.extents; cdr.propList Ź v.propList; }; ENDCASE => ERROR; Insert[fdTable, offset+code, cdr]; i Ź i + delta; ENDLOOP; ENDLOOP; ENDLOOP; ENDLOOP; RETURN [fdTable] }; <> 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]; }; WriteFDTypefaceDataToStream: 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; }; <> Begin: PROC [stream: IO.STREAM] = INLINE {}; End: PROC [stream: IO.STREAM] = INLINE {}; PutCARD32: PROC [stream: IO.STREAM, card: CARD32] = { <> ln: Basics.LongNumber = [lc[card]]; IO.PutByte[stream, ln.hh]; IO.PutByte[stream, ln.hl]; IO.PutByte[stream, ln.lh]; IO.PutByte[stream, ln.ll]; }; PutBYTE: PROC [stream: IO.STREAM, byte: BYTE] = { IO.PutByte[stream, byte]; }; PutCount: PROC [stream: IO.STREAM, count: CARD] = { <> <> <> <> c: ARRAY [0..5) OF BYTE Ź ALL[0]; k: NAT Ź 0; i: CARD Ź count; DO c[k] Ź (i MOD 128) + 128; k Ź k + 1; i Ź i / 128; IF i = 0 THEN EXIT; ENDLOOP; c[0] Ź c[0]-128; UNTIL k = 0 DO k Ź k - 1; IO.PutByte[stream, c[k]]; ENDLOOP; }; PutIdentifier: PROC [stream: IO.STREAM, s: ROPE] = { PutCount[stream, Rope.Size[s]]; IO.PutRope[stream, s]; }; PutInteger: PROC [stream: IO.STREAM, int: INT] = { <> <> <<(i.e., uses the low-order bit to indicate the sign)>> PutCount[stream, IF int < 0 THEN CARD[CARD[-int]*2-1] ELSE CARD[int]*2]; }; largestFlonumFraction: REAL Ź LargestFlonumFraction[]; LargestFlonumFraction: PROC RETURNS [REAL] ~ INLINE { a: REAL Ź 0.5; FOR i: NAT IN [0..1000) DO b: REAL ~ a+a+0.5; IF b = REAL[Real.Fix[b]] THEN RETURN [a]; a Ź b; ENDLOOP; ERROR; -- this doesn't act like floating point! }; PutREAL: PROC [stream: IO.STREAM, real: REAL] = { <> neg: BOOL = real < 0; exponent: INT Ź 0; significand: INT; real Ź ABS[real]; WHILE real > largestFlonumFraction DO real Ź Real.FScale[real, -1]; exponent Ź exponent + 1; ENDLOOP; UNTIL real = (significand Ź Real.Round[real]) DO real Ź Real.FScale[real, 1]; exponent Ź exponent - 1; ENDLOOP; IF neg THEN significand Ź -significand; PutInteger[stream, significand]; PutInteger[stream, exponent]; }; END.