(* Copyright (C) 1991, Digital Equipment Corporation *)
(* All rights reserved. *)
(* See the file COPYRIGHT for a full description. *)

(* Last modified on Fri Apr 17 22:06:38 1992 by msm *)
(*      modified on Sat Feb 22 00:20:14 1992 by goldberg@parc.xerox.com *)
(*      modified on Fri Sep 20 01:59:12 1991 by kalsow *)


MODULE Solitaire EXPORTS Main;

IMPORT AnchorBtnVBT, Axis, BorderedVBT, ButtonVBT, Card, Char, FieldList, 
  Filter, Fmt, Font, HVSplit, Latin1Key, MenuBtnVBT, MouseSplit, PackSplit, 
  PaintOp, ParseParams, Point, Rd, RigidVBT, Scan, Solve, Split, Stdio, 
  TSplit, Text, TextVBT, TextureVBT, Thread, Trestle, TrestleComm, VBT, Wr, 
  ZSplit, KeyboardKey;

FROM Card IMPORT Width, Height, Overlap, Value, Suit, Real, Family;

CONST
  Gutter = 16;
  Gap    = 8;

TYPE
  State = REF RECORD
                deck  : Card.StandardDeck;
                pile  : ARRAY [Family.Spades .. Family.Clubs] OF Card.T;
                talon : ARRAY [0 .. 3] OF Card.T;
                layout: ARRAY [0 .. 9] OF Card.T;
                consec, wins, losses, consecWins, consecLosses: INTEGER;
                neverWon                                      : BOOLEAN;
              END;

VAR
  helpDialog, scoreDialog: VBT.T;
  state                  : State;
  buttonFont := Font.FromName(
                  ARRAY OF
                    TEXT{
                    "-*-menu-medium-r-*-*-*-120-*-*-*-*-iso8859-1",
                    "-*-helvetica-bold-r-*-*-*-120-*-*-*-*-iso8859-1",
                    "-*-itc souvenir-demi-r-*-*-*-120-*-*-*-*-iso8859-1",
                    "-*-times-bold-r-*-*-*-120-*-*-*-*-iso8859-1"});
  textFont := Font.FromName(
                ARRAY OF
                  TEXT{
                  "-*-new century schoolbook-medium-r-"
                    & "*-*-*-120-*-*-*-*-iso8859-1",
                  "-*-itc souvenir-demi-r-*-*-*-120-*-*-*-*-iso8859-1",
                  "-*-times-medium-r-*-*-*-120-*-*-*-*-iso8859-1",
                  "-*-helvetica-medium-r-*-*-*-120-*-*-*-*-iso8859-1"});
  msgFont := Font.FromName(
               ARRAY OF
                 TEXT{"-*-helvetica-medium-o-*-*-*-140-*-*-*-*-iso8859-1",
                      "-*-times-medium-o-*-*-*-120-*-*-*-*-iso8859-1"});

PROCEDURE Play (VAR (* out*) a, b: Card.T): BOOLEAN =

  PROCEDURE Playable (c: Card.T): BOOLEAN =
    VAR v: Value;
    BEGIN
      c := c.below;
      IF NOT Real(c) THEN RETURN FALSE END;
      v := c.value;
      DEC(v);
      IF state.pile[c.family].below.value = v THEN
        a := c;
        b := state.pile[c.family].below;
        RETURN TRUE
      ELSE
        RETURN FALSE
      END;
    END Playable;

  VAR won: BOOLEAN;
  BEGIN
    FOR i := 0 TO LAST(state.layout) DO
      IF Playable(state.layout[i]) THEN RETURN TRUE END
    END;
    FOR i := 0 TO LAST(state.talon) DO
      IF Playable(state.talon[i]) THEN RETURN TRUE END
    END;
    won := TRUE;
    FOR s := Family.Spades TO Family.Clubs DO
      IF state.pile[s].below.value # Value.King THEN won := FALSE END
    END;
    IF won AND state.neverWon THEN
      INC(state.wins);
      state.consec := MAX(state.consec, 0) + 1;
      state.consecWins := MAX(state.consecWins, state.consec);
      state.neverWon := FALSE
    END;
    RETURN FALSE
  END Play;

PROCEDURE Obvious (a: Card.T): Card.T =
  VAR
    v: Value;
    s: Suit;
  BEGIN
    IF a.family # Family.Any THEN
      IF (a.value = Value.King) AND (a.below.value # Value.Max) THEN
        FOR i := 0 TO LAST(state.layout) DO
          IF NOT Real(state.layout[i].below) THEN
            RETURN state.layout[i]
          END
        END
      ELSE
        v := a.value;
        s := a.family;
        INC(v);
        FOR i := 0 TO LAST(state.deck) DO
          IF (state.deck[i].family = s) AND (state.deck[i].value = v) THEN
            RETURN state.deck[i]
          END
        END;
      END
    END;
    RETURN NIL
  END Obvious;

PROCEDURE Stupid (a: Card.T): Card.T =
  VAR
    v: Value;
    s: Suit;
  BEGIN
    IF Real(a) THEN
      v := a.value;
      s := a.family;
      DEC(v);
      FOR i := 0 TO LAST(state.deck) DO
        IF (state.deck[i].family = s) AND (state.deck[i].value = v) THEN
          RETURN state.deck[i]
        END
      END
    END;
    RETURN NIL
  END Stupid;

PROCEDURE Trivial (a: Card.T): Card.T =
  BEGIN
    IF Real(a) AND (a.above.value # Value.Talon) THEN
      FOR i := 0 TO LAST(state.talon) DO
        IF NOT Real(state.talon[i].below) THEN RETURN state.talon[i] END
      END
    END;
    RETURN NIL
  END Trivial;

PROCEDURE Attachable (a, b: Card.T): BOOLEAN =
  VAR
    v : Value;
    ap: Card.T;
    tc: INTEGER;
  BEGIN
    IF NOT Real(a) THEN RETURN FALSE END;
    ap := a.above;
    v := a.value;
    tc := 0;
    FOR i := 0 TO LAST(state.talon) DO
      IF state.talon[i].above = state.talon[i] THEN INC(tc) END
    END;
    WHILE Real(ap) AND (ap # a) DO
      IF ap.family # a.family THEN RETURN FALSE END;
      DEC(v);
      IF v # ap.value THEN RETURN FALSE END;
      DEC(tc);
      ap := ap.above
    END;
    IF ap.value = Value.Min THEN RETURN FALSE END;
    IF tc < 0 THEN RETURN FALSE END;
    IF Real(b.above) THEN RETURN FALSE END;
    IF (b.above.value = Value.Talon) AND (b # b.above) THEN
      RETURN FALSE
    END;
    IF (b.family # a.family) AND (b.family # Family.Any) THEN
      RETURN FALSE
    END;
    IF b.value = Value.Talon THEN RETURN NOT Real(a.above) END;
    v := a.value;
    IF b.above.value = Value.Min THEN DEC(v) ELSE INC(v) END;
    RETURN v = b.value
  END Attachable;

PROCEDURE NewDeck (parent: ZSplit.T; state: State) =
  VAR p: Point.T;
  BEGIN
    Card.attachable := Attachable;
    Card.play := Play;
    Card.obvious := Obvious;
    Card.trivial := Trivial;
    Card.stupid := Stupid;
    Card.InitializeStandardDeck(state.deck, parent);
    p.h := Gutter;
    p.v := Gutter;
    FOR st := Family.Spades TO Family.Clubs DO
      state.pile[st] := Card.New(Value.Min, st, p, parent);
      IF st = Family.Hearts THEN
        INC(p.h, 7 * (Width + Gap))
      ELSE
        INC(p.h, Width + Gap)
      END
    END;
    p.h := Gutter + 3 * (Width + Gap);
    p.v := Gutter;
    FOR i := 0 TO LAST(state.talon) DO
      state.talon[i] := Card.New(Value.Talon, Family.Any, p, parent);
      INC(p.h, Width + Gap)
    END;
    p.h := Gutter;
    INC(p.v, Height + Gap);
    FOR i := 0 TO LAST(state.layout) DO
      state.layout[i] := Card.New(Value.Max, Family.Any, p, parent);
      INC(p.h, Width + Gap)
    END
  END NewDeck;

TYPE MyBg = TextureVBT.T OBJECT OVERRIDES shape := Shape END;

PROCEDURE Shape ( <*UNUSED*>ch: MyBg; ax: Axis.T;  <*UNUSED*>n: CARDINAL):
  VBT.SizeRange =
  CONST
    Wid = 2 * Gutter + 9 * Gap + 10 * Width;
    Hei = 2 * Gutter + Gap + 2 * Height + 15 * Overlap;
  BEGIN
    IF ax = Axis.T.Hor THEN
      RETURN
        VBT.SizeRange{lo := Wid, pref := Wid, hi := VBT.DefaultShape.hi}
    ELSE
      RETURN VBT.SizeRange{lo := 0, pref := Hei, hi := VBT.DefaultShape.hi}
    END
  END Shape;

PROCEDURE NewGame (VAR (* out*) state: State; fromStdin: BOOLEAN): VBT.T =
  VAR
    txt           := NEW(MyBg);
    res: ZSplit.T;
  BEGIN
    LOCK VBT.mu DO
      EVAL TextureVBT.T.init(txt, Card.felt.op, Card.felt.txt);
      res := ZSplit.New(txt);
      state := NEW(State);
      state.consec := 0;
      state.wins := 0;
      state.losses := 0;
      state.consecWins := 0;
      state.consecLosses := 0;
      NewDeck(res, state);
      IF fromStdin THEN
        StdinLayout(res, state)
      ELSE
        NewLayout(res, state)
      END;
    END;
    RETURN res;
  END NewGame;

PROCEDURE NewLayout ( <*UNUSED*>v: VBT.T; state: State) =
  <*FATAL Card.BadDeal*>
  VAR
    j   : INTEGER;
    a, b: Card.T;
  BEGIN
    Card.Shuffle(state.deck);
    FOR i := 0 TO LAST(state.deck) DO Card.Detach(state.deck[i]) END;
    Card.Attach(state.deck[0], state.talon[1]);
    Card.Attach(state.deck[1], state.talon[2]);
    j := 0;
    FOR i := 2 TO LAST(state.deck) DO
      Card.Attach(state.deck[i], state.layout[j].below);
      IF j < LAST(state.layout) THEN INC(j) ELSE j := 0 END
    END;
    WHILE Play(a, b) DO Card.Attach(a, b) END;
    state.neverWon := TRUE;
    Card.StartUndoLog()
  END NewLayout;

VAR
  game, board, menu, txtMsg: VBT.T;
  abortButton              : TSplit.T;
  solver                   : Thread.T := NIL;
  solveMutex                          := NEW(MUTEX);
  verbose, solving         : BOOLEAN;

PROCEDURE TrackingOn ( <*UNUSED*>         button: ButtonVBT.T;  <*UNUSED*>
                                 READONLY cd    : VBT.MouseRec            ) =
  BEGIN
    Card.EnableTracking(TRUE);
  END TrackingOn;

PROCEDURE TrackingOff ( <*UNUSED*>         button: ButtonVBT.T;  <*UNUSED*>
                                  READONLY cd    : VBT.MouseRec            ) =
  BEGIN
    Card.EnableTracking(FALSE);
  END TrackingOff;

PROCEDURE DoNewLayout ( <*UNUSED*>         button: ButtonVBT.T;  <*UNUSED*>
                                  READONLY cd    : VBT.MouseRec            ) =
  BEGIN
    RemoveHelp();
    IF state.neverWon THEN
      INC(state.losses);
      state.consec := MIN(state.consec, 0) - 1;
      state.consecLosses := MAX(state.consecLosses, -state.consec)
    END;
    NewLayout(board, state)
  END DoNewLayout;

PROCEDURE DoUndo ( <*UNUSED*>         button: ButtonVBT.T;  <*UNUSED*>
                             READONLY cd    : VBT.MouseRec            ) =
  BEGIN
    RemoveHelp();
    EVAL Card.Undo()
  END DoUndo;

PROCEDURE DoHint ( <*UNUSED*>button: ButtonVBT.T; READONLY cd: VBT.MouseRec) =
  <*FATAL Split.NotAChild*>
  VAR
    howHard: [0 .. 2];
    msg    : TEXT;
  BEGIN
    CASE cd.whatChanged OF
    | VBT.Modifier.MouseL =>
        howHard := 0;
        msg :=
          "checking to see if game is winnable... press Abort to abort";
    | VBT.Modifier.MouseR =>
        howHard := 2;
        msg :=
          "checking to see if game is winnable... press Abort to abort";
    | VBT.Modifier.MouseM =>
        howHard := 1;
        msg := "checking very hard to see if game is winnable... "
                 & "press Abort to abort";
    ELSE
      RETURN
    END;
    (* don't solve again, if already solving *)
    IF solving THEN RETURN; END;
    TSplit.SetCurrent(abortButton, Split.Succ(abortButton, NIL));
    RemoveHelp();
    TextVBT.Put(txtMsg, msg);   (* XXX: when remove this msg? *)
    solver := Thread.Fork(NEW(SolveClosure, stackSize := 100000,
                              howHard := howHard, apply := SolveIt));
  END DoHint;

TYPE SolveClosure = Thread.SizedClosure OBJECT howHard: [0 .. 2];  END;

PROCEDURE DoAbort ( <*UNUSED*>         button: ButtonVBT.T;  <*UNUSED*>
                             READONLY cd    : VBT.MouseRec            ) =
  BEGIN
    RemoveHelp();
    IF solver # NIL THEN
    Thread.Alert(solver) END;
  END DoAbort;

PROCEDURE SolveIt (self: SolveClosure): REFANY =
  <*FATAL Split.NotAChild*>
  PROCEDURE ConvertCard (card: Card.T): Solve.CardType =
    VAR res: Solve.CardType;
    BEGIN
      IF NOT Card.Real(card) THEN
        RETURN (Solve.noCard)
      ELSE
        res.suit := VAL(ORD(card.family) - 1, Solve.Suit);
        res.val := ORD(card.value);
        RETURN (res);
      END;
    END ConvertCard;

  VAR
    txt      : TEXT;
    j                         := Family.Any;
    layout   : Solve.Layout;
    why      : Solve.WhyStop;
    stateCard: Card.T;
    card     : Solve.CardType;
    lst, nxt : Solve.CardList;
  BEGIN
    Thread.Acquire(solveMutex);
    TRY
      solving := TRUE;
      FOR i := 1 TO 4 DO
        INC(j);
        card := ConvertCard(state.pile[j].below);
        IF card # Solve.noCard THEN layout.fnd[i] := card; END;
      END;
      FOR i := 1 TO 4 DO
        layout.tal[i] := ConvertCard(state.talon[i - 1].below);
      END;
      FOR i := 1 TO 10 DO
        stateCard := state.layout[i - 1].below;
        WHILE Card.Real(stateCard) DO stateCard := stateCard.below; END;
        stateCard := stateCard.above;
        card := ConvertCard(stateCard);
        nxt := NIL;
        lst := NIL;
        WHILE Card.Real(stateCard) DO
          lst := NEW(Solve.CardList);
          lst.card := card;
          lst.nxt := nxt;
          nxt := lst;
          stateCard := stateCard.above;
          card := ConvertCard(stateCard);
        END;
        layout.tab[i] := lst;
      END;
      CASE self.howHard OF
      | 0, 2 =>
          (* solves about 87% of games, average time of 25 secs/game *)
          txt := Solve.NextMove(layout, why, depth := 2000, breadth := 500,
                                total := 100000, verbose := verbose,
                                callback := PrintCount);

      | 1 =>
          (* for unsolved in previous, solves about 46%, 73 secs/game *)
          txt :=
            Solve.NextMove(
              layout, why, depth := 80000, breadth := 2000,
              total := 100000, verbose := verbose, callback := PrintCount);
      END;
      IF self.howHard = 2 AND why = Solve.WhyStop.Solution THEN
        txt := "Game is winnable"
      END;                      (* if *)
      TextVBT.Put(txtMsg, txt); (* XXX: when remove this msg? *)
      RETURN NIL;
    FINALLY
      solving := FALSE;
      Thread.Release(solveMutex);
      LOCK VBT.mu DO TSplit.SetCurrent(abortButton, NIL); solver := NIL END
    END;
  END SolveIt;

PROCEDURE PrintCount (cnt: CARDINAL) =
  VAR
    txt: TEXT;
    n  : INTEGER;
  BEGIN
    txt := TextVBT.Get(txtMsg);
    IF txt = NIL OR Text.Length(txt) = 0 THEN
      TextVBT.Put(txtMsg, Fmt.F("(%s moves examined)", Fmt.Int(cnt)))
    ELSIF Text.GetChar(txt, Text.Length(txt) - 1) = ')' THEN
      n := Text.FindCharR(txt, '(');
      TextVBT.Put(txtMsg, Fmt.F("%s(%s moves examined)",
                                Text.Sub(txt, 0, n), Fmt.Int(cnt)));
    ELSE
      TextVBT.Put(
        txtMsg, Fmt.F("%s (%s moves examined)", txt, Fmt.Int(cnt)));
    END;
  END PrintCount;

PROCEDURE DoRedo ( <*UNUSED*>         button: ButtonVBT.T;  <*UNUSED*>
                             READONLY cd    : VBT.MouseRec            ) =
  BEGIN
    RemoveHelp();
    EVAL Card.Redo(TRUE)
  END DoRedo;

PROCEDURE DoReset ( <*UNUSED*>         button: ButtonVBT.T;  <*UNUSED*>
                              READONLY cd    : VBT.MouseRec            ) =
  BEGIN
    RemoveHelp();
    WHILE Card.Undo() DO END
  END DoReset;

PROCEDURE DoExit ( <*UNUSED*>         button: ButtonVBT.T;  <*UNUSED*>
                             READONLY cd    : VBT.MouseRec            ) =
  BEGIN
    Trestle.Delete(game)
  END DoExit;

PROCEDURE RemoveHelp () =
  <*FATAL Split.NotAChild*>
  BEGIN
    TextVBT.Put(txtMsg, "");
    TSplit.SetCurrent(board, Split.Succ(board, NIL));
  END RemoveHelp;

PROCEDURE AddText (v: VBT.T; t: TEXT) =
  <*FATAL Split.NotAChild*>
  VAR
    index0, index1, index2: INTEGER;
    word                  : TEXT;
  BEGIN
    index0 := 0;
    REPEAT
      index1 := Text.FindChar(t, ' ', index0);
      IF index1 = -1 THEN
        index2 := Text.Length(t)
      ELSE
        index2 := index1;
      END;
      word := Text.Sub(t, index0, index2 - index0);
      index0 := index1 + 1;
      Split.Insert(v, Split.Pred(v, NIL),
                   TextVBT.New(word, 0.5, 0.0, 0.0, 0.0, fnt := textFont))
    UNTIL index1 = -1
  END AddText;

TYPE Para = PackSplit.T OBJECT OVERRIDES shape := ParaShape END;

PROCEDURE ParaShape (v: Para; ax: Axis.T; n: CARDINAL): VBT.SizeRange
  RAISES {} =
  VAR sh := PackSplit.T.shape(v, ax, n);
  BEGIN
    IF ax # PackSplit.AxisOf(v) THEN
      sh.hi := sh.lo + 1;
      sh.pref := sh.lo
    END;
    RETURN sh
  END ParaShape;

PROCEDURE Paragraph (READONLY t: ARRAY OF TEXT): PackSplit.T =
  VAR res := NEW(Para);
  BEGIN
    EVAL PackSplit.T.init(res, hgap := 1.2, vgap := 0.5);
    FOR i := FIRST(t) TO LAST(t) DO
      IF t[i] # NIL THEN AddText(res, t[i]) END
    END;
    RETURN res
  END Paragraph;

TYPE AT = ARRAY OF TEXT;

PROCEDURE CreateHelp ( <*UNUSED*>z: ZSplit.T) =
  CONST
    Para1  = AT{Text1};
    Text1  = "  This solitaire is better known as Sea Haven Towers.";
    Para3  = AT{Text2, Text3, Text4, Text5, Text6, Text7};
    Text2  = "  The top row contains the four foundations,";
    Text3  = "which are built up in suit from Ace to King.";
    Text4  = "It also contains the four talons, where any single card";
    Text5  = "may be placed. The lower part of the board contains";
    Text6  = "the rest of the deck. Cards there are played";
    Text7  = "descending in suit on the topmost card in a stack.";
    Para5  = AT{Text8, Text9, Text10, Text11};
    Text8  = "  You can only move one card at a time.";
    Text9  = "As a convenience, if there is space, cards will be moved";
    Text10 = "to the talon and back, allowing you to move several cards";
    Text11 = "at a time.";
    Para7  = AT{Text12, Text13, Text14, Text15, Text16, Text16a, Text17};
    Text12 = "  You move a card by pointing to it with the";
    Text13 = "mouse, pressing any button, and dragging the card to";
    Text14 = "its destination. As a shortcut, you can move it to";
    Text15 = "the next higher card in suit by left-clicking.";
    Text16 = "You can move it to the talon by middle-clicking.";
    Text16a = "The right button shows you which card to move onto this one.";
    Text17 = "Cards move to the foundations automatically.";
    Para9 = AT{Text18, Text19, Text20, Text21, Text22, Text23};
    Text18 = "  You can ask for assistance by pressing the 'hint' button.";
    Text19 = "If you press using the left mouse-button, solitaire will";
    Text20 = "try to supply a hint.  If you use the middle button,";
    Text21 = "solitaire will try really hard to supply a hint. The right";
    Text22 = "button causes solitaire to determine only if the current";
    Text23 = "position is solvable or not.";
    Para11 = AT{Text24, Text25};
    Text24 = "  You can invoke any command except 'hint' by typing the";
    Text25 = "capitalized letter in its name.";
    Para13  = AT{Text26};
    Text26 = "  Click on this text to resume play.";
  VAR p1, p3, p5, p7, p9, p11, p13: VBT.T;
  BEGIN
    p1 := Paragraph(Para1);
    p3 := Paragraph(Para3);
    p5 := Paragraph(Para5);
    p7 := Paragraph(Para7);
    p9 := Paragraph(Para9);
    p11 := Paragraph(Para11);
    p13 := Paragraph(Para13);
    helpDialog := HelpSplitCons(ARRAY OF VBT.T{p1, p3, p5, p7, p9, p11, p13});
    Split.AddChild(board, helpDialog)
  END CreateHelp;

PROCEDURE Spacer (): VBT.T =
  CONST
    shape = RigidVBT.Shape{
              RigidVBT.SizeRange{lo := 0.0, pref := 0.0, hi := 1000.0},
              RigidVBT.SizeRange{2.0, 2.0, 2.0}};
  BEGIN
    RETURN RigidVBT.New(TextureVBT.New(op := PaintOp.Bg), shape)
  END Spacer;

PROCEDURE HelpSplitCons (READONLY a: ARRAY OF VBT.T): HelpVBT =
  VAR
    hv, hv2 := HVSplit.New(Axis.T.Ver, adjustable := FALSE);
    res     := NEW(HelpVBT);
  BEGIN
    IF 0 < LAST(a) THEN Split.AddChild(hv, a[0]) END;
    FOR i := 1 TO LAST(a) DO Split.AddChild(hv, Spacer(), a[i]) END;
    Split.AddChild(
      hv2, TextureVBT.New(op := PaintOp.Bg),
      BorderedVBT.New(BorderedVBT.New(hv, 6.0, op := PaintOp.Bg)),
      TextureVBT.New(op := PaintOp.Bg));
    EVAL BorderedVBT.T.init(res, hv2, 35.0, op := PaintOp.Bg);
    RETURN res
  END HelpSplitCons;

TYPE HelpVBT = BorderedVBT.T OBJECT OVERRIDES mouse := HelpMouse END;

PROCEDURE HelpMouse ( <*UNUSED*>         v : HelpVBT;     <*UNUSED*>
                                READONLY cd: VBT.MouseRec           ) =
  BEGIN
    RemoveHelp()
  END HelpMouse;

PROCEDURE DoHelp (v: ButtonVBT.T;  <*UNUSED*>READONLY cd: VBT.MouseRec) =
  <*FATAL Split.NotAChild*>
  BEGIN
    RemoveHelp();
    IF helpDialog = NIL THEN
      CreateHelp(VBT.GetProp(v, TYPECODE(ZSplit.T)))
    END;
    TSplit.SetCurrent(board, helpDialog)
  END DoHelp;

PROCEDURE CreateScore ( <*UNUSED*>z: ZSplit.T) =
  CONST
    Text1 = "  Scoring summary:";
    Text2 = "Wins:";
    Text3 = "Losses:";
    Text4 = "Winning streak:";
    Text5 = "Losing streak:";
    Text6 = "Longest winning streak:";
    Text7 = "Longest losing streak:";
    Text8 = "The current game has been won. ";
    Text9 = "Click on this text to resume play.";
  VAR p1, p2, p3, p4, p5, p6, p7: VBT.T;
  BEGIN
    p1 := Paragraph(AT{Text1});
    p2 := Paragraph(AT{Text2, Fmt.Int(state.wins)});
    p3 := Paragraph(AT{Text3, Fmt.Int(state.losses)});
    IF state.consec >= 0 THEN
      p4 := Paragraph(AT{Text4, Fmt.Int(state.consec)})
    ELSE
      p4 := Paragraph(AT{Text5, Fmt.Int(-state.consec)})
    END;
    p5 := Paragraph(AT{Text6, Fmt.Int(state.consecWins)});
    p6 := Paragraph(AT{Text7, Fmt.Int(state.consecLosses)});
    IF state.neverWon THEN
      p7 := Paragraph(AT{"  ", Text9})
    ELSE
      p7 := Paragraph(AT{Text8, Text9})
    END;
    scoreDialog :=
      HelpSplitCons(ARRAY OF VBT.T{p1, p2, p3, p4, p5, p6, p7});
    Split.AddChild(board, scoreDialog)
  END CreateScore;

PROCEDURE DoScore (v: ButtonVBT.T;  <*UNUSED*>READONLY cd: VBT.MouseRec) =
  <*FATAL Split.NotAChild *>
  BEGIN
    RemoveHelp();
    IF scoreDialog # NIL THEN
      Split.Delete(VBT.Parent(scoreDialog), scoreDialog);
      VBT.Discard(scoreDialog);
      scoreDialog := NIL
    END;
    CreateScore(VBT.GetProp(v, TYPECODE(ZSplit.T)));
    TSplit.SetCurrent(board, scoreDialog)
  END DoScore;

PROCEDURE TBorder (v: VBT.T; op := PaintOp.Fg): VBT.T =
  BEGIN
    RETURN BorderedVBT.New(v, 0.3, op := op)
  END TBorder;

PROCEDURE TButton (name: Text.T; proc: ButtonVBT.Proc): ButtonVBT.T =
  BEGIN
    RETURN
      ButtonVBT.New(TBorder(TextVBT.New(name, fnt := buttonFont)), proc)
  END TButton;

PROCEDURE MButton (name: TEXT; action: ButtonVBT.Proc; ref: REFANY := NIL):
  MenuBtnVBT.T =
  VAR ti := TextVBT.New(name, 0.0, 0.5, 3.0, 0.5, fnt := buttonFont);
  BEGIN
    RETURN MenuBtnVBT.New(ti, action, ref)
  END MButton;

TYPE
  KeyGrab = Filter.T OBJECT
              hasFocus := FALSE;
              mbutton: ButtonVBT.T
            OVERRIDES
              misc  := KeyMisc;
              mouse := KeyMouse;
              key   := KeyKey
            END;

PROCEDURE KeyKey (v: KeyGrab; READONLY cd: VBT.KeyRec) =
  VAR
    cdM: VBT.MouseRec;
    b                 := v.mbutton;
    what := cd.whatChanged;
  BEGIN
    IF cd.wentDown THEN
      cdM.time := cd.time;
      cdM.modifiers := cd.modifiers;
      cdM.whatChanged := VBT.Modifier.Mouse4;
      IF what >= Latin1Key.a AND what <= Latin1Key.z THEN
        what := what + (Latin1Key.A - Latin1Key.a)
      END;
      IF what = Latin1Key.U THEN
        DoUndo(b, cdM)
      ELSIF what = Latin1Key.R THEN
        DoRedo(b, cdM)
      ELSIF what = Latin1Key.N THEN
        DoNewLayout(b, cdM)
      ELSIF what = Latin1Key.Q THEN
        DoExit(b, cdM)
      ELSIF what = Latin1Key.H THEN
        DoHelp(b, cdM)
      ELSIF what = Latin1Key.S THEN
        DoScore(b, cdM)
      ELSIF what = Latin1Key.E THEN
        DoReset(b, cdM)
      ELSIF what = Latin1Key.O THEN
        TrackingOn(b, cdM)
      ELSIF what = Latin1Key.F THEN
        TrackingOff(b, cdM)
      ELSIF what = Latin1Key.A THEN
        DoAbort(b, cdM)
      ELSIF what >= Latin1Key.space AND what <= Latin1Key.ydiaeresis OR
        what = KeyboardKey.Return OR what = KeyboardKey.BackSpace OR
        what = KeyboardKey.Tab OR what = KeyboardKey.Linefeed OR
	what = KeyboardKey.Escape OR what = KeyboardKey.Delete THEN
	RemoveHelp()
      END
    END
  END KeyKey;

PROCEDURE KeyMisc (v: KeyGrab; READONLY cd: VBT.MiscRec) =
  BEGIN
    IF cd.selection = VBT.KBFocus THEN
      IF cd.type = VBT.Lost THEN
        v.hasFocus := FALSE
      ELSIF cd.type = VBT.TakeSelection AND NOT v.hasFocus THEN
        TakeFocus(v, cd.time)
      END
    END;
    Filter.T.misc(v, cd)
  END KeyMisc;

PROCEDURE KeyMouse (v: KeyGrab; READONLY cd: VBT.MouseRec) =
  BEGIN
    IF NOT v.hasFocus AND cd.clickType = VBT.ClickType.FirstDown THEN
      TakeFocus(v, cd.time)
    END;
    MouseSplit.Mouse(v, cd)
  END KeyMouse;

PROCEDURE KeyGrabNew (v: VBT.T; b: ButtonVBT.T := NIL): KeyGrab =
  VAR res := NEW(KeyGrab);
  BEGIN
    EVAL Filter.T.init(res, v);
    res.mbutton := b;
    RETURN res
  END KeyGrabNew;

PROCEDURE TakeFocus (v: KeyGrab; time: VBT.TimeStamp) =
  BEGIN
    TRY
      VBT.Acquire(v, VBT.KBFocus, time);
      v.hasFocus := TRUE
    EXCEPT
      VBT.Error =>
    END
  END TakeFocus;

PROCEDURE StdinLayout ( <*UNUSED*>v: VBT.T; state: State) =

  PROCEDURE ScanCard (txt: TEXT): [0 .. 51] =
    VAR
      val: CARDINAL;
      ch : CHAR;
    BEGIN
      ch := Text.GetChar(txt, 0);
      val := ORD(ch) - ORD('0');
      ch := Text.GetChar(txt, 1);
      IF ch IN Char.Digits THEN
        val := 10 * val + ORD(ch) - ORD('0');
        ch := Text.GetChar(txt, 2);
      END;
      CASE ch OF                <* NOWARN *>
      | 'S' => RETURN ((val - 1) * 4 + 0);
      | 'H' => RETURN ((val - 1) * 4 + 1);
      | 'D' => RETURN ((val - 1) * 4 + 2);
      | 'C' => RETURN ((val - 1) * 4 + 3);
      END;
    END ScanCard;

  <*FATAL Card.BadDeal, Rd.Failure *>
  VAR
    j   : INTEGER;
    a, b: Card.T;
    fl  : FieldList.T               := NIL;
    tmp : ARRAY [0 .. 51] OF Card.T;
  BEGIN
    TRY
      fl := NEW(FieldList.T).init();
      fl.getText(Rd.GetText(Stdio.stdin, LAST(INTEGER)));
      FOR i := 0 TO 51 DO
        j := ScanCard(fl.text(i));
        tmp[i] := state.deck[j];
      END;
    FINALLY
      IF fl.number() # 52 THEN
        Wr.PutText(
          Stdio.stderr,
          "Need to provide 52 cards on stdin.\n"
            & "Each card is of the form n[D,S,D,H], 1 <= n <= 13\n");
        Trestle.Delete(game);
      END;
    END;

    FOR i := 0 TO 51 DO state.deck[i] := tmp[i]; END;

    FOR i := 0 TO LAST(state.deck) DO Card.Detach(state.deck[i]) END;
    Card.Attach(state.deck[0], state.talon[1]);
    Card.Attach(state.deck[1], state.talon[2]);
    j := 0;
    FOR i := 2 TO LAST(state.deck) DO
      Card.Attach(state.deck[i], state.layout[j].below);
      IF j < LAST(state.layout) THEN INC(j) ELSE j := 0 END
    END;
    WHILE Play(a, b) DO Card.Attach(a, b) END;
    state.neverWon := TRUE;
    Card.StartUndoLog()
  END StdinLayout;

<* FATAL Wr.Failure, Thread.Alerted *>

PROCEDURE Main () =
  <* FATAL Split.NotAChild *>
  VAR  fromStdin: BOOLEAN;
  BEGIN
    Card.EnableHighlight(TRUE, 600);
    ParseParams.BeginParsing();
    verbose := ParseParams.KeywordPresent("-v");
    fromStdin := ParseParams.KeywordPresent("-f");
    state := NIL;
    board := TSplit.Cons(NewGame(state, fromStdin));
    txtMsg := TextVBT.New("", fnt := msgFont);
    menu := BorderedVBT.New(
              HVSplit.Cons(
                Axis.T.Ver, MButton("Score", DoScore, board),
                MButton("rEset", DoReset), MButton("Help", DoHelp, board),
                MButton("New game", DoNewLayout),
                MButton("track On", TrackingOn, board),
                MButton("track oFf", TrackingOff, board),
                MButton("Quit", DoExit)));
    abortButton := TSplit.Cons(TButton("Abort", DoAbort), NIL);
    TSplit.SetCurrent(abortButton, NIL);
    game :=
      KeyGrabNew(
        HVSplit.Cons(
          Axis.T.Ver,
          ButtonVBT.MenuBar(
            TBorder(AnchorBtnVBT.New(
                      TextVBT.New("Control", fnt := buttonFont), menu,
                      99999), op := PaintOp.Bg), TButton("Undo", DoUndo),
            TButton("Redo", DoRedo), TButton("hint", DoHint), abortButton,
            txtMsg), board), MButton("Bogus", DoExit, board));
    TRY
      IF ParseParams.KeywordPresent("-display") THEN
        Trestle.Install(
          game, trsl := Trestle.Connect(ParseParams.GetNext()))
      ELSE
        Trestle.Install(game)
      END;
      Trestle.AwaitDelete(game)
    EXCEPT
      TrestleComm.Failure =>
        Wr.PutText(
          Stdio.stderr, "solitaire: couldn't contact window system\n")
    | Scan.BadFormat =>
        Wr.PutText(Stdio.stderr, "solitaire: bad -display paramter\n")
    END
  END Main;

BEGIN
  Main();
END Solitaire.