MODULE ScaleFilter;

IMPORT Axis, Cursor, Filter, FilterClass, Font, JoinScreen,
       MultiFilter, MultiClass, PaintOp, Palette, Pixmap, Rd,
       Rect, ScrnCursor, ScrnFont, ScrnPaintOp, ScrnPixmap,
       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;
        auto                                   := FALSE;
        keepAspectRatio       : BOOLEAN;
        oldHorSize, oldVerSize                 := 0.0;
      OVERRIDES
        init     := Init;
        rescreen := Rescreen;
        reshape  := Reshape;
      END;

TYPE
  MC = MultiClass.Filter OBJECT
       OVERRIDES
         succ    := Succ;
         pred    := Succ;
         replace := Replace;
       END;

PROCEDURE Replace (m: MC; ch: VBT.T; new: VBT.T) =
  BEGIN
    WITH holder = Filter.Child(m.vbt) DO
      <* ASSERT ch = Filter.Child(holder) *>
      EVAL Filter.Replace(holder, new);
    END
  END Replace;

PROCEDURE Succ (m: MC; ch: VBT.T): VBT.T =
  BEGIN
    WITH holder = Filter.Child(m.vbt) DO
      IF ch = NIL THEN
        RETURN Filter.Child(holder)
      ELSE
        <* ASSERT ch = Filter.Child(holder) *>
        RETURN NIL
      END
    END
  END Succ;

PROCEDURE Init (t: T; ch: VBT.T): T =
  VAR holder := NEW(Filter.T).init(ch);
  BEGIN
    EVAL Filter.T.init(t, holder);
    MultiClass.Be(t, NEW(MC));
    MultiClass.BeChild(t, ch);
    RETURN t;
  END Init;

PROCEDURE Reshape (t: T; READONLY cd: VBT.ReshapeRec) =
  BEGIN
    IF t.auto THEN AutoReshape(t, cd) END;
    Filter.T.reshape(t, cd)
  END Reshape;

TYPE
  ScaledScreenType =
    VBT.ScreenType OBJECT
      unscaledRes   : ARRAY Axis.T OF REAL;
      hscale, vscale                         := 1.0;
      stParent      : VBT.ScreenType;
    METHODS
      scale       (hscale, vscale: REAL) := ScaleScreenType;
      (* changes the res, scales all ScaledFonts in Palette *)
    OVERRIDES
      opApply                            := ScaleOpApply;
      cursorApply                        := ScaleCursorApply;
      pixmapApply                        := ScalePixmapApply;
      fontApply                          := ScaleFontApply;
    END;

PROCEDURE ScaleOpApply (             st: ScaledScreenType;
                        <* UNUSED *> cl: Palette.OpClosure;
                                     op: PaintOp.T          ):
  ScrnPaintOp.T =
  BEGIN
    RETURN Palette.ResolveOp(st.stParent, op);
  END ScaleOpApply;

PROCEDURE ScaleCursorApply (             st: ScaledScreenType;
                            <* UNUSED *> cl: Palette.CursorClosure;
                                         cs: Cursor.T               ):
  ScrnCursor.T =
  BEGIN
    RETURN Palette.ResolveCursor(st.stParent, cs);
  END ScaleCursorApply;

PROCEDURE ScalePixmapApply (             st: ScaledScreenType;
                            <* UNUSED *> cl: Palette.PixmapClosure;
                                         pm: Pixmap.T               ):
  ScrnPixmap.T =
  BEGIN
    RETURN Palette.ResolvePixmap(st.stParent, pm);
  END ScalePixmapApply;

PROCEDURE ScaleFontApply (st  : ScaledScreenType;
                          cl  : Palette.FontClosure;
                          font: Font.T                 ): ScrnFont.T =
  BEGIN
    IF cl =  NIL THEN
      (* builtin *)
      RETURN Palette.ResolveFont(st.stParent, font);
    ELSE
      RETURN VBT.ScreenType.fontApply(st, cl, font);
    END;
  END ScaleFontApply;

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

TYPE
  FontOracle =
    ScrnFont.Oracle OBJECT
      st: ScaledScreenType;
    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 OR NUMBER(matches^) = 0 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.st.stParent.font.lookup(closest);
      EXCEPT
        ScrnFont.Failure, TrestleComm.Failure => sf.current := NIL
      END;
    END;
    IF sf.current = NIL THEN
      sf.current := orc.st.stParent.fonts[Font.BuiltIn.fnt]
    END;
    sf.id := sf.current.id;
    sf.metrics := sf.current.metrics;
    RETURN sf;
  END BestMatch;

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 *)
    IF ch = '.' THEN
      res := FLOAT(int);
      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;
    ELSE
      (* integer measurements are in 1/10 points *)
      res := FLOAT(int) / 10.0;
    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.st.stParent.bits.font.builtIn(f);
  END BuiltIn;

PROCEDURE List (orc: FontOracle; pat: TEXT; maxResults: INTEGER):
  REF ARRAY OF TEXT RAISES { TrestleComm.Failure} =
  BEGIN
    (* !!!!TEMPORARY (until msm fixes JoinFont oracle !!!!! *)
    IF ISTYPE (orc.st.stParent, JoinScreen.T) THEN RETURN NIL END;
    (* !!!!TEMPORARY (until msm fixes JoinFont oracle !!!!! *)
    RETURN orc.st.stParent.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
    (* !!!!TEMPORARY (until msm fixes JoinFont oracle !!!!! *)
    IF ISTYPE(orc.st.stParent, JoinScreen.T) THEN
      RETURN Palette.ResolveFont(orc.st.stParent, Font.BuiltIn)
    END;
    (* !!!!TEMPORARY (until msm fixes JoinFont oracle !!!!! *)
    IF size = Inf THEN
      RETURN orc.st.stParent.bits.font.lookup(name)
    ELSE
      RETURN
        orc.lookupScaled(name, size, MIN(orc.st.hscale, orc.st.vscale))
    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} =
  BEGIN
    (* !!!!TEMPORARY (until msm fixes JoinFont oracle !!!!! *)
    IF ISTYPE(orc.st.stParent, JoinScreen.T) THEN RETURN NIL END;
    (* !!!!TEMPORARY (until msm fixes JoinFont oracle !!!!! *)
    RETURN orc.st.stParent.bits.font.match(
             family, ScrnFont.AnyValue, slant, maxResults, weightName,
             version, foundry, width, ScrnFont.AnyValue,
             ScrnFont.ScreenTypeResolution, ScrnFont.ScreenTypeResolution,
             spacing, ScrnFont.AnyValue, charsetRegistry, charsetEncoding);
  END Match;

PROCEDURE InitST (stNew: ScaledScreenType;  st, stBits: VBT.ScreenType;
                  hscale, vscale   : REAL            ) =
  BEGIN
    stNew.stParent := st;
    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, st := stNew);
    stNew.pixmap := st.pixmap;
    stNew.cmap := st.cmap;
    stNew.unscaledRes := st.res;
    Palette.Init(stNew);
    stNew.scale(hscale, vscale);
  END InitST;

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

PROCEDURE Rescreen (t: T; READONLY cd: VBT.RescreenRec) =
  BEGIN
    t.oldHorSize := 0.0;
    t.oldVerSize := 0.0;
    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(st, t.hscale, t.vscale)
    END;
    IF t.ch # NIL THEN VBTClass.Rescreen(t.ch, t.stNew); END;
  END Scale1;

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.auto := FALSE;
    IF hscale # t.hscale OR vscale # t.vscale THEN
      ChangeScale(t, hscale, vscale);
    END;
  END Scale;

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

PROCEDURE AutoScale (t: T; keepAspectRatio := FALSE) =
  BEGIN
    t.auto := TRUE;
    t.keepAspectRatio := keepAspectRatio;
    VBT.Mark(t);
  END AutoScale;

PROCEDURE AutoReshape (t: T; READONLY cd: VBT.ReshapeRec) =
  VAR
    ch            := MultiFilter.Child(t);
    dom           := cd.new;
    sx, sy : REAL;
    horSize       := FLOAT(Rect.HorSize(dom));
    verSize       := FLOAT(Rect.VerSize(dom));
  BEGIN
    IF ch # NIL AND NOT Rect.IsEmpty(dom) THEN
      IF t.oldHorSize = 0.0 AND t.oldVerSize = 0.0 THEN
        VAR sz := VBTClass.GetShapes(ch, TRUE);
        BEGIN
          IF sz[Axis.T.Hor].pref = 0 OR sz[Axis.T.Ver].pref = 0 THEN
            sx := 1.0;
            sy := 1.0;
          ELSE
            sx := horSize / FLOAT(sz[Axis.T.Hor].pref);
            sy := verSize / FLOAT(sz[Axis.T.Ver].pref);
          END;
        END;
      ELSE
        sx := horSize / t.oldHorSize;
        sy := verSize / t.oldVerSize;
      END;
      IF t.keepAspectRatio THEN sx := MIN(sx, sy); sy := sx; END;
      IF sx < 0.95 OR sx > 1.05 OR sy < 0.95 OR sy > 1.05 THEN
        t.oldHorSize := horSize;
        t.oldVerSize := verSize;
        ChangeScale(t, t.hscale * sx, t.vscale * sy);
      END;
    END;
  END AutoReshape;

BEGIN
END ScaleFilter.