Last modified on Tue Jan 31 16:54:02 PST 1995 by kalsow 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
MODULEIMPORT RTHeapStats; IMPORT RTutils, RTCollector;Solitaire EXPORTSMain ; IMPORT AnchorBtnVBT, Axis, BorderedVBT, ButtonVBT, Card, Filter, Fmt, Font, HVSplit, Latin1Key, MenuBtnVBT, MouseSplit, PackSplit, PaintOp, Params, Point, Rd, RigidVBT, Solve, Solve2, Split, Stdio, TSplit, Text, TextVBT, TextureVBT, Thread, Trestle, TrestleComm, VBT, Wr, ZSplit, KeyboardKey, Process, Time; IMPORT RTProcess, IO;
FROM Card IMPORT Width, Height, Overlap, Value, Suit, Real, Family; CONST Gutter = 6; (*16*) Gap = 3; (*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{ "-*-helvetica-bold-r-*-*-*-120-*-*-*-*-iso8859-1", "-*-menu-medium-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"}); PROCEDUREPlay (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; PROCEDUREObvious (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; PROCEDUREStupid (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; PROCEDURETrivial (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; PROCEDUREAttachable (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; PROCEDURENewDeck (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; PROCEDUREShape ( <*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 + 10 * 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; PROCEDURENewGame (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; PROCEDURENewLayout ( <*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; fromStdin : BOOLEAN; display : TEXT := NIL; PROCEDURETrackingOn ( <*UNUSED*> button: ButtonVBT.T; <*UNUSED*> READONLY cd : VBT.MouseRec ) = BEGIN Card.EnableTracking(TRUE); END TrackingOn; PROCEDURETrackingOff ( <*UNUSED*> button: ButtonVBT.T; <*UNUSED*> READONLY cd : VBT.MouseRec ) = BEGIN Card.EnableTracking(FALSE); END TrackingOff; PROCEDUREDoNewLayout ( <*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; PROCEDUREDoUndo ( <*UNUSED*> button: ButtonVBT.T; <*UNUSED*> READONLY cd : VBT.MouseRec ) = BEGIN RemoveHelp(); EVAL Card.Undo() END DoUndo; PROCEDUREDoHint ( <*UNUSED*>button: ButtonVBT.T; READONLY cd: VBT.MouseRec) = BEGIN
*** RTutils.Heap (suppressZeros := TRUE, presentation := RTutils.HeapPresentation.ByNumber, window := 10); RTCollector.Disable(); RTCollector.Enable(); (* force a full collection
RTCollector.Disable(); RTCollector.Enable(); ****) DoSolve (cd, 0); END DoHint; PROCEDUREDoHint2 ( <*UNUSED*>button: ButtonVBT.T; READONLY cd: VBT.MouseRec) = BEGIN DoSolve (cd, 1); END DoHint2; PROCEDUREDoSolve (READONLY cd: VBT.MouseRec; which_solver: INTEGER) = <*FATAL Split.NotAChild*> VAR howHard: [0 .. 2]; msg : TEXT; BEGIN CASE cd.whatChanged OF | VBT.Modifier.MouseL => howHard := 0; msg := "checking for a win..."; | VBT.Modifier.MouseR => howHard := 2; msg := "checking for a win..."; | VBT.Modifier.MouseM => howHard := 1; msg := "checking hard for a win..."; 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, solver := which_solver)); END DoSolve; TYPE SolveClosure = Thread.SizedClosure OBJECT howHard : [0 .. 2]; solver : [0..1]; OVERRIDES apply := SolveIt; END; PROCEDUREDoAbort ( <*UNUSED*> button: ButtonVBT.T; <*UNUSED*> READONLY cd : VBT.MouseRec ) = BEGIN RemoveHelp(); IF solver # NIL THEN Thread.Alert(solver) END; END DoAbort; PROCEDURESolveIt (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; depth : CARDINAL; breadth : CARDINAL; total : CARDINAL; start : Time.T; elapsed : Time.T; 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 *) depth := 2000; breadth := 500; total := 100000; | 1 => (* for unsolved in previous, solves about 46%, 73 secs/game *) depth := 80000; breadth := 2000; total := 100000; END; start := Time.Now (); IF (self.solver = 0) THEN txt := Solve.NextMove(layout, why, depth, breadth, total, verbose := verbose, callback := PrintCount); ELSE txt := Solve2.NextMove(layout, why, depth, breadth, total, verbose := verbose, callback := PrintCount); END; elapsed := Time.Now () - start; IF self.howHard = 2 AND why = Solve.WhyStop.Solution THEN txt := "Game is winnable" END; (* if *) IF (elapsed > 0.5d0) THEN txt := Fmt.F ("%s (%s sec.)", txt, Fmt.LongReal (elapsed, Fmt.Style.Fix, prec := 2)); END; 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; PROCEDUREPrintCount (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; PROCEDUREDoRedo ( <*UNUSED*> button: ButtonVBT.T; <*UNUSED*> READONLY cd : VBT.MouseRec ) = BEGIN RemoveHelp(); EVAL Card.Redo(TRUE) END DoRedo; PROCEDUREDoReset ( <*UNUSED*> button: ButtonVBT.T; <*UNUSED*> READONLY cd : VBT.MouseRec ) = BEGIN RemoveHelp(); WHILE Card.Undo() DO END END DoReset; PROCEDUREDoExit ( <*UNUSED*> button: ButtonVBT.T; <*UNUSED*> READONLY cd : VBT.MouseRec ) = BEGIN
RTHeapStats.ReportReachable ();
Trestle.Delete(game) END DoExit; PROCEDURERemoveHelp () = <*FATAL Split.NotAChild*> BEGIN TextVBT.Put(txtMsg, ""); TSplit.SetCurrent(board, Split.Succ(board, NIL)); END RemoveHelp; PROCEDUREAddText (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; PROCEDUREParaShape (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; PROCEDUREParagraph (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; PROCEDURECreateHelp ( <*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; PROCEDURESpacer (): 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; PROCEDUREHelpSplitCons (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, 5.0, op := PaintOp.Bg); RETURN res END HelpSplitCons; TYPE HelpVBT = BorderedVBT.T OBJECT OVERRIDES mouse := HelpMouse END; PROCEDUREHelpMouse ( <*UNUSED*> v : HelpVBT; <*UNUSED*> READONLY cd: VBT.MouseRec ) = BEGIN RemoveHelp() END HelpMouse; PROCEDUREDoHelp (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; PROCEDURECreateScore ( <*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; PROCEDUREDoScore (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; PROCEDURETBorder (v: VBT.T; op := PaintOp.Fg): VBT.T = BEGIN RETURN BorderedVBT.New(v, 0.3, op := op) END TBorder; PROCEDURETButton (name: Text.T; proc: ButtonVBT.Proc): ButtonVBT.T = BEGIN RETURN ButtonVBT.New(TBorder(TextVBT.New(name, fnt := buttonFont)), proc) END TButton; PROCEDUREMButton (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; PROCEDUREKeyKey (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; PROCEDUREKeyMisc (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; PROCEDUREKeyMouse (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; PROCEDUREKeyGrabNew (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; PROCEDURETakeFocus (v: KeyGrab; time: VBT.TimeStamp) = BEGIN TRY VBT.Acquire(v, VBT.KBFocus, time); v.hasFocus := TRUE EXCEPT VBT.Error => END END TakeFocus; PROCEDUREGetC (rd: Rd.T): CHAR = <*FATAL Rd.Failure, Rd.EndOfFile*> BEGIN IF Rd.EOF (rd) THEN RETURN '\000'; ELSE RETURN Rd.GetChar (rd); END; END GetC; PROCEDUREScanCard (rd: Rd.T): [0 .. 51] = VAR val: CARDINAL; ch := GetC (rd); BEGIN (* skip white space *) WHILE (ch = ' ') OR (ch = '\n') OR (ch = '\t') DO ch := GetC (rd); END; IF (ch < '1') OR ('9' < ch) THEN BadInput () END; val := ORD (ch) - ORD ('0'); ch := GetC (rd); IF ('0' <= ch) AND (ch <= '3') THEN val := 10 * val + ORD(ch) - ORD('0'); ch := GetC (rd); END; IF (val < 1) OR (val > 13) THEN BadInput () END; CASE ch OF | 'S' => RETURN ((val - 1) * 4 + 0); | 'H' => RETURN ((val - 1) * 4 + 1); | 'D' => RETURN ((val - 1) * 4 + 2); | 'C' => RETURN ((val - 1) * 4 + 3); ELSE BadInput (); RETURN 0; END; END ScanCard; PROCEDUREBadInput () = BEGIN 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 BadInput; PROCEDUREStdinLayout ( <*UNUSED*>v: VBT.T; state: State) = <*FATAL Card.BadDeal*> VAR j : INTEGER; a, b: Card.T; tmp : ARRAY [0 .. 51] OF Card.T; BEGIN FOR i := 0 TO 51 DO j := ScanCard(Stdio.stdin); tmp[i] := state.deck[j]; 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 *> PROCEDUREGetParams () = VAR i := 1; p: TEXT; BEGIN WHILE i < Params.Count DO p := Params.Get (i); IF Text.Equal (p, "-v") THEN verbose := TRUE; ELSIF Text.Equal (p, "-f") THEN fromStdin := TRUE; ELSIF Text.Equal (p, "-display") THEN INC (i); IF (i >= Params.Count) THEN BadDisplay () END; display := Params.Get (i); END; INC (i); END; END GetParams; PROCEDUREBadDisplay () = BEGIN Wr.PutText(Stdio.stderr, "solitaire: bad -display parameter\n"); Process.Exit (1); END BadDisplay; PROCEDUREMain () = <* FATAL Split.NotAChild *> BEGIN Card.EnableHighlight(TRUE, 600); GetParams (); 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), TButton("hint2", DoHint2), abortButton, txtMsg), board), MButton("Bogus", DoExit, board)); TRY IF (display # NIL) THEN Trestle.Install(game, trsl := Trestle.Connect(display)) ELSE Trestle.Install(game) END; Trestle.AwaitDelete(game) EXCEPT TrestleComm.Failure => Wr.PutText( Stdio.stderr, "solitaire: couldn't contact window system\n") END END Main; VAR old_handler: RTProcess.InterruptHandler := NIL; PROCEDURECtrlC () = BEGIN IO.Put ("\r\n**Control-C**\r\n"); IF (old_handler # NIL) THEN old_handler (); END; END CtrlC; BEGIN old_handler := RTProcess.OnInterrupt (CtrlC); Main(); END Solitaire.