NodeStyleFontImpl.mesa
Copyright © 1985 by Xerox Corporation. All rights reserved.
Michael Plass, April 11, 1986 12:37:41 pm PST
Doug Wyatt, May 26, 1985 1:43:21 pm PDT
Russ Atkinson (RRA) June 13, 1985 6:15:24 pm PDT
Rick Beach, June 20, 1985 2:12:43 pm PDT
DIRECTORY
Atom USING [GetPName],
Convert USING [AppendInt],
Imager USING [Error],
ImagerFont USING [Find, Font, Scale],
NodeStyle USING [FontAlphabets, FontFace],
NodeStyleFont USING [],
Real USING [Round],
RefText USING [AppendRope, AppendTextRope, ObtainScratch, ReleaseScratch],
Rope USING [Equal, Find, FromRefText, Match, ROPE, Size],
VFonts USING [DefaultFont];
~
BEGIN
ROPE: TYPE ~ Rope.ROPE;
FontAlphabets: TYPE ~ NodeStyle.FontAlphabets;
FontFace: TYPE ~ NodeStyle.FontFace;
Font:
TYPE ~ ImagerFont.Font;
PrefixKind:
TYPE ~
RECORD [
pattern: ROPE,
sizeInName: BOOL,
faceEncoding: FaceEncoding
];
FaceEncoding:
TYPE ~ {boldItalic, bir, bi};
prefixKinds:
LIST
OF PrefixKind ←
LIST[
[pattern: "xerox/tiogafonts/", sizeInName: TRUE, faceEncoding: bi],
[pattern: "xerox/pressfonts/", sizeInName: FALSE, faceEncoding: bir],
[pattern: "xerox/altofonts/", sizeInName: TRUE, faceEncoding: bi],
[pattern: "xerox/xc*", sizeInName: FALSE, faceEncoding: boldItalic]
];
AppendFontName:
PROC [text:
REF
TEXT, prefix:
ATOM, family:
ATOM, face: FontFace, size:
REAL, alphabets: FontAlphabets]
RETURNS [new:
REF
TEXT, sizeInName:
BOOL] ~ {
fam: ROPE ~ Atom.GetPName[family];
pre: ROPE ← IF prefix#NIL THEN Atom.GetPName[prefix] ELSE NIL;
faceEncoding: FaceEncoding ← boldItalic;
IF Rope.Find[fam, "/"] >= 0
THEN {
text ← RefText.AppendRope[text, fam];
RETURN [text, FALSE];
};
IF pre = NIL OR Rope.Size[pre] = 0 THEN pre ← "xerox/tiogafonts/";
sizeInName ← FALSE;
FOR p:
LIST
OF PrefixKind ← prefixKinds, p.rest
UNTIL p=
NIL
DO
IF Rope.Match[p.first.pattern, pre,
FALSE]
THEN {
sizeInName ← p.first.sizeInName;
faceEncoding ← p.first.faceEncoding;
};
ENDLOOP;
text ← RefText.AppendRope[text, pre];
text ← RefText.AppendRope[text, fam];
IF sizeInName
THEN {
text ← Convert.AppendInt[text, Real.Round[size]];
};
SELECT faceEncoding
FROM
boldItalic => {
IF face=Bold OR face=BoldItalic THEN text ← RefText.AppendTextRope[text, "-bold"];
IF face=Italic OR face=BoldItalic THEN text ← RefText.AppendTextRope[text, "-italic"];
};
bir => {
text ← RefText.AppendTextRope[text, SELECT face FROM Bold => "-BRR", Italic => "-MIR", BoldItalic => "-BIR", ENDCASE => "-MRR"];
};
bi => {
IF face=Bold OR face=BoldItalic THEN text ← RefText.AppendTextRope[text, "B"];
IF face=Italic OR face=BoldItalic THEN text ← RefText.AppendTextRope[text, "I"];
};
ENDCASE => ERROR;
new ← text;
};
FontNameFromStyleParams:
PUBLIC
PROC [prefix:
ATOM, family:
ATOM, face: FontFace, size:
REAL, alphabets: FontAlphabets]
RETURNS [name:
ROPE, scale:
REAL] ~ {
scratch: REF TEXT ~ RefText.ObtainScratch[100];
text: REF TEXT ← scratch;
sizeInName: BOOL ← FALSE;
[text, sizeInName] ← AppendFontName[text, prefix, family, face, size, alphabets];
name ← Rope.FromRefText[text];
IF sizeInName THEN scale ← 1.0 ELSE scale ← size;
RefText.ReleaseScratch[scratch];
};
nTrys: NAT ~ 4;
tryDelta: ARRAY [0..nTrys) OF REAL ← [0, -0.999, 0.999, -1.998];
families:
LIST
OF
LIST
OF
ATOM ←
LIST[
LIST[$Tioga, $Laurel, $TimesRoman],
LIST[$TimesRoman, $Classic],
LIST[$Helvetica, $Modern, $TimesRoman],
LIST[$Modern, $Helvetica],
LIST[$Classic, $TimesRoman],
LIST[$Gacha, $Helvetica]
];
SubstituteFamilies:
PROC [family:
ATOM]
RETURNS [
LIST
OF
ATOM] ~ {
fam: ROPE ~ Atom.GetPName[family];
FOR f:
LIST
OF
LIST
OF
ATOM ← families, f.rest
UNTIL f=
NIL
DO
k: ATOM ← f.first.first;
IF family = k OR Rope.Equal[fam, Atom.GetPName[k]] THEN RETURN [f.first];
ENDLOOP;
RETURN [NIL];
};
FontReplacementProc:
PROC [prefix:
ATOM, family:
ATOM, face: FontFace, size:
REAL, alphabets: FontAlphabets]
RETURNS [font: ImagerFont.Font] ←
NIL;
Plug with debugger for experimentation purposes.
horribleHackForTioga10:
BOOL ←
TRUE;
FontFromStyleParams:
PUBLIC
PROC [prefix:
ATOM, family:
ATOM, face: FontFace, size:
REAL, alphabets: FontAlphabets]
RETURNS [font: ImagerFont.Font ←
NIL] ~ {
font ← CheckCache[prefix, family, face, size, alphabets];
IF font =
NIL
THEN {
IF FontReplacementProc #
NIL
THEN {
font ← FontReplacementProc[prefix, family, face, size, alphabets];
};
IF font =
NIL
THEN {
scratch: REF TEXT ~ RefText.ObtainScratch[100];
text: REF TEXT ← scratch;
sizeInName: BOOL ← FALSE;
families: LIST OF ATOM ← NIL;
trialFamily: ATOM ← family;
firstFamily: ATOM ← family;
IF horribleHackForTioga10
AND (firstFamily=$tioga
OR firstFamily=$Tioga)
AND (size
NOT
IN [9.5..10.5])
THEN {
trialFamily ← firstFamily ← $TimesRoman;
};
WHILE font =
NIL
AND trialFamily #
NIL
DO
FOR try:
NAT
IN [0..nTrys)
WHILE font=
NIL
DO
trialSize: REAL ← size + tryDelta[try];
text.length ← 0;
[text, sizeInName] ← AppendFontName[text, prefix, trialFamily, face, trialSize, alphabets];
font ← ImagerFont.Find[Rope.FromRefText[text] ! Imager.Error => CONTINUE];
IF NOT sizeInName THEN EXIT;
ENDLOOP;
IF font =
NIL
THEN {
IF families = NIL THEN families ← SubstituteFamilies[firstFamily];
IF families #
NIL
THEN {
families ← families.rest;
};
trialFamily ← IF families=NIL THEN NIL ELSE families.first;
};
ENDLOOP;
IF font =
NIL
THEN {
font ← VFonts.DefaultFont[font];
sizeInName ← TRUE;
};
IF
NOT sizeInName
THEN {
font ← ImagerFont.Scale[font, size];
};
RefText.ReleaseScratch[scratch];
};
EnterCache[[prefix, family, face, size, alphabets, font]];
};
};
Cache stuff
cacheSize: NAT ← 5;
cache: LIST OF CacheRec ← NIL;
cacheHits: INT ← 0;
CacheRec:
TYPE ~
RECORD [prefix:
ATOM, family:
ATOM, face: FontFace, size:
REAL, alphabets: FontAlphabets, font: ImagerFont.Font];
FlushCache:
ENTRY
PROC ~ {cache ←
NIL};
CheckCache:
ENTRY
PROC [prefix:
ATOM, family:
ATOM, face: FontFace, size:
REAL, alphabets: FontAlphabets]
RETURNS [ImagerFont.Font] ~ {
prev: LIST OF CacheRec ← NIL;
FOR c:
LIST
OF CacheRec ← cache, c.rest
UNTIL c =
NIL
DO
IF c.first.prefix = prefix
AND c.first.family = family
AND c.first.face = face
AND c.first.size = size
AND c.first.alphabets = alphabets
THEN {
IF prev #
NIL
THEN {
Move to front
prev.rest ← c.rest;
c.rest ← cache;
cache ← c;
};
cacheHits ← cacheHits + 1;
RETURN [c.first.font];
};
prev ← c;
ENDLOOP;
cacheMisses ← cacheMisses + 1;
RETURN [NIL]
};
EnterCache:
ENTRY
PROC [cacheRec: CacheRec] ~ {
new: LIST OF CacheRec ← NIL;
prev: LIST OF CacheRec ← NIL;
i: NAT ← 2;
NB: The following code forces a cache size of >= 2
FOR p:
LIST
OF CacheRec ← cache, p.rest
DO
IF p = NIL THEN {new ← LIST[cacheRec]; EXIT};
IF i >= cacheSize
AND p.rest#
NIL
THEN {
new ← p.rest;
p.rest ← NIL;
new.rest ← NIL;
new.first ← cacheRec;
EXIT;
};
i ← i + 1;
ENDLOOP;
new.rest ← cache;
cache ← new;
};