<* PRAGMA LL *>

MODULE NumericVBT;

IMPORT Axis, AnyEvent, Filter, Font, FlexVBT, FloatMode, Fmt, HVSplit, Lex,
       Pixmap, PixmapVBT, Rd, Rect, Shadow, ShadowedFeedbackVBT, ShadowedVBT,
       Text, TextPort, TextPortClass, TextRd, TextureVBT, Thread,
       TrillSwitchVBT, TypeinVBT, VBT, VBTKitResources, VText;

REVEAL
  T = Public BRANDED OBJECT
        (* create-time options: *)
        allowEmpty: BOOLEAN;
        (* changable options: *)
        min, max: INTEGER;
        (* current state: *)
        val   : INTEGER;
        digits: CARDINAL := 0;
        empty : BOOLEAN;
      OVERRIDES
        init     := Init;
        callback := Callback;
      END;
  Typein = TypeinVBT.T BRANDED OBJECT
             v: T
           OVERRIDES
             returnAction := ReturnAction;
             reshape      := Reshape
           END;

TYPE
  State = RECORD
            num  : INTEGER;
            empty: BOOLEAN
          END;

PROCEDURE Init (v         : T;
                min       : INTEGER  := FIRST (INTEGER);
                max       : INTEGER  := LAST (INTEGER);
                allowEmpty: BOOLEAN  := FALSE;
                naked     : BOOLEAN  := FALSE;
                font      : Font.T   := Font.BuiltIn;
                shadow    : Shadow.T := NIL              ): T =
  VAR hsplit, minus, plus: VBT.T;
  BEGIN
    IF shadow = NIL THEN shadow := Shadow.None END;
    GetResources ();
    max := MAX (min, max);
    v.allowEmpty := allowEmpty;
    v.min := min;
    v.max := max;
    IF v.typein = NIL THEN v.typein := NEW (Typein) END;
    v.typein := v.typein.init (FALSE, 0.5, 0.5, font, shadow, wrap := FALSE);
    v.typein.v := v;
    IF min <= 0 AND 0 <= max THEN
      PutCl (v, State {0, allowEmpty})
    ELSE
      PutCl (v, State {min, allowEmpty})
    END;
    IF naked THEN
      EVAL Filter.T.init (v, NEW (ShadowedVBT.T).init (
                               v.typein, shadow, Shadow.Style.Lowered));
    ELSE
      minus := NewPlusMinusVBT (v, -1, shadow, minusOff);
      plus := NewPlusMinusVBT (v, 1, shadow, plusOff);
      hsplit :=
        FlexVBT.FromAxis (
          HVSplit.Cons (
            Axis.T.Hor, minus, VBar (shadow),
            NEW (ShadowedVBT.T).init (v.typein, shadow, Shadow.Style.Raised),
            VBar (shadow), plus),
          Axis.T.Hor, FlexVBT.RigidRange (25.0));
      EVAL Filter.T.init (v, hsplit);
    END;
    RETURN v;
  END Init;

PROCEDURE Callback (<* UNUSED *> v: T; <* UNUSED *> event: AnyEvent.T) =
  BEGIN
  END Callback;

PROCEDURE VBar (shadow: Shadow.T): VBT.T =
  BEGIN
    IF shadow.size # 0.0 THEN
      RETURN NIL
    ELSE
      RETURN FlexVBT.FromAxis(TextureVBT.New(shadow.bgFg),
                                Axis.T.Hor, FlexVBT.RigidRange(1.0))
    END
  END VBar;

PROCEDURE ReturnAction (typein: Typein; READONLY cd: VBT.KeyRec) =
  VAR v := typein.v;
  BEGIN
    PutCl (v, ReadState (v));
    v.callback (AnyEvent.FromKey (cd))
  END ReturnAction;

PROCEDURE Reshape (typein: Typein; READONLY cd: VBT.ReshapeRec) =
  TYPE Pixels = CARDINAL;

  BEGIN
    TypeinVBT.T.reshape (typein, cd);
    IF cd.new = Rect.Empty THEN RETURN END;
    LOCK typein.mu DO
      VAR
        width: Pixels  := Rect.HorSize (VBT.Domain (typein));
        vtext: VText.T := typein.vtext;
        marginSlack: Pixels := vtext.leftMargin + vtext.rightMargin
                                 + 2 * vtext.turnMargin;
      BEGIN
        IF typein.charWidth > 0 AND width > marginSlack THEN
          typein.v.digits := (width - marginSlack) DIV typein.charWidth
        ELSE
          typein.v.digits := 0
        END
      END
    END;
    PutCl (typein.v, ReadState (typein.v))
  END Reshape;

PROCEDURE CheckAndFixValue (v: T) =
  VAR s := ReadState (v);
  BEGIN
    IF s.empty THEN
      IF v.allowEmpty THEN
        v.val := FIRST (INTEGER);
        v.empty := TRUE
      ELSE
        PutCl (v, s)
      END
    ELSIF s.num < v.min OR s.num > v.max THEN
      PutCl (v, s)
    ELSE
      v.val := s.num;
      v.empty := FALSE
    END
  END CheckAndFixValue;

PROCEDURE ReadState (v: T): State =
  VAR contents := TextPort.GetText (v.typein);
  BEGIN
    IF Text.Empty (contents) THEN
      IF v.allowEmpty THEN
        RETURN State {FIRST (INTEGER), TRUE}
      ELSE
        RETURN State {0, FALSE}
      END
    ELSE
      TRY
        (* RETURN State {Scan.Int (StripLeadingBlanks (contents)), FALSE} *)
        RETURN State {Lex.Int (TextRd.New (contents)), FALSE}
      EXCEPT
      | Lex.Error, FloatMode.Trap, Rd.Failure, Thread.Alerted =>
          (* We may have all kinds of illegal characters -- through the
             primary/secondary replacement mechanism, for example.  So we must
             be careful. *)
          RETURN State {v.val, FALSE}
      END
    END
  END ReadState;

ELSIF i = 0 THEN
        RETURN t
      ELSE
        RETURN Text.Sub (t, i, LAST (CARDINAL))
      END
    END;
    RETURN ""
  END StripLeadingBlanks;
*************)

TYPE
  PlusMinusVBT = TrillSwitchVBT.T BRANDED OBJECT
                   v    : T;
                   delta: INTEGER;
                 OVERRIDES
                   callback := PlusMinus
                 END;

PROCEDURE NewPlusMinusVBT (v       : T;
                           delta   : INTEGER;
                           shadow  : Shadow.T;
                           contents: Pixmap.T  ): PlusMinusVBT =
  VAR
    p := NEW (PixmapVBT.T).init (contents, op:=shadow.bgFg, bg:=shadow.bg);
    f := NEW (ShadowedFeedbackVBT.T).init (p, shadow);
    pm: PlusMinusVBT := NEW (PlusMinusVBT).init (f);
  BEGIN
    pm.v := v;
    pm.delta := delta;
    RETURN pm;
  END NewPlusMinusVBT;

PROCEDURE PlusMinus (pm: PlusMinusVBT; READONLY cd: VBT.MouseRec) =
  VAR v := pm.v;
  BEGIN
    CheckAndFixValue (v);
    IF v.empty THEN RETURN END;
    PutCl (v, State {v.val + pm.delta, FALSE});
    v.callback (AnyEvent.FromMouse (cd))
  END PlusMinus;

PROCEDURE Put (v: T; n: INTEGER) =
  BEGIN
    PutCl (v, State {n, FALSE});
  END Put;

PROCEDURE PutBounds (v: T; min, max: INTEGER) =
  BEGIN
    v.min := min;
    v.max := max;
    PutCl (v, State {v.val, FALSE});
  END PutBounds;

PROCEDURE SetEmpty (v: T) =
  BEGIN
    IF v.allowEmpty THEN PutCl (v, State {0, TRUE}) END;
  END SetEmpty;

PROCEDURE PutCl (v: T; READONLY s: State) =
  BEGIN
    IF s.empty AND v.allowEmpty THEN
      v.empty := TRUE;
      v.val := FIRST (INTEGER);
      TextPort.SetText (v.typein, "")
    ELSE
      v.empty := FALSE;
      v.val := MIN (v.max, MAX (v.min, s.num));
      TextPort.SetText (v.typein, Fmt.Pad (Fmt.Int (v.val), v.digits))
    END
  END PutCl;

PROCEDURE Get (v: T): INTEGER =
  BEGIN
    CheckAndFixValue(v);
    RETURN v.val;
  END Get;

PROCEDURE GetMin (v: T): INTEGER =
  BEGIN
    CheckAndFixValue(v);
    RETURN v.min;
  END GetMin;

PROCEDURE GetMax (v: T): INTEGER =
  BEGIN
    CheckAndFixValue(v);
    RETURN v.max;
  END GetMax;

PROCEDURE IsEmpty (v: T): BOOLEAN =
  BEGIN
    CheckAndFixValue(v);
    RETURN v.empty;
  END IsEmpty;

PROCEDURE TakeFocus (v: T; time: VBT.TimeStamp; alsoSelect: BOOLEAN := TRUE):
  BOOLEAN =
  BEGIN
    IF NOT TextPort.TryFocus (v.typein, time) THEN RETURN FALSE END;
    IF alsoSelect THEN
      TextPort.Select (
        v.typein, time, 0, LAST (CARDINAL), replaceMode := TRUE);
    END;
    RETURN TRUE
  END TakeFocus;

VAR
  rsrcMu := NEW (MUTEX);
  <* LL = rsrcMu *>
  rsrcInit                    := FALSE;

VAR minusOff, plusOff: Pixmap.T;

PROCEDURE GetResources () =
  BEGIN
    LOCK rsrcMu DO
      IF rsrcInit THEN RETURN END;
      minusOff := VBTKitResources.GetPixmap ("minusOff");
      plusOff := VBTKitResources.GetPixmap ("plusOff");
      rsrcInit := TRUE;
    END
  END GetResources;

BEGIN
END NumericVBT.