MODULE VTView;

IMPORT Axis, Font, Rd, Rect, RefList, RefListSort, PaintOp, Palette, Point,
       Pts, ScrnFont, Thread, VBT, VTDef, VTVirtual, VTReal,
       VTCaret;

TYPE
  Pixels = VTDef.Pixels;
  RealLines = VTDef.RealLines;
  VirtualLines = VTDef.VirtualLines;
  VScreenFont = VTDef.VScreenFont;

PROCEDURE New (         vt      : T;
                        vbt     : VBT.T;
               READONLY full    : Rect.T;
               READONLY vOptions: VOptions;
                        start   : I         ): View
  RAISES {Rd.EndOfFile, Rd.Failure, Thread.Alerted} =
  BEGIN
    WITH leading = Pts.ToScreenPixels (
                     vbt, vOptions.leadingPts, Axis.T.Ver),
         vScreenFont = MakeVScreenFont (vOptions.vFontxxx, vbt, leading),
         box         = vScreenFont.box,
         view = NEW (View, vt := vt, vbt := vbt, vOptions := vOptions,
                     vScreenFont := vScreenFont,
                     lineSpacing := box.south - box.north + leading) DO
      view.real.line := NEW (RealLines, 1);
      view.real.blocks.block := NEW (VTDef.BlockArray, 1);
      view.virtual.line := NEW (VirtualLines, 1);
      view.newVirtual.line := NEW (VirtualLines, 1);
      SetLocation (view, full, full);
      VTReal.Init (view);
      VTVirtual.Init (view, start);
      LOCK vt.caret.mutex DO
        VTCaret.InitInView (view);
        view.next := vt.views;
        view.previous := NIL;
        IF vt.views # NIL THEN vt.views.previous := view; END;
        vt.views := view;
      END;
      RETURN view
    END
  END New;

VAR
  vFontList      : RefList.T := NIL;
  vScreenFontList: RefList.T := NIL;
  vFontMutex                 := NEW(MUTEX);
  (* vFontQ: ObjectCleanUp.Q; *)
  timeToCleanup := NEW(Thread.Condition);
  handouts      := 0;

CONST
  handoutMax = 100;             (* After 100 handouts, call cleanup *)
  handoutMin = 10;              (* vFonts that haven't been handed out at
                                   least 10 times get removed from the
                                   cache. *)

PROCEDURE MakeVFont (         font     : Font.T;
                     READONLY printable: SET OF CHAR;
                              whiteTabs: BOOLEAN      ): VFont =
  VAR vL: RefList.T;
  BEGIN
    LOCK vFontMutex DO
      vL := vFontList;
      WHILE vL # NIL DO
        WITH v = NARROW (vL.head, VFont) DO
          IF v.font.fnt = font.fnt AND v.printable = printable
               AND v.whiteTabs = whiteTabs THEN
            INC (v.handedOut);
            INC (handouts);
            IF handouts > handoutMax THEN
              Thread.Signal (timeToCleanup);
              handouts := 0
            END;
            RETURN v
          END
        END;
        vL := vL.tail;
      END;
      WITH vFont = NEW (VFont, handedOut := 0) DO
        vFont.font := font;
        vFont.printable := printable;
        vFont.whiteTabs := whiteTabs;
        vFontList := RefList.Cons (vFont, vFontList);
        RETURN vFont
      END
    END
  END MakeVFont;

PROCEDURE VFontCleanUpThread (<* UNUSED *> cl: Thread.Closure): REFANY =
  VAR
    vfl: RefList.T;
    n              := 0;
  BEGIN
    LOOP                         (* forever *)
      LOCK vFontMutex DO
        Thread.Wait (vFontMutex, timeToCleanup);
        vfl := RefListSort.SortD (vFontList, CompareHandouts);
        WHILE vfl # NIL AND NARROW (vfl.head, VFont).handedOut < handoutMin DO
          INC (n);
          vfl := vfl.tail        (* remove this from the cache *)
        END;
        vFontList := RefList.ReverseD (vfl) (* popular ones near the front *)
      END
    END;
  END VFontCleanUpThread;

PROCEDURE CompareHandouts (xx, yy: REFANY): [-1 .. 1] =
  VAR
    x: VFont := xx;
    y: VFont := yy;
  BEGIN
    IF x.handedOut < y.handedOut THEN
      RETURN -1
    ELSIF x.handedOut = y.handedOut THEN
      RETURN 0
    ELSE
      RETURN 1
    END
  END CompareHandouts;

PROCEDURE MakeVOptions (vFont: VFont;
                        leftMargin, rightMargin, turnMargin, topMargin,
                          leading: Points;
                        whiteBlack, whiteStroke: ColorScheme;
                        leftOffset             : Points;
                        wrap                   : BOOLEAN;
                        eob                    : BOOLEAN;
                        intervalStylePrecedence: IntervalStylePrecedence):
  VOptions =
  VAR vOptions: VOptions;
  BEGIN
    vOptions.vFontxxx := vFont;
    vOptions.leftMarginPts := leftMargin;
    vOptions.rightMarginPts := rightMargin;
    vOptions.turnMarginPts := turnMargin;
    vOptions.topMarginPts := topMargin;
    vOptions.leadingPts := leading;
    vOptions.whiteBlack := whiteBlack;
    vOptions.whiteStroke := whiteStroke;
    vOptions.leftOffsetPts := leftOffset;
    vOptions.wrap := wrap;
    vOptions.eob := eob;
    vOptions.intervalStylePrecedence := intervalStylePrecedence;
    RETURN vOptions;
  END MakeVOptions;

PROCEDURE Close (view: View) =
  BEGIN
    WITH z_111 = view^ DO
      LOCK z_111.vt.caret.mutex DO
        IF z_111.previous = NIL THEN
          z_111.vt.views := z_111.next;
        ELSE
          z_111.previous.next := z_111.next;
        END;
        IF z_111.next # NIL THEN
          z_111.next.previous := z_111.previous;
        END;
        (* DISPOSE (view); *)
      END;
    END;
  END Close;

PROCEDURE Move (view: View; READONLY full, saved: Rect.T; scroll: BOOLEAN)
  RAISES {Rd.EndOfFile, Rd.Failure, Thread.Alerted} =
  VAR
    oFull, oClip, okClip: Rect.T;
    delta               : Point.T;
    f                   : Rect.Partition;
  BEGIN
    oFull := view.rect.full;
    oClip :=
      Rect.Meet (
        Rect.Meet (view.rect.clip, saved),
        Rect.MoveEdge (view.rect.full, Rect.Edge.S,
                       view.rect.text.south - view.rect.full.south));
    delta := Point.Sub (Rect.NorthWest (full), Rect.NorthWest (oFull));
    SetLocation (view, full, Rect.Move (view.rect.bad, delta));
    IF view.rect.full.east - view.rect.full.west = oFull.east - oFull.west
      THEN
      VTVirtual.Resize (view, view.nLines);
      IF (scroll OR ((delta.h = 0) AND (delta.v = 0)))
           AND NOT Rect.IsEmpty (oClip) THEN
        VTCaret.Deactivate (view);
        TRY
          VTReal.Resize (view, view.nLines);
          okClip :=
            Rect.Meet (
              Rect.Meet (full, Rect.MoveEdge (full, Rect.Edge.S,
                                              view.rect.text.south
                                                - view.rect.full.south)),
              Rect.Move (oClip, delta));
          VBT.Scroll (view.vbt, okClip, delta, PaintOp.Copy);
          Rect.Factor (full, okClip, f, 0, 0);
          VTReal.Bad (view, f [0]);
          VTReal.Bad (view, f [1]);
          VTReal.Bad (view, f [3]);
          VTReal.Bad (view, f [4]);
        FINALLY
          VTCaret.Reactivate (view);
        END;
      ELSE
        VTReal.Bad (view, view.rect.clip);
      END;
    ELSE
      VTVirtual.Bad (view);
      VTReal.Bad (view, view.rect.clip);
    END;
  END Move;

PROCEDURE Rescreen (view: View; <* UNUSED *> READONLY cd: VBT.RescreenRec) =
  VAR
    leading := Pts.ToScreenPixels (
                 view.vbt, view.vOptions.leadingPts, Axis.T.Ver);
  BEGIN
    view.vScreenFont :=
      MakeVScreenFont (view.vOptions.vFontxxx, view.vbt, leading);
    view.lineSpacing :=
      view.vScreenFont.box.south - view.vScreenFont.box.north + leading;
  END Rescreen;

PROCEDURE SetPixelOptions (VAR vo: VOptions; v: VBT.T) =
  BEGIN
    vo.leftMargin := Pts.ToScreenPixels (v, vo.leftMarginPts, Axis.T.Hor);
    vo.rightMargin :=
      Pts.ToScreenPixels (v, vo.rightMarginPts, Axis.T.Hor);
    vo.turnMargin := Pts.ToScreenPixels (v, vo.turnMarginPts, Axis.T.Hor);
    vo.topMargin := Pts.ToScreenPixels (v, vo.topMarginPts, Axis.T.Ver);
    vo.leading := Pts.ToScreenPixels (v, vo.leadingPts, Axis.T.Ver);
    vo.leftOffset := Pts.ToScreenPixels (v, vo.leftOffsetPts, Axis.T.Hor);
  END SetPixelOptions;

PROCEDURE SetLocation (view: View; READONLY full, bad: Rect.T) =
  VAR
    nLines0, nLines1: INTEGER;
    newRealLine     : RealLines;
    newVirtualLine  : VirtualLines;
    text            : Rect.T;
  BEGIN
    WITH vo = view.vOptions DO
      SetPixelOptions (vo, view.vbt);
      view.rect.full := full;
      view.rect.clip := full;
      nLines0 := view.nLines;
      nLines1 := MAX (0, (full.south - (full.north + vo.topMargin))
                           DIV view.lineSpacing);
      view.nLines := nLines1;
      IF nLines1 > LAST (view.real.line^) THEN
        newRealLine := NEW (RealLines, nLines1 + 1);
        FOR i := 0 TO LAST (view.real.line^) DO
          newRealLine [i] := view.real.line [i];
        END;
        view.real.line := newRealLine;
        view.real.blocks.block :=
          NEW (VTDef.BlockArray, nLines1 + 1);
        newVirtualLine := NEW (VirtualLines, nLines1 + 1);
        FOR i := 0 TO LAST (view.virtual.line^) DO
          newVirtualLine [i] := view.virtual.line [i];
        END;
        view.virtual.line := newVirtualLine;
        newVirtualLine := NEW (VirtualLines, nLines1 + 1);
        FOR i := 0 TO LAST (view.newVirtual.line^) DO
          newVirtualLine [i] := view.newVirtual.line [i];
        END;
        view.newVirtual.line := newVirtualLine;
      END;
      text := Rect.FromEdges (
                view.rect.full.west + vo.leftMargin + vo.turnMargin,
                view.rect.full.east - vo.rightMargin - vo.turnMargin,
                view.rect.full.north + vo.topMargin,
                view.rect.full.north + vo.topMargin
                  + view.nLines * view.lineSpacing);
      view.rect.textClip := Rect.Meet (text, view.rect.clip);
      IF view.vOptions.wrap THEN
        view.rect.text :=
          Rect.FromEdges (
            text.west - vo.leftOffset, text.east, text.north, text.south);
      ELSE
        view.rect.text :=
          Rect.FromEdges (text.west - vo.leftOffset, LAST (Pixels) DIV 2,
                          text.north, text.south);
      END;
      view.lineWidth := view.rect.text.east - view.rect.text.west;
      view.rect.bad := Rect.Meet (bad, view.rect.clip)
    END
  END SetLocation;

PROCEDURE MakeVScreenFont (vFont: VFont; vbt: VBT.T; leading: CARDINAL):
  VScreenFont =
  VAR
    vScreenFont: VScreenFont;
    metrics    : ScrnFont.Metrics;
  PROCEDURE Find (vFont: VFont; metrics: ScrnFont.Metrics): VScreenFont =
    BEGIN
      VAR list := vScreenFontList;
      BEGIN
        WHILE list # NIL DO
          VAR x: VScreenFont := list.head;
          BEGIN
            list := list.tail;
            IF x.vFont = vFont AND x.metrics = metrics THEN
              RETURN x
            END
          END
        END
      END;
      RETURN NIL
    END Find;
  BEGIN
    metrics := FontMetrics (vbt, vFont.font);
    IF metrics = NIL THEN RETURN MakeBadVScreenFont (vFont); END;

    IF (metrics.maxBounds.boundingBox.south
          - metrics.maxBounds.boundingBox.north) + leading < 2 THEN
      RETURN MakeBadVScreenFont (vFont);
    END;

    LOCK vFontMutex DO
      vScreenFont := Find (vFont, metrics);
      IF vScreenFont # NIL THEN RETURN vScreenFont; END;
    END;

    vScreenFont := UncachedMakeVScreenFont (vFont, metrics);

    LOCK vFontMutex DO
      IF Find (vFont, metrics) = NIL THEN
        vScreenFontList := RefList.Cons (vScreenFont, vScreenFontList);
      END;
    END;

    RETURN vScreenFont;
  END MakeVScreenFont;

PROCEDURE UncachedMakeVScreenFont (vFont: VFont; metrics: ScrnFont.Metrics):
  VScreenFont =
  VAR
    vScreenFont: VScreenFont;
    bsWidth    : INTEGER;
    oneChar    : SET OF CHAR;
  BEGIN
    vScreenFont := NEW(VScreenFont);
    vScreenFont.vFont := vFont;
    vScreenFont.box := metrics.maxBounds.boundingBox;
    vScreenFont.paintOpaque := metrics.selfClearing
                     AND NOT (metrics.leftKerning OR metrics.rightKerning);

    FOR c := FIRST(CHAR) TO LAST(CHAR) DO
      vScreenFont.width[c] := 0;
    END;
    vScreenFont.defined := SET OF CHAR{};

    FOR i := ORD(FIRST(CHAR)) TO ORD(LAST(CHAR)) DO
      VAR c := VAL(i, CHAR);  print_i := i;
      BEGIN
        IF c IN vFont.printable THEN
          IF (ORD(c) < metrics.firstChar) OR (metrics.lastChar < ORD(c)) THEN
            print_i := metrics.defaultChar;
          END;
          IF (print_i < metrics.firstChar) OR (metrics.lastChar < print_i) THEN
            vScreenFont.width[c] := 0;
          ELSIF metrics.charMetrics # NIL THEN
            vScreenFont.width[c] :=
                metrics.charMetrics[print_i - metrics.firstChar].printWidth;
          ELSE
            vScreenFont.width[c] := metrics.maxBounds.printWidth;
          END;
          IF vScreenFont.width[c] # 0 THEN
            oneChar := SET OF CHAR{c};  (* temp to work around compiler bug *)
            vScreenFont.defined := vScreenFont.defined + oneChar;
          END;
        END;
      END;
    END;

    WITH fnt = vScreenFont DO
      IF SET OF CHAR{' ', '\\', '0'.. '7'} - fnt.defined # SET OF CHAR{} THEN
        RETURN MakeBadVScreenFont(vFont);
      END;

      bsWidth := fnt.width['\\'];
      FOR c := FIRST(CHAR) TO LAST(CHAR) DO
        IF NOT (c IN fnt.defined) THEN
          fnt.width[c] :=
            bsWidth + fnt.width[VAL(ORD(c) DIV 64 + ORD('0'), CHAR)]
                    + fnt.width[VAL(ORD(c) DIV 8 MOD 8 + ORD('0'), CHAR)]
                    + fnt.width[VAL(ORD(c) MOD 8 + ORD('0'), CHAR)];
        END;
      END;

      fnt.width['\n'] := 1;
      fnt.defined := fnt.defined - SET OF CHAR{'\n'};

      IF '\t' IN vFont.printable THEN
        fnt.width['\t'] := 8 * fnt.width[' '];
        fnt.defined := fnt.defined - SET OF CHAR{'\t'};
      END;

      fnt.metrics := metrics;
    END;
    RETURN vScreenFont;
  END UncachedMakeVScreenFont;

PROCEDURE MakeBadVScreenFont (vFont: VFont): VScreenFont =
  CONST A = FIRST(INTEGER) DIV 4;  B = LAST(INTEGER) DIV 4;
  VAR vScreenFont := NEW(VScreenFont);
  BEGIN
    vScreenFont.vFont := vFont;
    vScreenFont.box := Rect.FromEdges(A, B, A, B);
    FOR c := FIRST(CHAR) TO LAST(CHAR) DO
      vScreenFont.width[c] := B - A;
    END;
    vScreenFont.defined := SET OF CHAR{FIRST(CHAR) .. LAST(CHAR)};
    vScreenFont.paintOpaque := TRUE;
    vScreenFont.metrics := NIL;
    RETURN vScreenFont;
  END MakeBadVScreenFont;

PROCEDURE FontMetrics (v: VBT.T; fnt: Font.T): ScrnFont.Metrics =
  BEGIN
    WITH screentype = VBT.ScreenTypeOf(v) DO
      IF screentype = NIL THEN
        RETURN NIL
      ELSE
        RETURN Palette.ResolveFont(screentype, fnt).metrics
      END
    END
  END FontMetrics;

PROCEDURE Init () =
  BEGIN
    (* -- vFontQ := ObjectCleanUp.NewQ (); ObjectCleanUp.EstablishCleanUp
       (TYPECODE (VFont), 1, vFontQ); -- *)
    EVAL Thread.Fork(NEW(Thread.Closure, apply := VFontCleanUpThread));
  END Init;

BEGIN
  Init();
END VTView.