
    <<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];

    NodeStyleFontImpl: CEDAR MONITOR
    IMPORTS Atom, Convert, Real, Rope, RefText, Imager, ImagerFont, VFonts
    EXPORTS NodeStyleFont
    ~ 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;
    cacheMisses: 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;
        };

    END.