DIRECTORY
Atom USING [MakeAtomFromRefText],
BasicTime USING [GMT, nullGMT],
Convert USING [AppendCard],
FS USING [ComponentPositions, EnumerateForNames, Error, ErrorDesc, ExpandName, GetInfo, GetName, NameProc, nullOpenFile, Open, OpenFile],
Imager,
ImagerBox,
ImagerFont USING [CorrectionType, nullXChar],
ImagerTypeface,
IO USING [PutFR1, rope],
RefText USING [AppendRope, ObtainScratch, ReleaseScratch],
Rope,
SymTab USING [Create, Delete, Fetch, Insert, Pairs, Ref, Store];
~
BEGIN
OPEN ImagerTypeface;
ROPE: TYPE ~ Rope.ROPE;
nullXChar: XChar ~ ImagerFont.nullXChar;
creators: SymTab.Ref ~ SymTab.Create[mod: 7, case: FALSE];
Creator: TYPE ~ REF CreatorRep;
CreatorRep: TYPE ~ RECORD[extension: ROPE, create: CreateProc];
Register:
PUBLIC
PROC [extension:
ROPE, create: CreateProc] ~ {
creator: Creator ~ NEW[CreatorRep ← [extension: extension, create: create]];
[] ← SymTab.Store[x: creators, key: extension, val: creator];
};
FetchCreator:
PUBLIC
PROC [extension:
ROPE]
RETURNS [CreateProc] ~ {
found: BOOL; val: REF;
[found, val] ← SymTab.Fetch[creators, extension];
IF found
THEN
WITH val
SELECT
FROM
creator: Creator => RETURN[creator.create];
ENDCASE => ERROR -- val is wrong type or NIL
ELSE RETURN[NIL];
};
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];
FlushTypefaces:
ENTRY
PROC
RETURNS [ok:
BOOL ←
TRUE] ~ {
someKey: ROPE ← NIL;
epa: PROC [key: ROPE, val: REF] RETURNS [quit: BOOL ← TRUE] ~ {someKey ← key};
WHILE SymTab.Pairs[typefaces, epa]
DO
IF NOT SymTab.Delete[typefaces, someKey] THEN RETURN [FALSE];
ENDLOOP;
};
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;
generics: LIST OF GenericCreator ~ LIST[NIL];
RegisterGenericCreator:
PUBLIC
ENTRY
PROC [genericCreator: GenericCreator] ~ {
priority: INTEGER ~ genericCreator.priority;
prev: LIST OF GenericCreator ← generics;
FOR p:
LIST
OF GenericCreator ← prev.rest, p.rest
UNTIL p =
NIL
OR p.first.priority < priority
DO
IF p.first.priority = priority THEN {p.first ← genericCreator; RETURN};
prev ← p;
ENDLOOP;
prev.rest ← CONS[genericCreator, prev.rest];
};
GetGeneric:
ENTRY
PROC [list:
LIST
OF GenericCreator]
RETURNS [first: GenericCreator ←
NIL, rest:
LIST
OF GenericCreator ←
NIL] ~ {
IF list#NIL THEN {first ← list.first; rest ← list.rest};
};
Create:
PROC [name:
ROPE]
RETURNS [typeface: Typeface] ~ {
current: GenericCreator ← NIL;
rest: LIST OF GenericCreator ← NIL;
[current, rest] ← GetGeneric[generics.rest];
UNTIL current =
NIL
OR current.priority <= 0
DO
IF (typeface ← current.proc[current, name])#NIL THEN RETURN;
[current, rest] ← GetGeneric[rest];
ENDLOOP;
IF (typeface ← NormalCreate[name])#NIL THEN RETURN;
UNTIL current =
NIL
DO
IF (typeface ← current.proc[current, name])#NIL THEN RETURN;
[current, rest] ← GetGeneric[rest];
ENDLOOP;
ERROR Imager.Error[[code: $fontNotFound, explanation: IO.PutFR1["Could not find font \"%g\".", IO.rope[name]]]];
};
NormalCreate:
PROC [name:
ROPE]
RETURNS [typeface: Typeface] ~ {
fontsDir: ROPE ~ "Fonts/";
pattern: ROPE ~ Rope.Cat["///", fontsDir, name, ".*!h"];
file: FS.OpenFile ← FS.nullOpenFile;
created: BasicTime.GMT ← BasicTime.nullGMT;
fullFName: ROPE ← NIL;
cp: FS.ComponentPositions;
nameStart, nameStop: INT ← 0;
fontName, extension: ROPE ← NIL;
convertToSlashes: Rope.TranslatorType ~ { RETURN[IF old='> THEN '/ ELSE old] };
create: CreateProc ← NIL;
nameProc: FS.NameProc ~ { file ← FS.Open[fullFName]; RETURN[continue: FALSE] };
FS.EnumerateForNames[pattern: pattern, proc: nameProc];
IF file=FS.nullOpenFile THEN RETURN [NIL];
[fullFName: fullFName, cp: cp] ← FS.ExpandName[name: FS.GetName[file].fullFName];
created ← FS.GetInfo[file].created;
nameStart ← cp.subDirs.start+Rope.Length[fontsDir];
nameStop ← cp.base.start+cp.base.length;
fontName ← Rope.Translate[base: fullFName, start: nameStart, len: nameStop-nameStart,
translator: convertToSlashes];
IF NOT Rope.Equal[s1: name, s2: fontName, case: FALSE] THEN ERROR Imager.Error[[code: $bug,
explanation: "Typeface file name doesn't match requested name."]];
extension ← Rope.Substr[base: fullFName, start: cp.ext.start, len: cp.ext.length];
create ← FetchCreator[extension];
IF create=NIL THEN ERROR Imager.Error[[code: $fontTypeNotFound,
explanation: Rope.Concat[fullFName, " is a font file of unknown type"]]];
typeface ← create[file];
typeface.name ← fontName;
typeface.created ← created;
RETURN[typeface];
};
Find:
PUBLIC
PROC [name:
ROPE]
RETURNS [Typeface] ~ {
typeface: Typeface ← FetchTypeface[name];
errorDesc: FS.ErrorDesc;
IF typeface=NIL THEN typeface ← Create[name ! FS.Error => { errorDesc ← error; CONTINUE }];
IF typeface=NIL THEN ERROR Imager.Error[[code: $fontFileError,
explanation: errorDesc.explanation]];
IF typeface.info = NIL THEN BuildInfoTable[typeface];
IF NOT SymTab.Insert[typefaces, typeface.name, typeface] THEN races ← races+1;
RETURN[typeface];
};
BuildInfoTable:
PROC[typeface: Typeface] ~ {
info: InfoTable ~ NEW[InfoTableRep ← ALL[[]]];
FOR code:
BYTE
IN
BYTE
DO
char: XChar ~ [set: 0, code: code];
exists: BOOL ~ typeface.class.Contains[typeface, char];
amplified: BOOL ~ typeface.class.Amplified[typeface, char];
correction: CorrectionType ~ typeface.class.Correction[typeface, char];
info[code] ← [exists: exists, amplified: amplified, correction: correction];
ENDLOOP;
typeface.info ← info;
};
DoWithScratchText:
PROC[len:
NAT, action:
PROC[
REF
TEXT]] ~ {
scratch: REF TEXT ~ RefText.ObtainScratch[len];
action[scratch ! UNWIND => RefText.ReleaseScratch[scratch]];
RefText.ReleaseScratch[scratch];
};
MakeNameAtom:
PUBLIC
PROC [name:
ROPE, gmt: BasicTime.
GMT]
RETURNS [atom:
ATOM] ~ {
InnterMakeNameAtom:
PROC[text:
REF
TEXT] ~ {
text ← RefText.AppendRope[to: text, from: name];
FOR i:
NAT
IN[0..text.length)
DO
char: CHAR ~ text[i];
IF char IN['A..'Z] THEN text[i] ← char-'A+'a; -- convert to lower case
ENDLOOP;
IF gmt#BasicTime.nullGMT
THEN {
text ← RefText.AppendRope[to: text, from: "/v"];
text ← Convert.AppendCard[to: text, from: LOOPHOLE[gmt]];
};
atom ← Atom.MakeAtomFromRefText[text];
};
DoWithScratchText[100, InnterMakeNameAtom];
};
Generic Creator to handle character-set mapping
This creator handles fonts with names of the form xerox/xc*/*, where the typeface is actually represented as a collection of other typefaces, with names like
xerox/xc*/*-c#,
# being the octal character set indicator. Thus we get to deal with lots of smaller font files, instead of one big one, and they may be in our old favorite formats that predate the 16-bit character codes.
XCGenericCreator:
PROC [self: GenericCreator, name:
ROPE]
RETURNS [typeface: Typeface ←
NIL] ~ {
IF Rope.Match["xerox/xc*/*", name,
FALSE]
THEN {
tname: ROPE ~ Rope.Translate[name]; -- in case name is really a REF TEXT!
vStart: INT ~ Rope.Index[tname, 0, "/"]+1;
vEnd: INT ~ Rope.Index[tname, vStart, "/"];
charSetVersion: ROPE ~ Rope.Substr[tname, vStart, vEnd-vStart];
rest: ROPE ~ Rope.Substr[tname, vEnd+1];
charSetMapper: CharSetMapper ~ FindMapping[charSetVersion, rest];
IF charSetMapper #
NIL
THEN {
typeface ←
NEW[TypefaceRep ← [
class: charSetMapClass,
data: charSetMapper,
name: tname
]];
};
};
};
CharSetMapper: TYPE ~ LIST OF CharSetEntry;
CharSetEntry:
TYPE ~
RECORD [charSet:
CARDINAL, newTypeface: Typeface];
In:
PROC [charSet:
CARDINAL, charSetMapper: CharSetMapper]
RETURNS [
BOOL] ~ {
FOR each:
LIST
OF CharSetEntry ← charSetMapper, each.rest
UNTIL each =
NIL
DO
IF each.first.charSet = charSet THEN RETURN [TRUE]
ENDLOOP;
RETURN [FALSE]
};
InsertInOrder:
PROC [charSetEntry: CharSetEntry, charSetMapper: CharSetMapper]
RETURNS [CharSetMapper] ~ {
IF charSetMapper =
NIL
OR charSetEntry.charSet < charSetMapper.first.charSet
THEN charSetMapper ← CONS[charSetEntry, charSetMapper]
ELSE {
prev: CharSetMapper ← charSetMapper;
UNTIL prev.rest = NIL OR charSetEntry.charSet < prev.rest.first.charSet DO prev ← prev.rest ENDLOOP;
prev.rest ← CONS[charSetEntry, prev.rest];
};
RETURN [charSetMapper];
};
CSVersionFromFileName:
PROC [fullFName:
ROPE]
RETURNS [
ROPE] ~ {
IF
NOT Rope.Match["[]<>fonts>xerox>*", fullFName,
FALSE]
THEN
ERROR
ELSE {
d1: INT ~ Rope.Size["[]<>fonts>xerox>"];
d2: INT ~ Rope.Index[fullFName, d1+1, ">"];
RETURN [Rope.Substr[fullFName, d1, d2-d1]];
};
};
FontNameFromFileName:
PROC [fullFName:
ROPE]
RETURNS [
ROPE] ~ {
IF
NOT Rope.Match["[]<>fonts>*", fullFName,
FALSE]
THEN
ERROR
ELSE {
d1: INT ~ Rope.Size["[]<>fonts>"];
d2: INT ~ Rope.Index[fullFName, d1+1, "."];
translator: Rope.TranslatorType ~ { new ← IF old = '> THEN '/ ELSE old };
RETURN [Rope.Translate[base: fullFName, start: d1, len: d2-d1, translator: translator]];
};
};
CharSetFromFontName:
PROC [fontName:
ROPE]
RETURNS [
CARDINAL] ~ {
c: CARDINAL ← 0;
b: CARDINAL ← 1;
size: INT ~ Rope.Size[fontName];
i: INT ← size-1;
ch: CHAR ← 0C;
WHILE i > 0
DO
ch ← Rope.Fetch[fontName, i];
SELECT ch
FROM
IN ['0..'8) => {IF b > 255 THEN EXIT; c ← c + b*(ch-'0); b ← b * 8};
ENDCASE => EXIT;
i ← i-1;
ENDLOOP;
IF i = size-1 THEN RETURN [CARDINAL.LAST]; -- no digits
IF i < 2 THEN RETURN [CARDINAL.LAST]; -- not enough left for valid name
IF NOT (ch='c OR ch='C) THEN RETURN [CARDINAL.LAST]; -- missing "c"
IF NOT Rope.Fetch[fontName, i-1] = '- THEN RETURN [CARDINAL.LAST]; -- missing "-"
RETURN [c];
};
FindMapping:
PROC [charSetVersion:
ROPE, shortName:
ROPE]
RETURNS [CharSetMapper] ~ {
This looks for a collection of font files, one for each character set. It tries to find an exact match for charSetVersion, but failing that, it chooses the lexicographically largest match (relying of FS to enumerate the names in order). The font names searched for are of the form
[]<>fonts>xerox>xc*>shortName-c#.*, where `xc*' denotes the character set version, shortName is the main part of the font name, with any qualifiers, and # is the character set number.
charSetMapper: CharSetMapper ← NIL;
pattern: ROPE ~ Rope.Cat["///fonts/xerox/xc*/", shortName, "-c*.*"];
matches: LIST OF ROPE ← NIL;
matchedVersion: ROPE ← NIL;
nameProc:
PROC [fullFName:
ROPE]
RETURNS [continue:
BOOL ←
TRUE] ~ {
csVersion: ROPE ~ CSVersionFromFileName[fullFName];
IF
NOT Rope.Equal[csVersion, matchedVersion,
FALSE]
THEN {
IF Rope.Compare[matchedVersion, charSetVersion, FALSE] IN [equal..greater]
THEN RETURN [continue: FALSE];
matchedVersion ← csVersion;
matches ← NIL;
};
matches ← CONS[fullFName, matches];
};
FS.EnumerateForNames[pattern: pattern, proc: nameProc];
FOR each:
LIST
OF
ROPE ← matches, each.rest
UNTIL each =
NIL
DO
fontName: ROPE ~ FontNameFromFileName[each.first];
charSet: CARDINAL ~ CharSetFromFontName[fontName];
IF charSet
IN [0..255)
AND
NOT In[charSet, charSetMapper]
THEN {
newTypeface: Typeface ← NIL;
newTypeface ← Find[fontName ! Imager.Error => CONTINUE];
IF newTypeface #
NIL
THEN charSetMapper ← InsertInOrder[[charSet, newTypeface], charSetMapper];
};
ENDLOOP;
RETURN [charSetMapper]
};
charSetMapClass: TypefaceClass ~
NEW[TypefaceClassRep ← [
type: $CharSetMapper,
Contains: CharSetMapContains,
NextChar: CharSetMapNextChar,
Width: CharSetMapWidth,
Amplified: CharSetMapAmplified,
Correction: CharSetMapCorrection,
BoundingBox: CharSetMapBoundingBox,
FontBoundingBox: CharSetMapFontBoundingBox,
Ligature: CharSetMapLigature,
Kern: CharSetMapKern,
NextKern: CharSetMapNextKern,
Mask: CharSetMapMask
]];
MapTypeface:
PROC [self: Typeface, char: XChar]
RETURNS [Typeface] ~ {
charSetMapper: CharSetMapper ~ NARROW[self.data];
FOR each:
LIST
OF CharSetEntry ← charSetMapper, each.rest
UNTIL each =
NIL
DO
IF each.first.charSet = char.set THEN RETURN[each.first.newTypeface];
ENDLOOP;
RETURN [NIL]
};
CharSetMapContains:
PROC [self: Typeface, char: XChar]
RETURNS [
BOOL] ~ {
mapped: Typeface ~ MapTypeface[self, char];
IF mapped = NIL THEN RETURN [FALSE];
RETURN [mapped.class.Contains[mapped, [set: 0, code: char.code]]];
};
CharSetMapNextChar:
PROC [self: Typeface, char: XChar]
RETURNS [next: XChar] ~ {
Cound be a lot cleverer here!
ch: WORD ← LOOPHOLE[char, WORD]+1;
UNTIL self.class.Contains[self,
LOOPHOLE[ch]]
OR ch =
WORD.
LAST
DO
ch ← ch + 1;
ENDLOOP;
next ← LOOPHOLE[ch];
};
CharSetMapWidth:
PROC [self: Typeface, char: XChar]
RETURNS [
VEC] ~ {
mapped: Typeface ~ MapTypeface[self, char];
IF mapped = NIL THEN RETURN [[0.5, 0]];
RETURN [mapped.class.Width[mapped, [set: 0, code: char.code]]];
};
CharSetMapAmplified:
PROC [self: Typeface, char: XChar]
RETURNS [
BOOL] ~ {
mapped: Typeface ~ MapTypeface[self, char];
IF mapped = NIL THEN RETURN [FALSE];
RETURN [mapped.class.Amplified[mapped, [set: 0, code: char.code]]];
};
CharSetMapCorrection:
PROC [self: Typeface, char: XChar]
RETURNS [ImagerFont.CorrectionType] ~ {
mapped: Typeface ~ MapTypeface[self, char];
IF mapped = NIL THEN RETURN [none];
RETURN [mapped.class.Correction[mapped, [set: 0, code: char.code]]];
};
defaultExtents: Extents ~ [leftExtent: -0.1, rightExtent: 0.4, descent: 0, ascent: 0.7];
CharSetMapBoundingBox:
PROC [self: Typeface, char: XChar]
RETURNS [Extents] ~ {
mapped: Typeface ~ MapTypeface[self, char];
IF mapped = NIL THEN RETURN [defaultExtents];
RETURN [mapped.class.BoundingBox[mapped, [set: 0, code: char.code]]];
};
CharSetMapFontBoundingBox:
PROC [self: Typeface]
RETURNS [Extents] ~ {
charSetMapper: CharSetMapper ~ NARROW[self.data];
box: Imager.Box ← [999999, 999999, -999999, -999999];
BoundPoint:
PROC [x, y:
REAL] ~
INLINE {
IF x < box.xmin THEN box.xmin ← x;
IF x > box.xmax THEN box.xmax ← x;
IF y < box.ymin THEN box.ymin ← y;
IF y > box.ymax THEN box.ymax ← y;
};
FOR each: CharSetMapper ← charSetMapper, each.rest
UNTIL each =
NIL
DO
mapped: Typeface ~ each.first.newTypeface;
e: Extents ← mapped.class.FontBoundingBox[mapped];
bb: Imager.Box ← ImagerBox.BoxFromExtents[e];
BoundPoint[bb.xmin, bb.ymin];
BoundPoint[bb.xmax, bb.ymax];
ENDLOOP;
IF box.xmin > box.xmax THEN RETURN [[0,0,0,0]];
RETURN [ImagerBox.ExtentsFromBox[box]]
};
CharSetMapLigature:
PROC [self: Typeface, char, successor: XChar]
RETURNS [XChar] ~ {
Note that we could manufacure the ligature info, since it should be the same across all fonts. But for now. . .
RETURN [nullXChar]
};
CharSetMapNextLigature:
PROC [self: Typeface, char, successor: XChar]
RETURNS [XChar] ~ {
RETURN [nullXChar]
};
CharSetMapKern:
PROC [self: Typeface, char, successor: XChar]
RETURNS [
VEC] ~ {
RETURN [[0, 0]]
};
CharSetMapNextKern:
PROC [self: Typeface, char, successor: XChar]
RETURNS [XChar] ~ {
RETURN [nullXChar]
};
CharSetMapMask:
PROC [self: Typeface, char: XChar, context: Imager.Context] ~ {
mapped: Typeface ~ MapTypeface[self, char];
IF mapped =
NIL
THEN Imager.MaskBox[context, ImagerBox.BoxFromExtents[defaultExtents]]
ELSE mapped.class.Mask[mapped, [set: 0, code: char.code], context];
};
RegisterGenericCreator[
NEW[GenericCreatorRep ← [data:
NIL, proc: XCGenericCreator, priority: 0]]];