Font info
PrefixKind:
TYPE ~
RECORD [
pattern: ROPE,
sizeInName: BOOL,
preScaled: BOOL, -- Having pre-scaled fonts was probably a mistake, but we are sort of stuck, for now.
faceEncoding: FaceEncoding
];
FaceEncoding:
TYPE ~ {boldItalic, bir, bi};
prefixKinds:
LIST
OF PrefixKind ¬
LIST[
[pattern: "xerox/tiogafonts/", sizeInName: TRUE, preScaled: TRUE, faceEncoding: bi],
[pattern: "xerox/pressfonts/", sizeInName: FALSE, preScaled: FALSE, faceEncoding: bir],
[pattern: "xerox/altofonts/", sizeInName: TRUE, preScaled: TRUE, faceEncoding: bi],
[pattern: "xerox/xc*/tioga-", sizeInName: TRUE, preScaled: FALSE, faceEncoding: boldItalic],
[pattern: "xerox/xc*/", sizeInName: FALSE, preScaled: FALSE, faceEncoding: boldItalic]
];
boldItalicSuffix:
ARRAY FontFace
OF
ROPE ~ [
Regular: "", Bold: "-bold", Italic: "-italic", BoldItalic: "-bold-italic"
];
birSuffix:
ARRAY FontFace
OF
ROPE ~ [
Regular: "-MRR", Bold: "-BRR", Italic: "-MIR", BoldItalic: "-BIR"
];
biSuffix:
ARRAY FontFace
OF
ROPE ~ [
Regular: "", Bold: "B", Italic: "I", BoldItalic: "BI"
];
faceIndex:
ARRAY FontFace
OF [0..4) ~ [
Regular: 0, Bold: 1, Italic: 2, BoldItalic: 3
];
AppendFontName:
PROC [text:
REF
TEXT,
prefix:
ATOM, family:
ATOM, face: FontFace, size:
REAL, alphabets: FontAlphabets]
RETURNS [new:
REF
TEXT, sizeInName:
BOOL ¬
FALSE, preScaled:
BOOL ¬
FALSE] ~ {
fam: ROPE ~ Atom.GetPName[family];
IF Rope.Find[fam, "/"] >= 0 THEN RETURN[RefText.AppendRope[text, fam]]
ELSE {
prePName: ROPE ~ IF prefix#NIL THEN Atom.GetPName[prefix] ELSE NIL;
pre: ROPE ~ IF Rope.Size[prePName]>0 THEN prePName ELSE "xerox/tiogafonts/";
famSize: INT ~ Rope.Size[fam];
pos: ARRAY [0..4] OF INT ¬ ALL[famSize];
text ¬ RefText.AppendRope[text, pre];
FOR i: [0..4]
IN [0..4]
DO
pos1: INT ~ IF i=0 THEN 0 ELSE pos[i-1]+1;
s2: ROPE ~ SELECT i FROM 0 => "(", 4 => ")", ENDCASE => "|";
IF NOT (pos[i] ¬ Rope.Index[s1: fam, pos1: pos1, s2: s2])<famSize THEN EXIT;
ENDLOOP;
IF pos[4]<famSize
THEN {
n: [0..4) ~ faceIndex[face];
f1: INT ~ pos[n]+1;
f2: INT ~ pos[n+1];
text ¬ RefText.AppendRope[text, fam, 0, pos[0]]; -- prefix
text ¬ RefText.AppendRope[text, fam, f1, f2-f1]; -- face part
text ¬ RefText.AppendRope[text, fam, pos[4]+1]; -- suffix
}
ELSE {
faceEncoding: FaceEncoding ¬ boldItalic;
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;
preScaled ¬ p.first.preScaled;
faceEncoding ¬ p.first.faceEncoding;
};
ENDLOOP;
text ¬ RefText.AppendRope[text, fam];
SELECT faceEncoding
FROM
boldItalic => {
text ¬ RefText.AppendRope[text, boldItalicSuffix[face]];
IF sizeInName
THEN {
text ¬ RefText.AppendChar[text, '-];
text ¬ Convert.AppendInt[text, Real.Round[size]];
};
};
bir => {
IF sizeInName THEN ERROR;
text ¬ RefText.AppendRope[text, birSuffix[face]];
};
bi => {
IF sizeInName THEN text ¬ Convert.AppendInt[text, Real.Round[size]];
text ¬ RefText.AppendRope[text, biSuffix[face]];
};
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, preScaled: BOOL ¬ FALSE;
[text, sizeInName, preScaled] ¬ AppendFontName[text, prefix, family, face, size, alphabets];
name ¬ Rope.FromRefText[text];
IF preScaled THEN scale ¬ 1.0 ELSE scale ¬ size;
RefText.ReleaseScratch[scratch];
};
nTrys: NAT ~ 5;
tryDelta: ARRAY [0..nTrys) OF REAL ¬ [0, -0.999, 0.999, -1.998, 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, $Modern],
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], FALSE] THEN RETURN [f.first];
ENDLOOP;
RETURN [NIL];
};
FontReplacementProc:
PROC [prefix:
ATOM, family:
ATOM, face: FontFace, size:
REAL, alphabets: FontAlphabets]
RETURNS [font: Font] ¬
NIL;
Plug with debugger for experimentation purposes.
horribleHackForTioga10:
BOOL ¬
TRUE;
defaultPrintFont: Font ¬ NIL;
candidates:
LIST
OF
ROPE ¬
LIST[
"xerox/xc1-2-2/modern",
"xerox/pressfonts/helvetica-mrr"
];
GetDefaultFont:
PROC
RETURNS [Font] ~ {
FOR each:
LIST
OF
ROPE ¬ candidates, each.rest
WHILE defaultPrintFont =
NIL
DO
Address fault if none of the default candidates were found
defaultPrintFont ¬ ImagerFont.Find[each.first, substituteQuietly ! Imager.Error => CONTINUE];
ENDLOOP;
RETURN [defaultPrintFont]
};
GetFont:
PUBLIC
PROC [style: Style]
RETURNS [Font] ~ {
RETURN FontFromStyleParams[
prefix: NodeStyle.GetName[style, fontPrefix],
family: NodeStyle.GetName[style, fontFamily],
face: NodeStyle.GetFontFace[style],
size: NodeStyle.GetReal[style, fontSize],
alphabets: NodeStyle.GetFontAlphabets[style]
];
};
GetSpaceWidth:
PUBLIC
PROC [style: NodeStyle.Ref]
RETURNS [
REAL] ~ {
font: Font ~ GetFont[style];
RETURN[ImagerFont.Escapement[font, Char.Widen[' ]].x];
};
FontFromStyleParams:
PUBLIC
PROC [prefix:
ATOM, family:
ATOM, face: FontFace, size:
REAL, alphabets: FontAlphabets]
RETURNS [font: Font ¬
NIL] ~ {
didSubstitution: BOOL ¬ FALSE;
font ¬ CheckStyleFontCache[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, preScaled: BOOL ¬ FALSE;
trialFace: FontFace ¬ face;
WHILE font =
NIL
DO
This loop tries different faces.
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
This loop tries different families.
FOR try:
NAT
IN [0..nTrys)
WHILE font =
NIL
DO
This loop tries different sizes of screen fonts.
trialSize: REAL ¬ size + tryDelta[try];
text.length ¬ 0;
[text, sizeInName, preScaled] ¬ AppendFontName[text, prefix, trialFamily, trialFace, trialSize, alphabets];
font ¬ ImagerFont.Find[Rope.FromRefText[text], noSubstitute ! Imager.Error => CONTINUE];
IF font = NIL THEN didSubstitution ¬ TRUE;
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 trialFace = Regular THEN EXIT;
trialFace ¬ IF trialFace = BoldItalic THEN Bold ELSE IF trialFace = Bold AND face = BoldItalic THEN Italic ELSE Regular;
ENDLOOP;
IF font =
NIL
THEN {
Last chance!
<<IF sizeInName
AND Basics.IsBound[VFonts.EstablishFont]
THEN { font ¬ VFonts.DefaultFont[font]; preScaled ¬ TRUE } -- Probably not for printing
ELSE { font ¬ GetDefaultFont[]; preScaled ¬ FALSE }>>
{ font ¬ GetDefaultFont[]; preScaled ¬ FALSE };
};
IF NOT preScaled THEN { font ¬ ImagerFont.Scale[font, size] };
RefText.ReleaseScratch[scratch];
};
EnterStyleFontCache[[prefix, family, face, size, alphabets, font]];
};
IF didSubstitution
THEN {
text: REF TEXT ¬ RefText.ObtainScratch[100];
text ¬ RefText.AppendRope[text, "Substituting font "];
text ¬ RefText.AppendRope[text, ImagerFont.Name[font]];
text ¬ RefText.AppendRope[text, " for "];
text ¬ AppendFontName[text, prefix, family, face, size, alphabets].new;
SimpleFeedback.Append[$Tioga, oneLiner, $Warning, Rope.FromRefText[text] ];
RefText.ReleaseScratch[text];
};
};
Style Font Cache
styleFontCacheSize: NAT ¬ 25;
styleFontCache: LIST OF StyleFontCacheRec ¬ NIL;
styleFontCacheHits: INT ¬ 0;
styleFontCacheMisses:
INT ¬ 0;
StyleFontCacheRec:
TYPE ~
RECORD [prefix:
ATOM, family:
ATOM, face: FontFace, size:
REAL, alphabets: FontAlphabets, font: Font];
FlushStyleFontCache:
ENTRY
PROC ~ { styleFontCache ¬
NIL };
CheckStyleFontCache:
ENTRY
PROC [prefix:
ATOM, family:
ATOM, face: FontFace, size:
REAL, alphabets: FontAlphabets]
RETURNS [Font] ~ {
prev: LIST OF StyleFontCacheRec ¬ NIL;
FOR c:
LIST
OF StyleFontCacheRec ¬ styleFontCache, 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 ¬ styleFontCache;
styleFontCache ¬ c;
};
styleFontCacheHits ¬ styleFontCacheHits + 1;
RETURN [c.first.font];
};
prev ¬ c;
ENDLOOP;
styleFontCacheMisses ¬ styleFontCacheMisses + 1;
RETURN [NIL]
};
EnterStyleFontCache:
ENTRY
PROC [styleFontCacheRec: StyleFontCacheRec] ~ {
new: LIST OF StyleFontCacheRec ¬ NIL;
prev: LIST OF StyleFontCacheRec ¬ NIL;
i: NAT ¬ 2;
NB: The following code forces a styleFontCache size of >= 2
FOR p:
LIST
OF StyleFontCacheRec ¬ styleFontCache, p.rest
DO
IF p = NIL THEN {new ¬ LIST[styleFontCacheRec]; EXIT};
IF i >= styleFontCacheSize
AND p.rest#
NIL
THEN {
new ¬ p.rest;
p.rest ¬ NIL;
new.rest ¬ NIL;
new.first ¬ styleFontCacheRec;
EXIT;
};
i ¬ i + 1;
ENDLOOP;
new.rest ¬ styleFontCache;
styleFontCache ¬ new;
};
Color info
GetNamedColor:
PROC [style: NodeStyle.Style, name: NodeStyle.NameParam]
RETURNS [ImagerColor.Color] ~ {
a: ATOM ~ NodeStyle.GetName[style, name];
RETURN [IF a=NIL OR a=$nil THEN NIL ELSE ImagerColor.Find[Atom.GetPName[a]]];
};
GetHSBColor:
PROC [style: Style, h, s, b: NodeStyle.RealParam]
RETURNS [ImagerColor.Color] ~ {
brightness: REAL ~ NodeStyle.GetReal[style, b];
IF brightness = 0.0 THEN RETURN[Imager.black]
ELSE {
saturation: REAL ~ NodeStyle.GetReal[style, s];
IF saturation = 0.0 THEN RETURN[Imager.MakeGray[1.0-brightness]]
ELSE {
hue: REAL ~ NodeStyle.GetReal[style, h];
RETURN[ImagerColor.ColorFromHSV[H: hue, S: saturation, V: brightness]];
};
};
};
ColorParams:
TYPE ~
RECORD [name: NodeStyle.NameParam, h, s, b: NodeStyle.RealParam];
paramsFromColorParam:
ARRAY ColorParam
OF ColorParams ~ [
text: [name: textNamedColor,
h: textHue, s: textSaturation, b: textBrightness],
underline: [name: underlineNamedColor,
h: underlineHue, s: underlineSaturation, b: underlineBrightness],
strikeout: [name: strikeoutNamedColor,
h: strikeoutHue, s: strikeoutSaturation, b: strikeoutBrightness],
outlineBox: [name: outlineBoxNamedColor,
h: outlineBoxHue, s: outlineBoxSaturation, b: outlineBoxBrightness],
background: [name: backgroundNamedColor,
h: backgroundHue, s: backgroundSaturation, b: backgroundBrightness],
area: [name: areaNamedColor,
h: areaHue, s: areaSaturation, b: areaBrightness],
outline: [name: outlineNamedColor,
h: outlineHue, s: outlineSaturation, b: outlineBrightness]
];
GetColor:
PUBLIC
PROC [style: NodeStyle.Style, param: NodeStyle.ColorParam]
RETURNS [color: ImagerColor.Color] ~ {
p: ColorParams ~ paramsFromColorParam[param];
color ¬ GetNamedColor[style, p.name];
IF color = NIL THEN color ¬ GetHSBColor[style, p.h, p.s, p.b];
};