(* Copyright (C) 1992, Digital Equipment Corporation                         *)
(* All rights reserved.                                                      *)
(* See the file COPYRIGHT for a full description.                            *)
(*                                                                           *)
(* by Steve Glassman and Greg Nelson           *)
(* Last modified on Wed Jan 13 09:12:58 PST 1993 by steveg *)
(*      modified on Tue Jul  7 14:21:27 PDT 1992 by meehan *)
(*      modified on Tue Jun 16 13:08:22 PDT 1992 by muller *)
(*      modified on Sat Jun 13 08:02:57 1992 by mhb   *)

MODULE ScaleFilter;

IMPORT Axis, Filter, FilterClass, Font, Palette, Rd, ScrnFont,
       TextRd, TextWr, Thread, TrestleComm, VBT, VBTClass, VBTRep, Wr;

REVEAL
  Private = Filter.T BRANDED OBJECT END;
  T = Public BRANDED OBJECT
        stNew         : VBT.ScreenType := NIL;
        hscale, vscale                 := 1.0;
      OVERRIDES
        init     := Init;
        rescreen := Rescreen;
      END;

PROCEDURE Init (t: T; ch: VBT.T): T =
  BEGIN
    EVAL Filter.T.init(t, ch);
    RETURN t;
  END Init;

PROCEDURE New (ch: VBT.T): T =
  BEGIN
    RETURN NEW(T).init(ch)
  END New;

TYPE
  ScaledScreenType = VBT.ScreenType OBJECT
                 hscale, vscale                 := 1.0;
               METHODS
                 scale (hscale, vscale: REAL) := ScaleScreenType;
                 (* changes the res, scales all ScaledFonts in Palette *)
               END;

PROCEDURE ScaleScreenType (st: ScaledScreenType; hscale, vscale: REAL) =
  BEGIN
    st.hscale := st.hscale * hscale;
    st.res[Axis.T.Hor] := st.res[Axis.T.Hor] * hscale;
    st.vscale := st.vscale * vscale;
    st.res[Axis.T.Ver] := st.res[Axis.T.Ver] * vscale;
    FOR i := 0 TO LAST(st.fonts^) DO
      TYPECASE st.fonts[i] OF
      | NULL =>
      | ScaledFont (sf) => sf.scaleTo(st.hscale);
      ELSE
      END;
    END;
  END ScaleScreenType;

TYPE
  FontOracle =
    ScrnFont.Oracle OBJECT
      v: T;
    METHODS
      lookupScaled (name: TEXT; size: REAL; initialScale: REAL := 1.0):
                    ScrnFont.T := LookupScaled;
    OVERRIDES
      match   := Match;
      list    := List;
      lookup  := Lookup;
      builtIn := BuiltIn;
    END;

PROCEDURE LookupScaled (orc         : FontOracle;
                        name        : TEXT;
                        size        : REAL;
                        initialScale: REAL        ): ScrnFont.T =
  VAR sf := NEW(ScaledFont);
  BEGIN
    sf.orc := orc;
    sf.name := DeSize(name);
    sf.size := size;
    sf.scale := initialScale;
    TRY
      sf.matches := orc.list(sf.name, 1000);
    EXCEPT TrestleComm.Failure => sf.matches := NIL END;
    RETURN BestMatch(orc, sf);
  END LookupScaled;

TYPE
  ScaledFont = ScrnFont.T OBJECT
                 orc    : FontOracle;
                 name   : TEXT;
                 size   : REAL;
                 scale  : REAL;
                 matches: REF ARRAY OF TEXT := NIL;
                 current: ScrnFont.T;
               METHODS
                 scaleTo (scale: REAL) := ScaleFont;
               END;

PROCEDURE ScaleFont (sf: ScaledFont; scale: REAL) =
  BEGIN
    sf.scale := scale;
    EVAL BestMatch(sf.orc, sf);
  END ScaleFont;

CONST Inf = 999999999.9;

PROCEDURE BestMatch (orc: FontOracle; sf: ScaledFont): ScrnFont.T =
  VAR
    matches       := sf.matches;
    closest: TEXT;
    dist   : REAL := Inf;
    size          := sf.size;
    scale         := sf.scale;
  BEGIN
    IF matches = NIL THEN
      sf.current := NIL;
    ELSE
      dist := Inf;
      FOR i := 0 TO LAST(matches^) DO
        WITH d = ABS(PointSize(matches[i]) - scale * size) DO
          IF d < dist THEN closest := matches[i]; dist := d; END;
        END;
      END;
      TRY
        sf.current := orc.v.st.font.lookup(closest);
      EXCEPT
        ScrnFont.Failure, TrestleComm.Failure => sf.current := NIL
      END;
    END;
    IF sf.current = NIL THEN
      sf.current := orc.v.st.fonts[Font.BuiltIn.fnt]
    END;
    sf.id := sf.current.id;
    sf.metrics := sf.current.metrics;
    RETURN sf;
  END BestMatch;

(* Assumes name is an X style font name, pointsize is the integer OR
   REAL!!!  after 8 "-"s *)
PROCEDURE PointSize (name: TEXT): REAL =
  VAR
    rd                 := TextRd.New(name);
    int      : INTEGER := 0;
    ch       : CHAR;
    res, frac: REAL;
  BEGIN
    TRY
      FOR i := 1 TO 8 DO REPEAT UNTIL Rd.GetChar(rd) = '-'; END;
      ch := Rd.GetChar(rd);
    EXCEPT
      Rd.EndOfFile, Rd.Failure, Thread.Alerted => RETURN Inf
    END;

    TRY
      WHILE ORD(ch) >= ORD('0') AND ORD(ch) <= ORD('9') DO
        int := 10 * int + ORD(ch) - ORD('0');
        ch := Rd.GetChar(rd);
      END;
    EXCEPT
      Rd.EndOfFile, Rd.Failure, Thread.Alerted =>
    END;

    (* slightly inaccurate conversion to floating pt *)
    res := FLOAT(int) / 10.0;
    IF ch = '.' THEN
      TRY
        ch := Rd.GetChar(rd);
        frac := 0.1;
        WHILE ORD(ch) >= ORD('0') AND ORD(ch) <= ORD('9') DO
          res := res + FLOAT(ORD(ch) - ORD('0')) * frac;
          frac := frac / 10.0;
          ch := Rd.GetChar(rd);
        END;
      EXCEPT
        Rd.EndOfFile, Rd.Failure, Thread.Alerted =>
      END;
    END;
    IF res = 0.0 THEN RETURN Inf ELSE RETURN res END;
  END PointSize;

PROCEDURE DeSize (name: TEXT): TEXT =
  VAR
    rd       := TextRd.New(name);
    wr       := TextWr.New();
    ch: CHAR;
  <* FATAL Wr.Failure, Thread.Alerted *>
  BEGIN
    TRY
      (* copy up to pixelsize *)
      FOR i := 1 TO 7 DO
        ch := Rd.GetChar(rd);
        WHILE ch # '-' DO Wr.PutChar(wr, ch); ch := Rd.GetChar(rd); END;
        Wr.PutChar(wr, ch);
      END;
    EXCEPT
      Rd.EndOfFile, Rd.Failure, Thread.Alerted => RETURN name;
    END;

    TRY
      (* skip pixelsize, pointsize, hres, vres *)
      FOR i := 1 TO 4 DO
        ch := Rd.GetChar(rd);
        WHILE ch # '-' DO ch := Rd.GetChar(rd); END;
      END;
    EXCEPT
      Rd.EndOfFile, Rd.Failure, Thread.Alerted => RETURN name
    END;
    Wr.PutText(wr, "*-*-*-*-");

    TRY
      (* copy spacing *)
      ch := Rd.GetChar(rd);
      WHILE ch # '-' DO Wr.PutChar(wr, ch); ch := Rd.GetChar(rd); END;
      Wr.PutChar(wr, ch);
    EXCEPT
      Rd.EndOfFile, Rd.Failure, Thread.Alerted => RETURN name;
    END;

    TRY
      (* skip average width *)
      ch := Rd.GetChar(rd);
      WHILE ch # '-' DO ch := Rd.GetChar(rd); END;
    EXCEPT
      Rd.EndOfFile, Rd.Failure, Thread.Alerted => RETURN name
    END;
    Wr.PutText(wr, "*-");

    TRY
      (* copy registry *)
      ch := Rd.GetChar(rd);
      WHILE ch # '-' DO Wr.PutChar(wr, ch); ch := Rd.GetChar(rd); END;
      Wr.PutChar(wr, ch);
    EXCEPT
      Rd.EndOfFile, Rd.Failure, Thread.Alerted => RETURN name;
    END;

    LOOP
      TRY
        (* copy charset *)
        ch := Rd.GetChar(rd);
        Wr.PutChar(wr, ch);
      EXCEPT
      | Rd.EndOfFile => EXIT;
      | Rd.Failure, Thread.Alerted => RETURN name;
      END;
    END;
    RETURN TextWr.ToText(wr);
  END DeSize;

PROCEDURE BuiltIn(orc: FontOracle; f: Font.Predefined): ScrnFont.T =
  BEGIN
    RETURN orc.v.st.bits.font.builtIn(f);
  END BuiltIn;

PROCEDURE List (orc: FontOracle; pat: TEXT; maxResults: INTEGER):
  REF ARRAY OF TEXT RAISES { TrestleComm.Failure} =
  BEGIN
    RETURN orc.v.st.bits.font.list(pat, maxResults)
  END List;

PROCEDURE Lookup (orc: FontOracle; name: TEXT): ScrnFont.T
  RAISES {ScrnFont.Failure, TrestleComm.Failure} =
  VAR size := PointSize(name);
  BEGIN
    IF size = Inf THEN
      RETURN orc.v.st.bits.font.lookup(name)
    ELSE
      RETURN orc.lookupScaled(name, size, orc.v.hscale)
    END;
  END Lookup;

PROCEDURE Match (             orc      : FontOracle;
                              family   : TEXT;
                 <* UNUSED *> pointSize: INTEGER      := 120;
                 slant     : ScrnFont.Slant := ScrnFont.Slant.Roman;
                 maxResults: CARDINAL       := 1;
                 weightName: TEXT           := ScrnFont.AnyMatch;
                 version   : TEXT           := "";
                 foundry   : TEXT           := ScrnFont.AnyMatch;
                 width     : TEXT           := ScrnFont.AnyMatch;
                 <* UNUSED *> pixelsize: INTEGER := ScrnFont.AnyValue;
                 <* UNUSED *> hres, vres: INTEGER := ScrnFont.ScreenTypeResolution;
                 spacing: ScrnFont.Spacing := ScrnFont.Spacing.Any;
                 <* UNUSED *> averageWidth: INTEGER := ScrnFont.AnyValue;
                 charsetRegistry: TEXT := "ISO8859";
                 charsetEncoding: TEXT := "1"        ): REF ARRAY OF TEXT
  RAISES {TrestleComm.Failure} =
  VAR
    matches := orc.v.st.bits.font.match(
                 family, ScrnFont.AnyValue, slant, maxResults, weightName,
                 version, foundry, width, ScrnFont.AnyValue,
                 ScrnFont.ScreenTypeResolution,
                 ScrnFont.ScreenTypeResolution, spacing, ScrnFont.AnyValue,
                 charsetRegistry, charsetEncoding);
  BEGIN
    RETURN matches;
  END Match;

PROCEDURE InitST (t                : T;
                  stNew: ScaledScreenType;  st, stBits: VBT.ScreenType;
                  hscale, vscale   : REAL            ) =
  BEGIN
    stNew.depth := st.depth;
    stNew.color := st.color;
    stNew.res := st.res;
    stNew.bg := st.bg;
    stNew.fg := st.fg;
    stNew.bits := stBits;
    stNew.op := st.op;
    stNew.cursor := st.cursor;
    stNew.font := NEW(FontOracle, v := t);
    stNew.pixmap := st.pixmap;
    stNew.cmap := st.cmap;
    Palette.Init(stNew);
    stNew.scale(hscale, vscale);
  END InitST;

PROCEDURE NewST (t: T; st: VBT.ScreenType; hscale, vscale: REAL):
  VBT.ScreenType =
  VAR stBits, stNew: VBT.ScreenType;
  BEGIN
    stBits := NEW(ScaledScreenType);
    InitST(t, stBits, st.bits, stBits, hscale, vscale);
    stNew := NEW(ScaledScreenType);
    InitST(t, stNew, st, stBits, hscale, vscale);
    RETURN stNew;
  END NewST;

PROCEDURE Rescreen (t: T; READONLY cd: VBT.RescreenRec) =
  BEGIN
    Scale1(t, cd.st);
  END Rescreen;

PROCEDURE Scale1 (t: T; st: VBT.ScreenType) =
  BEGIN
    IF st = NIL OR (t.hscale > 0.9 AND t.hscale < 1.1 AND t.vscale > 0.9
         AND t.vscale < 1.1) THEN
      t.stNew := st
    ELSE
      t.stNew := NewST(t, st, t.hscale, t.vscale);
    END;
    IF t.ch # NIL THEN VBTClass.Rescreen(t.ch, t.stNew); END;
  END Scale1;

PROCEDURE Child(t: T): VBT.T =
  BEGIN RETURN t.ch END Child;

PROCEDURE Get (t: T; VAR hscale, vscale: REAL) =
  BEGIN
    hscale := t.hscale;
    vscale := t.vscale;
  END Get;

PROCEDURE Scale (t: T; hscale, vscale: REAL) =
  BEGIN
    t.hscale := t.hscale * hscale;
    t.vscale := t.vscale * vscale;
    TYPECASE t.stNew OF
    | NULL => IF t.st # NIL THEN Scale1(t, t.st) END;
    | ScaledScreenType (sst) => sst.scale(hscale, vscale); VBT.Mark(t);
    ELSE
      Scale1(t, t.st);
    END;
    VBT.NewShape(t);
    VBT.Mark(t)
  END Scale;

BEGIN
END ScaleFilter.