<<>> <> <> <> <> <> <> <<>> DIRECTORY Ascii USING [Lower], Atom USING [GetPName], BasicTime USING [GMT], Basics USING [Comparison, CompareInt], ImagerError USING [Error, Warning], Imager USING [Context, SetXY, Trans], ImagerFont USING [CorrectionType, Extents, nullXChar, Substitution, XChar], ImagerSwitches USING [Value], ImagerSys USING [OpenInputFile, StreamCreateDate, FileError], ImagerTypeface USING [Creator, CreatorRep, Typeface, TypefaceClass, TypefaceClassRep, TypefaceRep, Version], IO USING [PutFR, PutFR1, rope, STREAM], RefText USING [ObtainScratch, ReleaseScratch], Rope USING [ActionType, Cat, Concat, Equal, FromRefText, Index, Map, Match, ROPE, Size, Substr], SymTab USING [Create, Erase, Fetch, Insert, Ref], Vector2 USING [Neg, VEC]; ImagerTypefaceImpl: CEDAR MONITOR IMPORTS Ascii, Atom, Basics, ImagerError, Imager, ImagerSwitches, ImagerSys, IO, RefText, Rope, SymTab, Vector2 EXPORTS ImagerTypeface ~ BEGIN OPEN ImagerTypeface; ROPE: TYPE ~ Rope.ROPE; VEC: TYPE ~ Vector2.VEC; XChar: TYPE ~ ImagerFont.XChar; Extents: TYPE ~ ImagerFont.Extents; CorrectionType: TYPE ~ ImagerFont.CorrectionType; nullXChar: XChar ~ ImagerFont.nullXChar; creators: ARRAY [0..3) OF LIST OF Creator ¬ ALL[NIL]; creatorOrder: LIST OF ROPE ¬ LIST["fd", "icfk", "psf-fs", "psf", "icffile", "fis", "ks", "strike", "cd", "cd-bitmaps", "cd-300", "ac", "gf"]; CreatorSeq: TYPE ~ RECORD [SEQUENCE size: NAT OF Creator]; GetCreators: ENTRY PROC RETURNS [result: REF CreatorSeq] ~ { <> size: NAT ¬ 0; i: NAT ¬ 0; FOR k: NAT IN [0..LENGTH[creators]) DO FOR each: LIST OF Creator ¬ creators[k], each.rest UNTIL each = NIL DO size ¬ size + 1; ENDLOOP; ENDLOOP; result ¬ NEW[CreatorSeq[size]]; FOR k: NAT IN [0..LENGTH[creators]) DO FOR each: LIST OF Creator ¬ creators[k], each.rest UNTIL each = NIL DO result[i] ¬ each.first; i ¬ i + 1; ENDLOOP; ENDLOOP; }; ExtensionFromCreator: PROC [creator: Creator] RETURNS [ROPE] ~ { WITH creator.data SELECT FROM data: REF FileExtensionCreateDataRep => { RETURN [data.extension] }; ENDCASE => RETURN [NIL]; }; FindExt: PROC [a: ROPE] RETURNS [i: INT ¬ 0] ~ { FOR tail: LIST OF ROPE ¬ creatorOrder, tail.rest UNTIL tail = NIL DO IF Rope.Equal[tail.first, a, FALSE] THEN RETURN; i ¬ i + 1; ENDLOOP; RETURN [-1] }; CompareOrder: PROC [aOrd, bOrd: INT, before: BOOL] RETURNS [Basics.Comparison] ~ { IF aOrd < 0 OR bOrd < 0 THEN RETURN [IF before THEN less ELSE greater]; RETURN [Basics.CompareInt[aOrd, bOrd]] }; RegisterCreator: PUBLIC ENTRY PROC [creator: Creator, before: BOOL] ~ { <> <> newExt: ROPE ~ ExtensionFromCreator[creator]; newOrder: INT ~ FindExt[newExt]; prev: LIST OF Creator ¬ NIL; IF newOrder < 0 THEN { <> IF before THEN { creators[0] ¬ CONS[creator, creators[0]] } ELSE { p: LIST OF Creator ¬ creators[2]; IF p = NIL THEN p ¬ LIST[creator] ELSE { UNTIL p.rest = NIL DO p ¬ p.rest ENDLOOP; p.rest ¬ LIST[creator]; }; }; RETURN }; IF creators[1] = NIL THEN { creators[1] ¬ LIST[creator]; RETURN }; FOR tail: LIST OF Creator ¬ creators[1], tail.rest DO IF tail = NIL THEN {prev.rest ¬ LIST[creator]; RETURN } ELSE { thisExt: ROPE ~ ExtensionFromCreator[tail.first]; SELECT CompareOrder[newOrder, FindExt[thisExt], before] FROM less => { IF prev = NIL THEN { creators[1] ¬ CONS[creator, creators[1]] } ELSE { prev.rest ¬ CONS[creator, prev.rest] }; RETURN; }; equal => { tail.first ¬ creator; RETURN }; ENDCASE; }; prev ¬ tail; ENDLOOP; }; RopeFromRef: PROC [x: REF] RETURNS [ROPE] ~ { WITH x SELECT FROM text: REF TEXT => RETURN[Rope.FromRefText[text]]; text: REF READONLY TEXT => RETURN[Rope.FromRefText[text]]; ENDCASE => RETURN[NARROW[x]]; }; typefaces: SymTab.Ref ~ SymTab.Create[mod: 37, case: FALSE]; triedAndFailed: SymTab.Ref ~ SymTab.Create[case: FALSE]; FlushTypefaceCaches: PUBLIC PROC ~ { alternates ¬ NIL; SymTab.Erase[typefaces]; SymTab.Erase[triedAndFailed]; }; FetchTypeface: PROC [name: ROPE] RETURNS [Typeface] ~ { found: BOOL; val: REF; [found, val] ¬ SymTab.Fetch[typefaces, name]; IF found THEN WITH val SELECT FROM typeface: Typeface => RETURN[typeface]; ENDCASE => ERROR -- val is wrong type or NIL ELSE RETURN[NIL]; }; races: INT ¬ 0; SetSubstitutionFont: PUBLIC PROC [defaultFont: ROPE] = { fallbackSubstitutes ¬ CONS[defaultFont, fallbackSubstitutes]; }; fallbackSubstitutes: LIST OF ROPE ¬ LIST["Xerox/XC1-3-3/Modern", "Xerox/XC1-1-1/Modern", "Xerox/XC1-2-2/Modern", "Xerox/XC1-1-1/Optima", "Xerox/Pressfonts/Modern-MRR"]; <> xcPrefixes: LIST OF ROPE ¬ LIST["Xerox/XC1-3-3/", "Xerox/XC1-1-1/", "Xerox/XC1-2-2/"]; sansNames: LIST OF ROPE ¬ LIST["Modern", "Helvetica", "Optima"]; thinSansNames: LIST OF ROPE ¬ LIST["Helvetica", "Modern", "Optima"]; serifNames: LIST OF ROPE ¬ LIST["Classic", "Times", "TimesRoman", "Optima"]; thinSerifNames: LIST OF ROPE ¬ LIST["Times", "TimesRoman", "Classic", "Optima"]; monoNames: LIST OF ROPE ¬ LIST["Terminal", "PrintWheel", "Gacha", "Modern"]; otherNames: LIST OF ROPE ¬ LIST["Modern", "Optima"]; EnumerateSubstitutions: PROC [name: ROPE, action: PROC [substituteName: ROPE] RETURNS [quit: BOOL ¬ FALSE]] ~ { Try: PROC [substituteName: ROPE] RETURNS [quit: BOOL ¬ FALSE] ~ { IF SymTab.Fetch[triedAndFailed, substituteName].found THEN RETURN; quit ¬ action[substituteName]; IF quit THEN RETURN; [] ¬ SymTab.Insert[triedAndFailed, substituteName, substituteName]; }; IF Rope.Match["Xerox/XC1*/*", name, FALSE] THEN { shortName: ROPE ~ Rope.Substr[name, Rope.Index[name, 8, "/"]+1]; Match: PROC [pattern: ROPE] RETURNS [BOOL] ~ { RETURN [Rope.Match[pattern: pattern, object: shortName, case: FALSE]] }; sans: BOOL ¬ Match["*helve*"] OR Match["*univ*"] OR Match["*sans*"] OR Match["*frut*"] OR Match["*univ*"] OR Match["*modern*"]; serif: BOOL ¬ Match["*classic*"] OR Match["*scotc*"] OR Match["*serif*"] OR Match["*time*"] OR Match["*cent*"] OR Match["*garam*"]; mono: BOOL ¬ Match["*terminal*"] OR Match["*gacha*"] OR Match["*printwheel*"]; bold: BOOL ¬ Match["*-*bol*"]; slanted: BOOL ¬ Match["*-*ita*"] OR Match["*-*obl*"]; thin: BOOL ¬ Match["*-*thin*"] OR Match["*helve*"] OR Match["*time*"]; FOR tail: LIST OF ROPE ¬ xcPrefixes, tail.rest UNTIL tail = NIL DO IF Try[Rope.Concat[tail.first, shortName]].quit THEN RETURN; ENDLOOP; FOR eachFamily: LIST OF ROPE ¬ CONS[Rope.Substr[shortName, 0, Rope.Index[shortName, 0, "-"]], IF serif AND NOT sans THEN (IF thin THEN thinSerifNames ELSE serifNames) ELSE IF sans THEN (IF thin THEN thinSansNames ELSE sansNames) ELSE IF mono THEN monoNames ELSE otherNames], eachFamily.rest UNTIL eachFamily = NIL DO FOR tail: LIST OF ROPE ¬ xcPrefixes, tail.rest UNTIL tail = NIL DO IF Try[Rope.Cat[tail.first, eachFamily.first, IF bold THEN "-bold" ELSE NIL, IF slanted THEN "-italic" ELSE NIL]].quit THEN RETURN; ENDLOOP; ENDLOOP; }; FOR tail: LIST OF ROPE ¬ fallbackSubstitutes, tail.rest UNTIL tail=NIL DO IF Try[tail.first].quit THEN RETURN; ENDLOOP; }; Create: PROC [name: ROPE, substitution: ImagerFont.Substitution, versionHint: Version] RETURNS [Typeface] ~ { typeface: Typeface ¬ NIL; IF versionHint # NIL THEN { FOR k: NAT IN [0..LENGTH[creators]) DO FOR each: LIST OF Creator ¬ creators[k], each.rest UNTIL each = NIL OR typeface # NIL DO creator: Creator ~ each.first; extension: ROPE = Atom.GetPName[versionHint.type]; IF creator.proc = FileExtensionCreate THEN { data: REF FileExtensionCreateDataRep ~ NARROW[creator.data]; IF Rope.Equal[s1: data.extension, s2: extension, case: FALSE] THEN { typeface ¬ creator.proc[self: creator, name: name, substitute: FALSE]; IF typeface = NIL OR typeface.created # versionHint.createDate OR typeface.class.type # versionHint.type THEN typeface ¬ NIL; }; }; ENDLOOP; ENDLOOP; }; FOR k: NAT IN [0..LENGTH[creators]) DO FOR each: LIST OF Creator ¬ creators[k], each.rest UNTIL each = NIL OR typeface # NIL DO creator: Creator ~ each.first; typeface ¬ creator.proc[self: creator, name: name, substitute: FALSE]; IF versionHint # NIL THEN { IF typeface = NIL OR typeface.created # versionHint.createDate OR typeface.class.type # versionHint.type THEN typeface ¬ NIL; }; ENDLOOP; ENDLOOP; IF typeface = NIL THEN { IF substitution # noSubstitute THEN { EachCandidate: PROC [substituteName: ROPE] RETURNS [quit: BOOL ¬ FALSE] ~ { FOR k: NAT IN [0..LENGTH[creators]) DO FOR each: LIST OF Creator ¬ creators[k], each.rest UNTIL each = NIL OR typeface # NIL DO creator: Creator ~ each.first; typeface ¬ FindTypeface[name: substituteName, substitution: noSubstitute, versionHint: NIL ! ImagerError.Error => IF error.code = $fontNotFound THEN CONTINUE; ]; ENDLOOP; ENDLOOP; RETURN [quit: typeface#NIL] }; EnumerateSubstitutions[name, EachCandidate]; }; IF typeface = NIL THEN { ERROR ImagerError.Error[[code: $fontNotFound, explanation: IO.PutFR1["Unable to find substitute for font \"%g\".", IO.rope[name]]]]; }; }; RETURN [typeface] }; FindTypeface: PUBLIC PROC [name: ROPE, substitution: ImagerFont.Substitution, versionHint: Version] RETURNS [Typeface] ~ { Insert: PROC [tname: ROPE, t: Typeface] ~ { IF NOT SymTab.Insert[typefaces, tname, t] THEN races ¬ races+1; }; typeface: Typeface ¬ FetchTypeface[name]; substitutionOccured: BOOL ¬ FALSE; IF typeface # NIL THEN { substitutionOccured ¬ NOT Rope.Equal[name, typeface.name, FALSE] } ELSE { name ¬ RopeFromRef[name]; -- in case somebody LOOPHOLEd a REF TEXT typeface ¬ Create[name, substitution, versionHint]; substitutionOccured ¬ NOT Rope.Equal[name, typeface.name, FALSE]; IF substitutionOccured THEN { old: Typeface ~ NARROW[SymTab.Fetch[typefaces, typeface.name].val]; IF old = NIL THEN Insert[typeface.name, typeface] ELSE typeface ¬ old; Insert[name, typeface]; } ELSE Insert[typeface.name, typeface]; }; IF substitution = substituteWithWarning AND substitutionOccured THEN { SIGNAL ImagerError.Warning[[code: $appearance, explanation: IO.PutFR["Could not find font \"%g\"; substituting \"%g\"", IO.rope[name], IO.rope[typeface.name]]]]; }; RETURN[typeface]; }; reverseKey: ROPE ~ "Backward Metrics"; ReverseMetrics: PUBLIC PROC [typeface: Typeface] RETURNS [Typeface] ~ { new: Typeface ¬ AlternateMetricFind[typeface, reverseKey]; IF new = NIL THEN { new ¬ NEW[TypefaceRep ¬ [ class: wellKnownAlternateMetricsClass, data: typeface, alternateMetrics: reverseKey ]]; new ¬ AlternateMetricInsert[typeface: typeface, alternateMetrics: reverseKey, alternate: new]; }; RETURN [new]; }; SelectAlternateTypefaceMetrics: PUBLIC PROC [typeface: Typeface, alternateMetrics: ROPE] RETURNS [Typeface] ~ { IF typeface.alternateMetrics = NIL THEN { new: Typeface ¬ AlternateMetricFind[typeface, alternateMetrics]; IF new # NIL THEN RETURN [new]; new ¬ typeface.class.AlternateMetrics[typeface, alternateMetrics]; IF new # NIL THEN { RETURN [AlternateMetricInsert[typeface, alternateMetrics, new]]; }; }; ERROR ImagerError.Error[error: [code: $illegalAlternateMetrics, explanation: Rope.Cat[ "Attempt to select unknown alternate font metrics: ", alternateMetrics, " for font ", typeface.name ]]]; }; AlternateMetricEntry: TYPE ~ RECORD[typeface: Typeface, alternateMetrics: ROPE, alternate: Typeface]; alternates: LIST OF AlternateMetricEntry ¬ NIL; <> AlternateMetricFind: ENTRY PROC [typeface: Typeface, alternateMetrics: ROPE] RETURNS [Typeface] ~ { FOR each: LIST OF AlternateMetricEntry ¬ alternates, each.rest UNTIL each = NIL DO IF each.first.typeface = typeface AND Rope.Equal[each.first.alternateMetrics, alternateMetrics, FALSE] THEN RETURN [each.first.alternate] ENDLOOP; RETURN [NIL] }; AlternateMetricInsert: ENTRY PROC [typeface: Typeface, alternateMetrics: ROPE, alternate: Typeface] RETURNS [Typeface] ~ { FOR each: LIST OF AlternateMetricEntry ¬ alternates, each.rest UNTIL each = NIL DO <> IF each.first.typeface = typeface AND Rope.Equal[each.first.alternateMetrics, alternateMetrics, FALSE] THEN RETURN [each.first.alternate] ENDLOOP; alternates ¬ CONS[[typeface, alternateMetrics, alternate], alternates]; RETURN [alternate] }; WNAlternateMetrics: PROC [self: Typeface, alternateMetrics: ROPE] RETURNS [Typeface] ~ {RETURN [NIL]}; WNContains: PROC [self: Typeface, char: XChar] RETURNS [BOOL] ~ { base: Typeface ~ NARROW[self.data]; RETURN [base.class.Contains[base, char]]; }; WNNextChar: PROC [self: Typeface, char: XChar] RETURNS [next: XChar] ~ { base: Typeface ~ NARROW[self.data]; RETURN [base.class.NextChar[base, char]]; }; WNEscapement: PROC [self: Typeface, char: XChar] RETURNS [VEC] ~ { base: Typeface ~ NARROW[self.data]; SELECT self.alternateMetrics FROM reverseKey => { RETURN [Vector2.Neg[base.class.Escapement[base, char]]] }; ENDCASE => ERROR; }; WNAmplified: PROC [self: Typeface, char: XChar] RETURNS [BOOL] ~ { base: Typeface ~ NARROW[self.data]; RETURN [base.class.Amplified[base, char]]; }; WNCorrection: PROC [self: Typeface, char: XChar] RETURNS [CorrectionType] ~ { base: Typeface ~ NARROW[self.data]; RETURN [base.class.Correction[base, char]]; }; WNBoundingBox: PROC [self: Typeface, char: XChar] RETURNS [Extents] ~ { base: Typeface ~ NARROW[self.data]; e: VEC ~ base.class.Escapement[base, char]; b: Extents ~ base.class.BoundingBox[base, char]; SELECT self.alternateMetrics FROM reverseKey => { extents: Extents ~ [ leftExtent: b.leftExtent+e.x, rightExtent: b.rightExtent-e.x, descent: b.descent+e.y, ascent: b.ascent-e.y ]; RETURN [extents]; }; ENDCASE => ERROR; }; WNFontBoundingBox: PROC [self: Typeface] RETURNS [Extents] ~ { base: Typeface ~ NARROW[self.data]; ee: Extents ¬ [leftExtent: 0.0, rightExtent: 0.0, descent: 0.0, ascent: 0.0]; FOR char: XChar ¬ base.class.NextChar[base, nullXChar], base.class.NextChar[base, char] UNTIL char = nullXChar DO e: Extents ~ self.class.BoundingBox[self, char]; IF e.leftExtent > ee.leftExtent THEN ee.leftExtent ¬ e.leftExtent; IF e.rightExtent > ee.rightExtent THEN ee.rightExtent ¬ e.rightExtent; IF e.descent > ee.descent THEN ee.descent ¬ e.descent; IF e.ascent > ee.ascent THEN ee.ascent ¬ e.ascent; ENDLOOP; RETURN [ee]; }; WNNull: PROC [self: Typeface, char, successor: XChar] RETURNS [XChar] ~ {RETURN [nullXChar]}; WNKern: PROC [self: Typeface, char, successor: XChar] RETURNS [VEC] ~ {RETURN [[0, 0]]}; WNMask: PROC [self: Typeface, char: XChar, context: Imager.Context] ~ { base: Typeface ~ NARROW[self.data]; SELECT self.alternateMetrics FROM reverseKey => { e: VEC ~ base.class.Escapement[base, char]; Imager.SetXY[context, Vector2.Neg[e]]; Imager.Trans[context]; base.class.Mask[base, char, context]; }; ENDCASE => ERROR; }; wellKnownAlternateMetricsClass: TypefaceClass ~ NEW[TypefaceClassRep ¬ [ type: $AlternateMetrics, AlternateMetrics: WNAlternateMetrics, Contains: WNContains, NextChar: WNNextChar, Escapement: WNEscapement, Amplified: WNAmplified, Correction: WNCorrection, BoundingBox: WNBoundingBox, FontBoundingBox: WNFontBoundingBox, Ligature: WNNull, NextLigature: WNNull, Kern: WNKern, NextKern: WNNull, Mask: WNMask ]]; <> <> <> <> <<];>> <<>> <7.0>Fonts>">> <Fonts>">> <<>> <> <> <> <> <> < CONTINUE];>> <> <> <> < CONTINUE];>> <<};>> <> <> <> <> <> <> <<};>> <> <<};>> <<>> <> <> <> <<};>> <> FileExtensionCreateDataRep: TYPE ~ RECORD [ extension: ROPE, createProc: PROC [stream: IO.STREAM] RETURNS [Typeface] ]; LowerCaseCat: PROC [ropes: ARRAY [0..4) OF ROPE] RETURNS [result: ROPE ¬ NIL] ~ { <> j: NAT ¬ 0; len: NAT ¬ 0; buf: REF TEXT ¬ NIL; FOR i: NAT IN [0..LENGTH[ropes]) DO len ¬ len + Rope.Size[ropes[i]]; ENDLOOP; buf ¬ RefText.ObtainScratch[len]; FOR i: NAT IN [0..LENGTH[ropes]) DO Action: Rope.ActionType ~ { buf[j] ¬ Ascii.Lower[c]; j ¬ j + 1 }; [] ¬ Rope.Map[base: ropes[i], action: Action]; ENDLOOP; buf.length ¬ j; result ¬ Rope.FromRefText[buf]; RefText.ReleaseScratch[buf]; buf ¬ NIL; }; fontDirSwitch: CHAR = 'f; -- Defined in ImagerSys implementation, so it can vary by system. FileExtensionCreate: PROC [self: Creator, name: ROPE, substitute: BOOL] RETURNS [Typeface] ~ { data: REF FileExtensionCreateDataRep ~ NARROW[self.data]; fontDir: ROPE ~ WITH ImagerSwitches.Value[fontDirSwitch] SELECT FROM rope: ROPE => rope, ENDCASE => NIL; fileName: ROPE ~ LowerCaseCat[[fontDir, name, ".", data.extension]]; stream: IO.STREAM ¬ NIL; stream ¬ ImagerSys.OpenInputFile[fileName ! ImagerSys.FileError => { <> ERROR ImagerError.Error[[$ioError, Rope.Cat["Error while attempting to open file ", name, ": ", explanation], LIST[[$code, code]]]]; }; ]; IF stream # NIL THEN { created: BasicTime.GMT ~ ImagerSys.StreamCreateDate[stream]; typeface: Typeface ~ data.createProc[stream]; typeface.name ¬ name; typeface.created ¬ created; RETURN [typeface]; }; RETURN [NIL]; }; CreatorFromFileExtension: PUBLIC PROC [extension: ROPE, createProc: PROC [stream: IO.STREAM] RETURNS [Typeface]] RETURNS [Creator] ~ { data: REF FileExtensionCreateDataRep ~ NEW[FileExtensionCreateDataRep ¬ [extension, createProc]]; RETURN [NEW[CreatorRep ¬ [proc: FileExtensionCreate, data: data]]]; }; END. <> <>