Contributor: BENJAMIN ARNOLDY
{_____________________________________________________________________________
| Filename: CODE.PAS
| Title: Spite & Malice
| Written By: Benjamin Arnoldy and Raechel Kula
|_____________________________________________________________________________
| Contents:
| The procedures: Deal, WhoseTurn, PickupCards, Decision, GetMove,
| CheckMove, MoveCard
| Oject: Pile
|_____________________________________________________________________________
| Synopsis:
| This program allows the user to select either another person, or the
computer as the opponent, then play the opponent in the card game
| Spite & Malice. The interface is textual.
|_____________________________________________________________________________
| Description:
| No references at this time.
|_____________________________________________________________________________
| Environment:
| TurboPASCAL for the PC.
|_____________________________________________________________________________
| Version History:
|
| Version 5.1 -- May 8, 1996
| Raechel Kula & Benjamin Arnoldy
| Improved interface and Decision.
|
| Version 5.0 -- May 7, 1996
| Raechel Kula & Benjamin Arnoldy
| Code is cleaned up and ready for presentation.
|
| Version 4.3 -- May 6, 1996
| Raechel Kula & Benjamin Arnoldy
| Additional testing, more tinkering with weights.
|
| Version 4.2 -- May 5, 1996
| Raechel Kula & Benjamin Arnoldy
| Added provisions in decision for jokers.
|
| Version 4.1 -- May 4, 1996
| Raechel Kula & Benjamin Arnoldy
| Testing and tinkering with weights to make
| the computer a better opponent.
|
| Version 4.0 -- May 3, 1996
| Raechel Kula & Benjamin Arnoldy
| An "operable" Decision procedure is
| in place.
|
| Version 3.1 -- May 2, 1996
| Raechel Kula & Benjamin Arnoldy
| Various Embellishments to make it an operable
| 2 player game (e.g. end of game stuff).
|
| Version 3.0 -- May 1, 1996
| Raechel Kula & Benjamin Arnoldy
| Ascii Graphical Interface is instituted.
|
| Version 2.9 -- April 30, 1996
| Raechel Kula & Benjamin Arnoldy
| Small display functions (CardString) coded.
|
| Version 2.2 -- April 28, 1996
| Raechel Kula & Benjamin Arnoldy
| CheckMove procedure ironed out.
|
| Version 2.1 -- April 26, 1996
| Raechel Kula & Benjamin Arnoldy
| Basic Main Program Procedures Modified to fit with new
| object structure.
|
| Version 2.0 -- April 25, 1996
| Raechel Kula & Benjamin Arnoldy
| Object Pile Coded.
|
| MidApril -- Meeting with Prof Squier & Subsequent Major Rethinking
|
| Version 1.1 -- Apr. 7, 1996
| Raechel Kula & Benjamin Arnoldy
| Pieces of Decision and CheckMove procedures are
| completed.
|
| Version 1.0 -- Mar. 29, 1996
| Raechel Kula & Benjamin Arnoldy
| WhoseTurn, PickupCards, MoveCard procedures are coded.
| The code successfully compiles.
|
| Version 0.2 -- Mar. 12, 1996
| Raechel Kula & Benjamin Arnoldy
| Deal and GetMove procedures are coded.
|
| Version 0.2 -- Mar. 5, 1996
| Raechel Kula & Benjamin Arnoldy
| GetValue and GetPlace procedures are coded.
|
| Version 0.1 -- Feb. 30, 1996
| Raechel Kula & Benjamin Arnoldy
| Main Program and Stubs
| Version 0.0
|____________________________________________________________________________}
program SpiteMalice;
uses CRT;
{=============================================================================
CONSTANTS
=============================================================================}
const DRAWPILE_MAX = 108;
HAND_MAX = 6;
SCOREPILE_MAX = 14;
DISCARDPILE_MAX = 108;
ACEPILE_MAX = 13;
TRASHPILE_MAX = 108;
MAXSIZE = 108;
NULL = -1;
{=============================================================================
TYPES
=============================================================================}
type CardVal_t = integer;
Pos_t = integer;
CardArray_t = array [1..108] of CardVal_t;
CardValTable_t = array [1..26] of CardVal_t;
choiceTable_t = array [1..26, 1..19] of integer;
{=============================================================================
OBJECT DECLARATION
=============================================================================}
type Pile = object
{public}
procedure Init;
procedure RandomShuffle;
procedure PutOnTop (CardtoPutOn: CardVal_t);
function RemoveFromTop: CardVal_t;
function SeeRandom (Pos: Pos_t): CardVal_t;
function DeleteByValue (value : CardVal_t): CardVal_t;
function IsPresent (CardtoFind: CardVal_t): boolean;
function NumCards: integer;
private
data: CardArray_t;
top: Pos_t; {top = slot with top card in it.}
end; {Object declaration}
{=============================================================================
OBJECT DEPENEDENT TYPES
=============================================================================}
Type pilepointer_t = ^Pile;
stack_t = array [1..26] of pilepointer_t;
{=============================================================================
GLOBAL VARIABLES
=============================================================================}
var DrawPile: Pile;
PlayerHand: Pile;
ComputerHand: Pile;
PlayerScorePile: Pile;
ComputerScorePile: Pile;
PlayerDiscardPile1: Pile;
PlayerDiscardPile2: Pile;
PlayerDiscardPile3: Pile;
PlayerDiscardPile4: Pile;
ComputerDiscardPile1: Pile;
ComputerDiscardPile2: Pile;
ComputerDiscardPile3: Pile;
ComputerDiscardPile4: Pile;
AcePile1: Pile;
AcePile2: Pile;
AcePile3: Pile;
AcePile4: Pile;
TrashPile: Pile;
ComputerTurn: boolean;
Game: boolean;
Valid, Discard, DecisionDiscard: boolean;
From, Tto: integer;
PosTable : stack_t;
TopCardTable: CardValTable_t;
pos: integer;
Winner: string;
ChoiceRate: choiceTable_t;
AnotherGame: boolean;
TwoPlayer: boolean;
MustMove: boolean;
{=============================================================================
OBJECT PROCEDURES & FUNCTIONS
=============================================================================}
{____________________________________________________________________
| Init
| Initializes a pile's array (data) and pointer (top)
|___________________________________________________________________}
procedure Pile.Init;
var Count: integer;
begin
top := MAXSIZE + 1;
for Count := 1 to MAXSIZE do
Pile.PutOnTop (NULL); {Stores NULL values in entire array.}
top := MAXSIZE + 1;
end; {procedure Init}
{____________________________________________________________________
| RandomShuffle
| Shuffles the cards in a pile.
|___________________________________________________________________}
procedure Pile.RandomShuffle;
var ShuffleArray: Pile; {Temporary Storage Pile}
Counter: Pos_t;
RandSlot: integer;
DeckSize: integer;
TopofDeck: Pos_t;
begin
DeckSize := DrawPile.NumCards;
TopofDeck := (MAXSIZE - DeckSize) + 1;
ShuffleArray.Init; {Initializing ShuffleArray}
ShuffleArray.top := TopofDeck;
for Counter := 1 to DeckSize do begin
RandSlot := Random (DeckSize) + 1; {'+1' due to Random range.}
While ShuffleArray.SeeRandom (RandSlot) <> NULL do
RandSlot := Random (DeckSize) + 1;
ShuffleArray.top := TopofDeck + Randslot;
{Set ShuffleArray's "top" pointer to slot beneath empty slot, so
that PutOnTop will put the card in the empty slot.}
ShuffleArray.PutOnTop (DrawPile.RemoveFromTop);
ShuffleArray.top := TopofDeck;
end; {for}
ShuffleArray.top := TopofDeck;
{Set ShuffleArray's "top" pointer to the top of the stack.}
for Counter := 1 to DeckSize do
DrawPile.PutOnTop (ShuffleArray.RemoveFromTop);
{Transfered shuffled ShuffleArray to DrawPile.}
end; {Procedure RandomShuffle}
{____________________________________________________________________
| PutOnTop
| Places a card value on the top of the pile.
|
|___________________________________________________________________}
procedure Pile.PutOnTop (CardtoPutOn: CardVal_t);
begin
top := top - 1; {Advance the top pointer to the empty slot above it.}
If top < 0 then begin
writeln ('ERROR. Array Overflow.');
HALT;
{Program is stopped if program attempts to a put a card on top of what
should be a full pile. This should never never happen given that the
size of the pile arrays are the same size as the number of cards.}
end;
data [top] := CardtoPutOn;
end; {procedure PutOnTop}
{____________________________________________________________________
| RemoveFromTop
| Removes the top card from a pile and return the value of
| of the card.
|___________________________________________________________________}
function Pile.RemoveFromTop: CardVal_t;
begin
RemoveFromTop := data [top];
data [top] := NULL;
top := top + 1; {Adjusts the top pointer so it points at the top card.}
end; {Procedure RemoveFromTop}
{____________________________________________________________________
| SeeRandom
| Allows the program to view the card value in any given
| position in a stack.
|___________________________________________________________________}
function Pile.SeeRandom (pos: Pos_t): CardVal_t;
begin
SeeRandom := data [top + pos - 1];
{The "- 1" in the equation defines position 1 as the top card.}
if (top + pos - 1) > MAXSIZE then
SeeRandom := NULL;
{if the seek excedes the boundaries, a null value is returned.}
end; {Procedure SeeRandom}
{____________________________________________________________________
| DeleteByValue
| Searches through a pile for a designated value, and "pulls"
| the card out, returning the card's value. After the card is
| removed, the gap in the stack is filled in by readjusting the
| cards.
|___________________________________________________________________}
function Pile.DeleteByValue (value : CardVal_t): CardVal_t;
var count:integer; hold : CardVal_t;
begin
count:=0;
Repeat
count :=count+1;
Until (data[count] = value);
hold := data[top];
data[top] := value;
data[count] := hold;
hold := Pile.RemoveFromTop;
end; {Procedure DeleteByValue}
{____________________________________________________________________
| IsPresent
| Searches through a pile, looking to see if a designated card
| value is present.
|___________________________________________________________________}
function Pile.IsPresent (CardtoFind: CardVal_t): boolean;
var
ValuePresent: boolean;
begin
ValuePresent := FALSE;
while ((ValuePresent = FALSE) OR (top > MAXSIZE)) do begin
top := top + 1;
If data [top] = CardtoFind then
ValuePresent := TRUE;
end; {While}
If ValuePresent = FALSE then
IsPresent := FALSE
else
IsPresent := TRUE;
end; {Function IsPresent}
{____________________________________________________________________
| NumCards
| Returns the number of cards in a pile.
|___________________________________________________________________}
function Pile.NumCards: integer;
begin
NumCards := (MAXSIZE - top) + 1;
{The "+ 1" in the equation takes into account that the position of top
contains a card.}
end; {function NumCards}
{============================================================================
GENERAL FUNCTIONS
============================================================================}
{____________________________________________________________________
| CardValue
| Converts card value (4..111) to orderinal value.
| (0 = Joker, 1,2,3,...10,11 = JACK,...)
|___________________________________________________________________}
function CardValue (Card: CardVal_t): integer;
begin
if Card = NULL then
CardValue := NULL
else
CardValue := Card DIV 8;
end; {function CardValue}
{____________________________________________________________________
| CardString
| Converts a card value to a string, for representation on the
| screen.
|___________________________________________________________________}
function CardString (Card: CardVal_t): string;
var
Number: integer;
Output: string;
begin
Number := Card DIV 8;
if Card = NULL then Output := '' else
if Number = 0 then Output := 'JO' else
if Number = 1 then Output := 'AC' else
if Number = 2 then Output := '02' else
if Number = 3 then Output := '03' else
if Number = 4 then Output := '04' else
if Number = 5 then Output := '05' else
if Number = 6 then Output := '06' else
if Number = 7 then Output := '07' else
if Number = 8 then Output := '08' else
if Number = 9 then Output := '09' else
if Number = 10 then Output := '10' else
if Number = 11 then Output := 'JA' else
if Number = 12 then Output := 'QU' else
if Number = 13 then Output := 'KI' else
Output := 'ERROR';
Number := Card MOD 4;
if Card = NULL then Output := '' else
if (Card DIV 8) = 0 then Output := Output + '!' else
if Number = 0 then Output := Output + chr(3) else
if Number = 1 then Output := Output + chr(4) else
if Number = 2 then Output := Output + chr(5) else
if Number = 3 then Output := Output + chr(6) else
Output := 'ERROR';
CardString := Output;
end; {function CardSuit}
{___________________________________________________________________
| AceTopCard
| Due to the possibility of a joker on an ace pile, this
| function returns the ordinal value of the card on the top of
| an ace pile -- if there's a joker it is converted to its
| ordinal value within the pile.
|___________________________________________________________________}
function AceTopCard (Number: integer): integer;
var position: integer;
begin
position := 1;
while (CardValue (PosTable [Number]^.SeeRandom (position)) = 0) do
position := position + 1;
AceTopCard := CardValue (PosTable [Number]^.SeeRandom (position)) +
position - 1;
end; {function AceTopCard}
{============================================================================
MAIN PROGRAM PROCEDURES
(Grouped with corresponding sub-procedures)
============================================================================}
{___________________________________________________________________
| Initialize
| Does all the Non-Object initialization.
|__________________________________________________________________}
procedure Initialize;
var count:integer;
begin
Randomize;
DrawPile.Init;
PlayerHand.Init;
ComputerHand.Init;
PlayerScorePile.Init;
ComputerScorePile.Init;
PlayerDiscardPile1.Init;
PlayerDiscardPile2.Init;
PlayerDiscardPile3.Init;
PlayerDiscardPile4.Init;
ComputerDiscardPile1.Init;
ComputerDiscardPile2.Init;
ComputerDiscardPile3.Init;
ComputerDiscardPile4.Init;
AcePile1.Init;
AcePile2.Init;
AcePile3.Init;
AcePile4.Init;
TrashPile.Init;
Game := TRUE;
{Set up Position Table}
PosTable[1] := @PlayerHand;
PosTable[2] := @PlayerHand;
PosTable[3] := @PlayerHand;
PosTable[4] := @PlayerHand;
PosTable[5] := @PlayerHand;
PosTable[6] := @PlayerHand;
PosTable[7] := @PlayerScorePile;
PosTable[8] := @PlayerDiscardPile1;
PosTable[9] := @PlayerDiscardPile2;
PosTable[10] := @PlayerDiscardPile3;
PosTable[11] := @PlayerDiscardPile4;
PosTable[12] := @AcePile1;
PosTable[13] := @AcePile2;
PosTable[14] := @AcePile3;
PosTable[15] := @AcePile4;
PosTable[16] := @ComputerDiscardPile1;
PosTable[17] := @ComputerDiscardPile2;
PosTable[18] := @ComputerDiscardPile3;
PosTable[19] := @ComputerDiscardPile4;
PosTable[20] := @ComputerHand;
PosTable[21] := @ComputerHand;
PosTable[22] := @ComputerHand;
PosTable[23] := @ComputerHand;
PosTable[24] := @ComputerHand;
PosTable[25] := @ComputerHand;
PosTable[26] := @ComputerScorePile;
end; {procedure Initialize}
{___________________________________________________________________
| InitTable
| Refreshes the values for the TopCardTable, which stores the
| values of the top card in all 26 positions.
|__________________________________________________________________}
procedure InitTable;
var count:integer;
begin
for count := 1 to 6 Do
TopCardTable[count] := PosTable[count]^.SeeRandom (count);
for count := 7 to 19 Do
TopCardTable[count] := PosTable[count]^.SeeRandom (1);
for count := 20 to 25 Do
TopCardTable[count] := PosTable[count]^.SeeRandom(count-19);
TopCardTable[26] := PosTable[26]^.SeeRandom(1);
end; {procedure InitTable}
{___________________________________________________________________
| Deal
| Deals the cards at the beginning of each game and decides,
| based on the outcome of the deal, who will go first.
|__________________________________________________________________}
procedure Deal;
var Card: CardVal_t;
Counter: integer;
PlayerScoreTop: CardVal_t;
ComputerScoreTop: CardVal_t;
begin
for Card := (1 +3) to (MAXSIZE +3) do
{Put 2 decks of cards in draw pile, +3 is necessary for the div and mod
to operate correctly.}
DrawPile.PutOnTop (Card);
DrawPile.RandomShuffle; {Shuffle the draw pile.}
for Counter := 1 to 5 do begin {Deal the hands}
PlayerHand.PutOnTop (DrawPile.RemoveFromTop);
ComputerHand.PutOnTop (DrawPile.RemoveFromTop);
end; {for}
for Counter := 1 to 14 do begin {Deal the score piles}
PlayerScorePile.PutOnTop (DrawPile.RemoveFromTop);
ComputerScorePile.PutOnTop (DrawPile.RemoveFromTop);
end; {for}
PlayerDiscardPile1.PutOnTop (DrawPile.RemoveFromTop);
PlayerDiscardPile2.PutOnTop (DrawPile.RemoveFromTop);
PlayerDiscardPile3.PutOnTop (DrawPile.RemoveFromTop);
PlayerDiscardPile4.PutOnTop (DrawPile.RemoveFromTop);
ComputerDiscardPile1.PutOnTop (DrawPile.RemoveFromTop);
ComputerDiscardPile2.PutOnTop (DrawPile.RemoveFromTop);
ComputerDiscardPile3.PutOnTop (DrawPile.RemoveFromTop);
ComputerDiscardPile4.PutOnTop (DrawPile.RemoveFromTop);
{Decide whose turn it is. ComputerTurn set to opposite, because
it will be reversed in upcoming WhoseTurn procedure.}
PlayerScoreTop := CardValue (PlayerScorePile.SeeRandom(1));
ComputerScoreTop := CardValue (ComputerScorePile.SeeRandom(1));
if PlayerScoreTop = 0 then
ComputerTurn := FALSE
else if ComputerScoreTop = 0 then
ComputerTurn := TRUE
else if PlayerScoreTop = ComputerScoreTop then
ComputerTurn := FALSE
else if PlayerScoreTop > ComputerScoreTop then
ComputerTurn := TRUE
else
ComputerTurn := FALSE;
end; {Deal}
{___________________________________________________________________
| OutString
| One of the procedures involving the interface.
| This procedure receives x,y coordinates for a screen position
| and outputs a string starting at that position.
|__________________________________________________________________}
procedure OutString (x,y: integer; toPrint: string);
begin
GotoXY (x,y);
write (toPrint);
end; {procedure OutString}
{____________________________________________________________________
| ColorDim
| One of the procedures involving the interface.
| Sets colors for displaying things involving the player whose
| turn it is not (hence, they are dimmed.)
|___________________________________________________________________}
procedure ColorDim;
begin
TextColor (LIGHTgray);
TextBackground (BLACK);
end; {procedure ColorDim}
{___________________________________________________________________
| ColorCard
| One of the procedures involving the interface.
| Sets colors for displaying a card of the player whose turn it
| is.
|___________________________________________________________________}
procedure ColorCard;
begin
TextColor (YELLOW);
TextBackGround (BLUE);
end; {procedure ColorCard}
{____________________________________________________________________
| ColorFrame
| One of the procedures involving the interface.
| Sets colors for highlighting the section of the frame
| involving the player whose turn it is.
|___________________________________________________________________}
procedure ColorFrame;
begin
TextColor (YELLOW);
TextBackground (BLACK);
end; {procedure ColorFrame}
{____________________________________________________________________
| ColorNormalText
| One of the procedures involving the interface.
| Sets colors for normal text and is also the colors which the
| game returns to upon exiting.
|___________________________________________________________________}
procedure ColorNormalText;
begin
TextColor (WHITE);
TextBackground (BLACK);
end; {procedure ColorNormalText}
{___________________________________________________________________
| ColorPosition
| One of the procedures involving the interface.
| Sets colors for the display of position indicators.
|__________________________________________________________________}
procedure ColorPosition;
begin
TextColor (WHITE);
TextBackground (RED);
end; {procedure ColorPosition}
{___________________________________________________________________
| TitleScreen
| Displays a title screen and asks whether the user would like
| a one-player or a two-player game. Accompanying procedures are
| called by TitleScreen
|__________________________________________________________________}
procedure Heart;
begin
TextColor (red);
TextBackground (LightGray);
write (char(3));
end;
procedure Club;
begin
TextColor (black);
TextBackground (LightGray);
write (char(5));
end;
procedure Diamond;
begin
TextColor (red);
TextBackground (lightgray);
write (char(4));
end;
procedure Spade;
begin
TextColor (black);
TextBackground (lightgray);
write (char(6));
end;
procedure SuitsCol (x, y, count: integer);
var c :integer;
begin
c := 0;
while (count > 0) Do begin
GotoXY (x, y+c*4);
Heart;
GotoXY (x, y+c*4+1);
Club;
GotoXY (x, y+c*4+2);
Diamond;
GotoXY (x, y+c*4+3);
Spade;
c := c + 1;
count := count - 1;
TextBackGround (black);
end; {while loop}
end; {SuitsCol}
procedure SuitsRow (x, y, count: integer);
var c :integer;
begin
c := 0;
while (count > 0) Do begin
GotoXY (x + (4*c), y);
Heart;
Club;
Diamond;
Spade;
c := c + 1;
count := count - 1;
TextBackground (black);
end; {while loop}
end; {SuitsRow}
procedure DrawTitleBox;
Begin
SuitsCol (25, 7, 2);
SuitsRow (25, 7, 8);
SuitsRow (25, 15, 8);
SuitsCol (57, 7, 2);
GotoXY (57, 15);
Heart;
end; {DrawTitleBox}
procedure Title;
begin
TextColor (white);
TextBackground (black);
OutString (28, 9, 'Welcome to Spite & Malice!');
end;
procedure Info (var TwoPlayer : boolean);
var response : char;
begin
repeat
OutString (33, 12, 'How many players?');
OutString (37, 13, '(');
TextColor (lightred);
OutString (38, 13, '1 ');
TextColor (white);
OutString (40, 13, 'or ');
TextColor (lightred);
OutString (43, 13, '2');
TextColor (white);
OutString (44, 13, ')');
GotoXY (40, 14);
readln (response);
until ((response = '1') OR (response = '2'));
if response = '1' then
TwoPlayer := FALSE
else
TwoPlayer := TRUE;
end;
procedure TitleScreen (var TwoPlayer:boolean);
var response: char;
Begin
TextBackground (black);
clrscr;
TextBackground (black);
DrawTitleBox;
Title;
Info (TwoPlayer);
TextBackground (black);
TextColor (white);
End; {procedure TitleScreen}
{___________________________________________________________________
| DrawFrame
| One of the procedures involving the interface.
| This procedure draws the ascii graphical skeleton of the
| screen. It also takes into account the turn in its choice of
| colors.
|__________________________________________________________________}
procedure DrawFrame (ComputerTurn: boolean);
var Row: integer;
Column: integer;
begin
{Clear screen with Black background.}
TextBackGround (BLACK);
TextColor (BLACK);
For Row:= 1 to 25 do
For Column := 1 to 80 do begin
if NOT ((Row = 25) and (Column = 80)) then
OutString (Column, Row, chr(219));
end; {for column}
if ComputerTurn = TRUE then
ColorDim
else
ColorFrame;
OutString (1,1,chr(201));
OutString (1,24,chr(200));
OutString (31,1,chr(203));
OutString (31,24,chr(202));
for Column := 2 to 30 do begin
OutString (Column,1,chr(205));
OutString (Column,24,chr(205));
end; {for}
For Row := 2 to 23 do begin
OutString (1,Row,chr(186));
OutString (31,Row,chr(186));
end; {for}
Outstring (1,18,chr(204));
Outstring (31,18,chr(185));
For Row := 2 to 30 do
OutString (Row,18,chr(205));
OutString (31,5,chr(204));
OutString (31,13,chr(204));
if ComputerTurn = TRUE then
ColorFrame
else
ColorDim;
For Column := 51 to 79 do begin
OutString (Column,1,chr(205));
OutString (Column,18,chr(205));
OutString (Column,24,chr(205));
end; {for}
For Row := 2 to 23 do begin
OutString (50,Row,chr(186));
OutString (80,Row,chr(186));
end; {for}
OutString (50,1,chr(203));
OutString (50,24,chr(202));
OutString (50,5,chr(185));
OutString (50,13,chr(185));
OutString (50,18,chr(204));
OutString (80,1,chr(187));
OutString (80,24,chr(188));
ColorFrame;
For Column := 32 to 49 do begin
OutString (Column,1,chr(205));
OutString (Column,5,chr(205));
OutString (Column,13,chr(205));
OutString (Column,24,chr(205));
end; {for}
TextColor (BLUE);
for Row := 2 to 4 do
for Column := 32 to 49 do
OutString (Column,Row,chr(219));
TextColor (WHITE);
TextBackground (BLUE);
OutString (34,2,'Spite & Malice');
OutString (34,3,'By Ben Arnoldy');
OutString (34,4,'& Raechel Kula');
end; {procedure DrawFrame}
{___________________________________________________________________
| DrawDiscards
| One of the procedures involved with the interface.
| This procedure sets up the discard portions of the screen.
|__________________________________________________________________}
procedure DrawDiscards (ComputerTurn:boolean);
var Counter: Pos_t;
begin
if ComputerTurn = TRUE then
ColorDim
else
ColorNormalText;
OutString (9,2,'Player Discard');
if ComputerTurn = TRUE then
ColorNormalText
else
ColorDim;
if (TwoPlayer = FALSE) then
OutString (58,2,'Computer Discard')
else if (TwoPlayer = TRUE) then
OutString (58,2,'Opponent Discard');
ColorPosition;
OutString (3,3,'H'+chr(26));
OutString (10,3,'I'+chr(26));
OutString (17,3,'J'+chr(26));
OutString (24,3,'K'+chr(26));
OutString (52,3,'P'+chr(26));
OutString (59,3,'Q'+chr(26));
OutString (66,3,'R'+chr(26));
OutString (73,3,'S'+chr(26));
for Counter := 1 to 14 do begin
if ComputerTurn = TRUE then
ColorDim
else
ColorCard;
OutString(6,2+Counter,
CardString (PlayerDiscardPile1.SeeRandom(Counter)));
OutString(13,2+Counter,
CardString (PlayerDiscardPile2.SeeRandom(Counter)));
OutString(20, 2+Counter,
CardString (PlayerDiscardPile3.SeeRandom(Counter)));
OutString(27, 2+Counter,
CardString (PlayerDiscardPile4.SeeRandom(Counter)));
if ComputerTurn = FALSE then
ColorDim
else
ColorCard;
OutString(55, 2+Counter,
CardString (ComputerDiscardPile1.SeeRandom(Counter)));
OutString(62, 2+Counter,
CardString (ComputerDiscardPile2.SeeRandom(Counter)));
OutString(69, 2+Counter,
CardString (ComputerDiscardPile3.SeeRandom(Counter)));
OutString(76, 2+Counter,
CardString (ComputerDiscardPile4.SeeRandom(Counter)));
end; {for}
{if there are too many cards in a discard pile to display...}
TextColor (LIGHTred);
TextBackground (BLACK);
for Counter := 1 to 4 do begin
if PosTable [7+Counter]^.NumCards > 14 then
OutString ((-2 + (Counter*7)),17,'more');
if PosTable [15+Counter]^.NumCards > 14 then
OutString ((44 + (Counter*7)),17,'more');
end; {for}
end; {procedure DrawDiscards}
{___________________________________________________________________
| DrawHands
| One of the procedures involved with the interface.
| This procedure displays the hands and scorepiles.
|__________________________________________________________________}
procedure DrawHands (ComputerTurn:boolean);
var CardFace: string;
begin
if ComputerTurn = TRUE then
ColorDim
else
ColorNormalText;
GotoXY (2,19);
write ('Player''s Hand:');
if ComputerTurn = FALSE then
ColorDim
else
ColorNormalText;
if (TwoPlayer = FALSE) then begin
GotoXY (51,19);
write ('Computer''s Hand:');
end
else if (TwoPlayer = TRUE) then begin
GotoXY (51,19);
write ('Opponent''s Hand:');
end;
ColorPosition;
OutString (3,21,'A'+chr(24));
OutString (8,21,'B'+chr(24));
OutString (13,21,'C'+chr(24));
OutString (18,21,'D'+chr(24));
OutString (23,21,'E'+chr(24));
OutString (28,21,'F'+chr(24));
OutString (52,21,'T'+chr(24));
OutString (57,21,'U'+chr(24));
OutString (62,21,'V'+chr(24));
OutString (67,21,'W'+chr(24));
OutString (72,21,'X'+chr(24));
OutString (77,21,'Y'+chr(24));
If ComputerTurn = TRUE then
ColorDim
else
ColorCard;
OutString(3,20,CardString (PlayerHand.SeeRandom(1)));
OutString(8,20,CardString (PlayerHand.SeeRandom(2)));
OutString(13,20,CardString (PlayerHand.SeeRandom(3)));
OutString(18,20,CardString (PlayerHand.SeeRandom(4)));
OutString(23,20,CardString (PlayerHand.SeeRandom(5)));
OutString(28,20,CardString (PlayerHand.SeeRandom(6)));
If ComputerTurn = FALSE then
ColorDim
else
ColorCard;
If TwoPlayer then begin
OutString(52,20,CardString (ComputerHand.SeeRandom(1)));
OutString(57,20,CardString (ComputerHand.SeeRandom(2)));
OutString(62,20,CardString (ComputerHand.SeeRandom(3)));
OutString(67,20,CardString (ComputerHand.SeeRandom(4)));
OutString(72,20,CardString (ComputerHand.SeeRandom(5)));
OutString(77,20,CardString (ComputerHand.SeeRandom(6)));
end {if}
else begin
CardFace := chr(168) + chr(63);
if ComputerHand.NumCards > 0 then
OutString(52,20,CardFace);
if ComputerHand.NumCards > 1 then
OutString(57,20,CardFace);
if ComputerHand.NumCards > 2 then
OutString(62,20,CardFace);
if ComputerHand.NumCards > 3 then
OutString(67,20,CardFace);
if ComputerHand.NumCards > 4 then
OutString(72,20,CardFace);
if ComputerHand.NumCards > 5 then
OutString(77,20,CardFace);
end; {if-else}
if ComputerTurn = TRUE then
ColorDim
else
ColorNormalText;
GotoXY (2,23);
write ('Score Pile: ', PlayerScorePile.NumCards,
' cards> ');
ColorPosition;
write('G'+chr(26));
TextColor (BLACK);
TextBackground (BLACK);
write(' ');
if ComputerTurn = TRUE then
ColorDim
else
ColorCard;
write (CardString (PlayerScorePile.SeeRandom(1)));
if ComputerTurn = FALSE then
ColorDim
else
ColorNormalText;
GotoXY (51,23);
write ('Score Pile: ', ComputerScorePile.NumCards,
' cards> ');
ColorPosition;
write('Z'+chr(26));
TextColor (BLACK);
TextBackground (BLACK);
write(' ');
if ComputerTurn = FALSE then
ColorDim
else
ColorCard;
write (CardString (ComputerScorePile.SeeRandom(1)));
end; {procedure DrawHands}
{___________________________________________________________________
| DrawAcePiles
| One of the procedures involved with the interface.
| This procedure draws the AcePile portion of the screen.
|__________________________________________________________________}
procedure DrawAcePiles;
var Counter: integer;
begin
ColorNormalText;
OutString (36,5,'Ace Piles:');
ColorPosition;
OutString (38,8,'L'+chr(26));
OutString (38,9,'M'+chr(26));
OutString (38,10,'N'+chr(26));
OutString (38,11,'O'+chr(26));
ColorCard;
for Counter := 1 to 4 do begin
OutString(41,7+Counter,CardString (TopCardTable [11+Counter] ));
if CardValue( TopCardTable [11+Counter] )=0 then
if AceTopCard (11+Counter) < 10 then
OutString(45,7+Counter,chr(AceTopCard (11+Counter) + 48))
else if AceTopCard (11+Counter) = 10 then
OutString(45,7+Counter,'10')
else if AceTopCard (11+Counter) = 11 then
OutString(45,7+Counter,'JA')
else if AceTopCard (11+Counter) = 12 then
OutString(45,7+Counter,'QU')
else if AceTopCard (11+Counter) = 13 then
OutString(45,7+Counter,'KI');
end; {for}
end; {Display}
{___________________________________________________________________
| DrawMessageBox
| One of the procedures involved with the interface.
| This procedure clears the message portion of the screen and
| prints a message displaying the turn.
|__________________________________________________________________}
procedure DrawMessageBox (ComputerTurn: boolean);
var
Column: integer;
Row: integer;
begin
TextColor (BLACK);
TextBackground (BLACK);
for Column := 32 to 49 do
for Row := 14 to 23 do
OutString (Column,Row,chr(219));
ColorNormalText;
if ((ComputerTurn = TRUE) AND (TwoPlayer = FALSE)) then begin
GotoXY (33,15);
write ('Computer''s Turn');
end
else if ((ComputerTurn = TRUE) AND (TwoPlayer = TRUE)) then begin
GotoXY (33,15);
write ('Opponent''s Turn');
end
else begin
GotoXY (34,15);
write ('Player''s Turn');
end;
end; {procedure DrawMessageBox}
{___________________________________________________________________
| Display
| This procedure directs the interface procedures for a complete
| redrawing of the screen.
|__________________________________________________________________}
procedure Display;
begin
clrscr;
DrawFrame (ComputerTurn);
DrawDiscards (ComputerTurn);
DrawHands (ComputerTurn);
DrawAcePiles;
DrawMessageBox (ComputerTurn);
end; {Display}
{___________________________________________________________________
| PickUpHand
| Picks up the required number of cards from the draw pile and
| places them in the hand of the person whose turn it is.
| This procedure also checks to see if the draw pile has run out
| of cards. If so the trash pile is placed in the draw pile and
| the draw pile is subsequently reshuffled.
|___________________________________________________________________}
Procedure PickupHand (var Hand : pile);
var numToGet, count, Counter : integer;
begin
If (Hand.NumCards > 3)Then
numToGet := 1
Else
numToGet := (5 - Hand.NumCards);
For count := 1 to numToGet Do begin
If DrawPile.NumCards = 0 then begin {Draw pile out of card, replenish}
For Counter := 1 to TrashPile.NumCards do
DrawPile.PutOnTop (TrashPile.RemoveFromTop);
DrawPile.RandomShuffle;
end; {if}
Hand.PutOnTop (DrawPile.RemoveFromTop);
end; {for}
end; {procedure PickupHand}
{____________________________________________________________________
| PickUpCards
| Sends correct hand to the PickupHand procedure according to
| whose turn it is.
|___________________________________________________________________}
Procedure PickupCards;
begin
If ComputerTurn Then
PickupHand (ComputerHand)
Else
PickupHand (PlayerHand);
InitTable; {Refresh the Top Card Table}
end; {PickupCards}
{____________________________________________________________________
| HouseKeeping
| Performs some checks after a card has been moved.
| These checks include: removing completed ace piles,
| checking for completed game, and checking for
| insufficient cards to discard.
|___________________________________________________________________}
procedure HouseKeeping;
var Counter: integer;
Counter2: integer;
begin
InitTable; {Keep current top card information updated.}
{Clean up any full ace piles.}
for Counter := 12 to 15 do
if PosTable [Counter]^.NumCards = 13 then
for Counter2 := 1 to 13 do
TrashPile.PutOnTop (PosTable [Counter]^.RemoveFromTop);
{Check for Game over.}
if ComputerScorePile.NumCards = 0 then
begin
Game := FALSE;
Discard := TRUE;
Winner := 'Computer';
end; {if}
if PlayerScorePile.NumCards = 0 then
begin
Game := FALSE;
Discard := TRUE;
Winner := 'Player';
end; {if}
{Run out of cards before discard.}
If ((Discard = FALSE) AND ComputerTurn AND
(ComputerHand.NumCards = 0)) then
PickUpCards;
If ((Discard = FALSE) AND (NOT ComputerTurn) AND
(PlayerHand.NumCards = 0)) then
PickUpCards;
end; {procedure HouseKeeping}
{____________________________________________________________________
| MoveCard
| Moves a card from one pile to another as specified.
|___________________________________________________________________}
Procedure MoveCard (From, Tto : integer);
var frompile : pilepointer_t; value: CardVal_t;
dummy: integer;
begin
if ((From < 7) Or ((From > 19) AND (From < 26))) then begin
frompile :=PosTable[From];
value := TopCardTable[From];
dummy := frompile^.DeleteByValue(value);
PosTable[Tto]^.PutOnTop(value);
end
else
PosTable[Tto]^.PutOnTop (PosTable[From]^.RemoveFromTop);
HouseKeeping; {Calls the HouseKeeping procedure}
end; {procedure MoveCard}
{____________________________________________________________________
| WhoseTurn
| This procedure changes the turns.
|___________________________________________________________________}
Procedure WhoseTurn (var ComputerTurn : boolean);
begin
If ComputerTurn Then
ComputerTurn := False
Else
ComputerTurn := True;
end; {WhoseTurn}
{____________________________________________________________________
| CheckMove
| Checks to see if the move proposed is a) valid, and
| b) a discard.
|___________________________________________________________________}
Procedure CheckMove(var From, Tto: integer);
var
TopCard: integer;
position: Pos_t;
Counter: Pos_t;
EmptyAcePile: boolean;
begin
InitTable;
Valid := TRUE;
Discard := FALSE;
MustMove := FALSE;
If TopCardTable [From] = NULL then
Valid := FALSE; {Invalid if moving from empty space.}
If (Valid AND ((Tto < 8) OR (Tto > 19))) then
Valid := FALSE;{Invalid if proposed to move card to ScorePiles or Hands}
If (Valid AND ComputerTurn AND ((Tto < 12) OR (From < 12))) then
Valid := FALSE; {Invalid if computer proposed to or from player's side.}
If (VALID AND (NOT ComputerTurn) AND ((Tto > 15) OR (From > 15))) then
Valid := FALSE; {Invalid if player proposed to or from computer's side.}
If (VALID AND ((From > 11) AND (From < 16))) then
Valid := FALSE; {Invalid if to Acepile from Acepile.}
if (VALID AND (((Tto > 7) AND (Tto < 12)) OR ((Tto > 15) AND (Tto < 20)))
AND (((From < 12) AND (From > 6)) OR ((From = 26) OR
((From > 15) AND (From < 20))))) then
Valid := FALSE; {Invalid if to discard from a discard or score pile.}
{Ace on top of Discard Pile must be played first.}
EmptyAcePile := FALSE;
for Counter := 1 to 4 do
if PosTable [Counter + 11]^.NumCards = 0 then
EmptyAcePile := TRUE;
if (EmptyAcePile AND Valid) then
for Counter := 1 to 4 do begin
if ((ComputerTurn) AND (CardValue (TopCardTable [Counter + 15]) = 1)
AND (From <> (Counter + 15))
AND (NOT(CardValue(TopCardTable[From])=1))) then
Valid := FALSE;
if ((NOT ComputerTurn) AND (CardValue (TopCardTable[Counter+7]) = 1)
AND (From <> (Counter + 7))
AND (NOT(CardValue(TopCardTable[From])=1))) then
Valid := FALSE;
end; {for}
if (EmptyAcePile AND Valid) then
for Counter := 1 to 4 do begin
if ((ComputerTurn) AND (CardValue (TopCardTable [Counter + 15]) = 1)
AND (From = (Counter + 15))
OR (CardValue(TopCardTable[From])=1)) then begin
Valid := True;
MustMove := True;
end; {if}
end; {for} {forces computer to play ace when
To/From scores below threshold}
{Ace Piles Check}
if (VALID AND ((Tto > 11) AND (Tto < 16))) then begin
TopCard := AceTopCard (Tto);
If ((TopCard = NULL) AND (CardValue (TopCardTable [From]) <> 1)) then
Valid := FALSE {If placing non-ace on empty ace pile.}
else if TopCard = NULL then
Valid := TRUE
else if CardValue(TopCardTable[From]) = 0 then
Valid := TRUE {In all cases but as ace, joker is valid.}
else if ((TopCard + 1) <> CardValue (TopCardTable[From])) then
Valid := FALSE; {If it is not next card in series.}
end; {if}
{Discard Check}
if (Valid AND ((ComputerTurn AND ((Tto < 20) AND (Tto > 15) AND (From > 19)
AND (From < 26))) OR (NOT ComputerTurn AND ((Tto < 12) AND (Tto > 7)
AND (From < 7) AND (From > 0))))) then
if PosTable [Tto]^.NumCards > 0 then begin
Discard := TRUE;
if ComputerTurn then
For Counter := 16 to 19 do
if PosTable [Counter]^.NumCards = 0 then begin
Valid := FALSE;
Discard := FALSE;
end; {if}
if NOT ComputerTurn then
For Counter := 8 to 11 do
if PosTable [Counter]^.NumCards = 0 then begin
Valid := FALSE;
Discard := FALSE;
end; {if}
end; {if}
end;{CheckMove}
{____________________________________________________________________
| GetMove
| Requested a proposal for a move from the player.
|___________________________________________________________________}
Procedure GetMove (var From, Tto: integer);
var FromChar, ToChar: char;
begin
Display;
ColorNormalText;
OutString (33,17,'Enter positions');
ColorDim;
OutString (35,18,'(@ to Quit)');
ColorNormalText;
OutString (33,19,'Move a card');
OutString (33,20,'from: ');
readln (FromChar);
OutString (33,21,'to: ');
readln (ToChar);
From := ord(UpCase(FromChar)) - 64;
Tto := ord(UpCase(ToChar)) - 64;
{-64 to adjust for alphabet's position in ASCII table.}
if ((From = 0) OR (Tto = 0)) then begin {quit}
ColorNormalText;
clrscr;
HALT;
end; {if}
if ((From < 1) OR (From > 26) OR (Tto < 1) OR (From > 26)) then begin
From := 1;
Tto := 1;
end; {if}
end; {GetMove}
{____________________________________________________________________
| ResultsofCheck
| Displays a message regarding the results of the check in
| CheckMove.
|___________________________________________________________________}
procedure ResultsofCheck;
begin
DrawMessageBox (ComputerTurn); {Calls the DrawMessageBox procedure}
ColorNormalText;
OutString (33,17,'Proposed Move:');
GotoXY (33,18);
write ('From: ',chr(From + 64));
GotoXY (33,19);
write ('To: ',chr(Tto + 64));
GotoXY (33,21);
if NOT Valid then begin
TextColor (WHITE+BLINK);
write ('Is NOT Valid!!');
end
else begin
TextColor (WHITE);
write ('Is Valid.');
end; {if else}
TextColor (RED+BLINK);
OutString (33,23,'Press ...');
readln;
end; {ResultsofCheck}
{_____________________________________________________________________
| PlayAgainBox
| Displays Box and asks player if he/she wants to play again
|_____________________________________________________________________}
procedure PlayAgainBox;
Begin
ColorNormalText;
clrscr;
DrawTitleBox;
ColorNormalText;
OutString (27, 11, 'Would you like to play again?');
OutString (37, 12, '(');
TextColor (LightRed);
OutString (38, 12, 'Y ');
TextColor (white);
OutString (40, 12, 'or ');
TextColor (lightRed);
OutString (43, 12, 'N');
TextColor (white);
OutString (44, 12, ')');
End;
{____________________________________________________________________
| GameOverDisplay
| Notifies player that the game is over, displays who won, and
| asks the player if he/she would like to play again.
|___________________________________________________________________}
Procedure GameOverDisplay (Winner: string);
var Response: char;
Valid: boolean;
begin
ColorNormalText;
clrscr;
DrawTitleBox;
ColorNormalText;
OutString (36, 10, 'Game Over!!');
OutString (32, 12, 'The ');
OutString (36, 12, Winner);
OutString (44, 12, ' wins!');
readln;
{Play Again?}
Valid := FALSE;
Repeat
PlayAgainBox;
readln (Response);
if (Upcase (Response) = 'Y') then begin
AnotherGame := TRUE;
Valid := TRUE;
end
else
if (Upcase (Response) = 'N') then begin
AnotherGame := FALSE;
Valid := TRUE;
end
else
Valid := FALSE;
Until Valid;
end; {function AnotherGame}
{___________________________________________________________________
| SetUp
| One of Decision's evaluative functions.
| This function adds a negative weight if a play will result in
| setting up the player to play from his/her score pile.
|__________________________________________________________________}
Function SetUp: integer;
const
WEIGHT = -20;
SWEIGHT =-10;
var
position: integer;
Points: integer;
CardCanPlay: integer;
ScoreCard: integer;
CardPlayed: integer;
begin
Points := 0;
ScoreCard := CardValue (TopCardTable [7]);
CardPlayed := AceTopCard (Tto) + 1;
CardCanPlay := CardPlayed + 1;
If CardCanPlay = ScoreCard then begin
Points := WEIGHT;
For position := 16 to 26 do begin
if CardValue (TopCardTable [position]) = ScoreCard then
Points := 0;
if position = From then
if CardValue (PosTable [position]^.SeeRandom(2)) = ScoreCard then
Points := 0;
end; {for}
end; {if}
If (Points = WEIGHT) AND (From = 26) then
Points := SWEIGHT;
SetUp := Points;
end; {function SetUp}
{___________________________________________________________________
| Block
| One of Decision's evaluative functions.
| This function adds a positive weight if the play results in
| preventing the player from playing from his score pile.
|__________________________________________________________________}
function Block: integer;
const
WEIGHT = 25;
var
Points: integer;
ScoreCard: integer;
CardPlayed: integer;
begin
Points := 0;
ScoreCard := CardValue (TopCardTable [7]);
CardPlayed := AceTopCard (Tto) + 1;
If CardPlayed = ScoreCard then
Points := WEIGHT;
Block := points;
end; {Block}
{___________________________________________________________________
| PlayMore
| One of Decision's evaluative functions.
| This function adds a positive weight if a play results in the
| computer being able to play more cards.
| It also adds a positive weight if a play allows the computer to
| move a card.
|___________________________________________________________________}
function PlayMore: integer;
const
WEIGHT = 15; {If move allows the computer to move more cards.}
WEIGHT2 = 10; {If Computer can move a card.}
var
position: integer;
Points: integer;
CardCanPlay: integer;
CardPlayed: integer;
begin
Points := WEIGHT2; {Just for being able to play a card.}
CardPlayed := AceTopCard (Tto) + 1;
CardCanPlay := CardPlayed + 1;
position := 16;
While (Position < 27) do begin
if CardValue (TopCardTable [position]) = CardCanPlay then
Points := WEIGHT;
if position = From then
if CardValue(PosTable [position]^.SeeRandom (2)) = CardCanPlay then
Points := WEIGHT;
position := position + 1;
end; {While}
{Special case for Jokers}
If CardValue (TopCardTable [From]) = 0 then
Points := Points - WEIGHT;
PlayMore := Points;
end; {function PlayMore}
{____________________________________________________________________
| MoreCards
| One of Decision's evaluative functions
| This function adds weight to a play that will result in the
| computer being able to pick up more cards at the beginning of
| its next turn. Additional weight is given to a play that will
| result in the computer being able to pick up 5 more cards this
| turn.
|____________________________________________________________________}
function MoreCards: integer;
const WEIGHT = 10;
WEIGHT2 = 20;
var HolestoFill: integer;
Counter: integer;
Points: integer;
begin
Points := 0;
{creates empty discard pile, ie a hole to fill}
If ((From >15) AND (From <20) AND (PosTable [From]^.NumCards = 1) AND
(NOT CardValue(TopCardTable [From]) = 0)) then
Points := WEIGHT;
{takes into account the holes}
HolestoFill := 0;
If ((From > 19) AND (From < 26 )) then begin
Points := WEIGHT;
For Counter := 16 to 19 do begin
If PosTable [Counter]^.NumCards = 0 then
HolestoFill := HolestoFill + 1;
end; {for}
If (ComputerHand.NumCards - HolestoFill) = 0 then
Points := WEIGHT2;
{special case for Jokers}
If CardValue (TopCardTable [From]) = 0 then
Points := Points - WEIGHT;
end; {if}
MoreCards := Points;
end; {MoreCards}
{_____________________________________________________________________
| HelpScore
| One of Decision's evaluative functions
| This function will add positive weight to a play that results
| in the computer being able to play from its score pile.
|____________________________________________________________________}
function HelpScore: integer;
const WEIGHT = 30;
var ScoreCard: integer;
CardPlayed: integer;
CardCanPlay: integer;
Points: integer;
begin
Points := 0;
ScoreCard := CardValue (TopCardTable [26]);
CardPlayed := AceTopCard (Tto) + 1;
CardCanPlay := CardPlayed + 1;
If CardCanPlay = ScoreCard then
Points := WEIGHT;
HelpScore := Points;
end; {function HelpScore}
{_____________________________________________________________________
| Score
| One of Decision's evaluative functions.
| This function adds positive weight to a score pile play.
|____________________________________________________________________}
function Score: integer;
const WEIGHT = 60;
WEIGHT2 = 10;
var ScoreCard: integer;
position: integer;
Points: integer;
Begin
Points := 0;
if From = 26 then begin
ScoreCard := CardValue (TopCardTable [26]);
if (((AceTopCard (Tto) + 1) = ScoreCard) OR (ScoreCard = 0)) then begin
Points := WEIGHT;
if ((ScoreCard + 1) = CardValue (TopCardTable [7])) then begin
Points := WEIGHT2;
position := 16;
while (position < 26) do begin
position := position + 1;
if ((TopCardTable [position] = 0) OR
(TopCardTable [position] = (ScoreCard +1))) then
Points := WEIGHT;
end; {While}
end; {if}
end; {if}
end; {if}
Score := Points;
end; {function Score}
{_____________________________________________________________________
| SameScore
| One of DiscardDecision's evaluative functions
| This function adds a negative weight to a discard
| of a card that is the same value as the computer's score
| pile.
|____________________________________________________________________}
function SameScore: integer;
const WEIGHT = -5;
JWEIGHT = -20;
var Points: integer;
begin
Points := 0;
If (CardValue(TopCardTable[From]) = CardValue (TopCardTable[26])) then
Points := WEIGHT;
{special case for Jokers}
If CardValue (TopCardTable[From]) = 0 then
Points := JWEIGHT;
SameScore := Points;
end; {function SameScore}
{_____________________________________________________________________
| Order
| One of DecisionDiscard's evaluative functions
| This function uses weights to prioritize a discard to the closest
| possible lower value in relation to the top cards of the discard
| piles.
|____________________________________________________________________}
function Order: integer;
const WEIGHT1 = 20;
WEIGHT2 = 11;
WEIGHT3 = 4;
WEIGHT4 = -5;
JWEIGHT = -20;
var next: CardVal_t;
Points: integer;
begin
next := CardValue (TopCardTable [Tto]) - 1;
if (CardValue (TopCardTable [From]) = next)
then Points := WEIGHT1;
if ((CardValue (TopCardTable [From]) + 1) = next)
then Points := WEIGHT2;
if ((CardValue (TopCardTable[From]) + 1) < next)
then Points := WEIGHT3;
if (CardValue (TopCardTable [From]) > next)
then Points := WEIGHT4;
{special case for Jokers}
if CardValue (TopCardTable [From]) = 0 then
Points := JWEIGHT;
Order := Points;
end; {Order}
{_____________________________________________________________________
| HighCard
| One of DecisionDiscard's evaluative functions.
| This function weights the possible cards to fill in a space
| in the discard piles. It adds most weight to the highest
| valued card.
|____________________________________________________________________}
function HighCard: integer;
var count, Points: integer;
begin
Points := 0;
if ((PosTable [16]^.NumCards = 0) OR (PosTable [17]^.NumCards = 0) OR
(PosTable [18]^.NumCards = 0) OR (PosTable [19]^.NumCards = 0)) then
for count := 20 to 25 do
if (CardValue(TopCardTable [From]) >
CardValue (TopCardTable [count])) then
Points := Points + 1;
HighCard := Points * 2;
end; {function HighCard}
{_____________________________________________________________________
| DiscardDecision
| This procedure is responsible for applying the various weights
| on to the decision surrounding the computer's discard.
|____________________________________________________________________}
Procedure DiscardDecision (var From, Tto: integer);
var max: integer;
f, t: integer;
Begin
For f := 20 to 25 Do
For t := 16 to 19 Do begin
From := f;
Tto := t;
CheckMove (From, Tto);
If Not (Valid) Then
ChoiceRate[f, t] := -10000
Else
ChoiceRate[f, t] := ((HighCard) + (Order) + (SameScore));
end; {for}
From := 20;
Tto := 16;
max := 0;
For f := 20 to 25 Do
For t := 16 to 19 Do begin
If (ChoiceRate[f, t] > ChoiceRate[From, Tto]) Then begin
max := ChoiceRate[f, t];
From := f;
Tto := t;
end; {if}
end; {for}
End; {DiscardDecision}
{_____________________________________________________________________
| Decision
| This procedure is responsible for applying the weights to the
| decision surrounding the computer's choice of moves.
|____________________________________________________________________}
Procedure Decision (var From, Tto: integer);
const Threshold = 10;
var Max: integer;
f, t: integer;
Begin
Display;
For f := 1 to 26 do
For t := 1 to 19 do
ChoiceRate [f, t] := 0;
For f := 16 to 26 Do
For t := 12 to 15 Do begin
From := f;
Tto := t;
CheckMove(From, Tto);
If Not (Valid) Then
ChoiceRate[f, t] := -10000
Else
ChoiceRate[f, t] := ((SetUp) + (Block) +
(PlayMore) + (MoreCards) + (HelpScore) + (Score));
end; {for}
{Tests Threshold}
From := 16;
Tto := 12;
max := 0;
For f := 16 to 26 Do
For t := 12 to 15 Do begin
If (ChoiceRate[f, t] > ChoiceRate[From, Tto]) Then begin
max := ChoiceRate[f, t];
From := f;
Tto := t;
end; {if}
end; {for}
If (Max < Threshold) AND (NOT(MustMove)) Then
DiscardDecision (From, Tto);
End; {Decision}
{============================================================================
MAIN PROGRAM
============================================================================}
BEGIN {Main Program}
Repeat
TitleScreen (TwoPlayer);
Initialize;
Deal;
While (Game) Do begin
WhoseTurn (ComputerTurn);
PickupCards;
Repeat
If ((ComputerTurn) AND (NOT TwoPlayer)) Then
Decision (From, Tto)
Else
GetMove (From, Tto);
CheckMove(From, Tto);
ResultsofCheck;
If Valid then
MoveCard (From, Tto);
Until (Discard);
End; {While Loop}
GameOverDisplay (Winner);
Until (NOT AnotherGame);
END. {Main Program}