home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Top Ten Mega Games 2
/
TOP_TEN_Mega_Games_2.iso
/
WIN31
/
CARDWS12
/
PYRAMID.CDL
< prev
next >
Wrap
Text File
|
1993-11-27
|
6KB
|
315 lines
//⌐ David Jean, 1993
game pyramid is 29 by 17;
//A1 D1 D2
//A2
//A3
//A4
//A5
//A6
//A7
{--------------------------------------------------------------------------}
procedure About is
begin
Clear 'About Pyramid';
write('Rules from : The Complete book of Solitaire & Patience Games by \n');
write('Albert H. Morehead & Geoffrey Mott-Smith, Bantam Book, 1977.\n');
write('Program : ⌐ David Jean, 1993.\n');
end;
stack A1;
stack A2;
stack A3;
stack A4;
stack A5;
stack A6;
stack A7;
stack D2;
function NextStack(fs : stack): stack is
var ls : stack;
begin
ls:=Cursor;
with it do
if ls=fs then
return it
else
ls:=it
for A1, A2, A3, A4, A5, A6, A7;
return fs;
end;
{--------------------------------------------------------------------------}
stack D1 is
X := 21;
Y := 3;
Direction := over;
w := 3;
h := 3;
//****************************
Start is
begin
Add Ace+Spade .. King+Diamond;
Shuffle;
[0]:=CrossCard;
end;
//****************************
SelectLeft(Spos : Index) is
if !>0 then
if ([!] / DeckSize)=Shaded then
Turn [!] side up
else
Turn [!] Side Shaded;
//****************************
SelectRight(Spos : Index) is
if !>0 then
begin
if D2!>0 then Turn D2[D2!] side up;
Turn [!] side up;
Pull 1 to D2;
end;
//****************************
Help is
begin
Clear 'The Stock';
Write('The topmost card of this pile is available to match on The Tableau.\n\n');
Write('You can click here with the right button to move a card to The Waste Pile.\n');
Wait 'About...' About;
end;
end D1;
stack D2 is
X := 25;
Y := 3;
Direction := over;
w := 3;
h := 3;
//****************************
SelectLeft From D1;
//****************************
Help is
begin
Clear 'The Waste Pile';
Write('The topmost card of this pile is available to match on The Tableau.\n\n');
Wait 'About...' About;
end;
end D2;
{--------------------------------------------------------------------------}
stack A1 is
X := 14;
Y := 2;
Direction := horizontal;
W := 3;
H := 3;
//****************************
Start is
begin
[0]:=EmptySpace;
Pull 1 from D1;
Draw D1;
end;
//****************************
SelectLeft(Spos : Index) is
var nx : stack;
begin
if Spos>! then Spos:=!;
nx:=NextStack(self);
if (nx=self) or
((nx[Spos]=EmptySpace) and (nx[Spos + 1]=EmptySpace)) then
if [Spos]<>EmptySpace then
if ([Spos] / DeckSize)=Shaded then
Turn [Spos] side up
else
Turn [Spos] Side Shaded;
end;
//****************************
Help is
begin
Clear 'The Tableau';
Write('From the available cards, discard pairs of card that total 13.\n');
Write('Kings are discarded alone.\n');
Write('Suit is not important.\n\n');
Write('Available cards are those not covered by others.\n\n');
Write('The goal is to empty the Tableau, The Stock and The Waste Pile.\n');
Wait 'About...' About;
end;
end A1;
stack A2 from A1 is
X := 12;
Y := 4;
W := 7;
//****************************
Start is
begin
[0]:=EmptySpace;
Pull 2 from D1;
Draw D1;
end;
end A2;
stack A3 from A1 is
X := 10;
Y := 6;
W := 11;
//****************************
Start is
begin
[0]:=EmptySpace;
Pull 3 from D1;
Draw D1;
end;
end A3;
stack A4 from A1 is
X := 8;
Y := 8;
W := 15;
//****************************
Start is
begin
[0]:=EmptySpace;
Pull 4 from D1;
Draw D1;
end;
end A4;
stack A5 from A1 is
X := 6;
Y := 10;
W := 19;
//****************************
Start is
begin
[0]:=EmptySpace;
Pull 5 from D1;
Draw D1;
end;
end A5;
stack A6 from A1 is
X := 4;
Y := 12;
W := 23;
//****************************
Start is
begin
[0]:=EmptySpace;
Pull 6 from D1;
Draw D1;
end;
end A6;
stack A7 from A1 is
X := 2;
Y := 14;
W := 27;
//****************************
Start is
begin
[0]:=EmptySpace;
Pull 7 from D1;
Draw D1;
end;
end A7;
{--------------------------------------------------------------------------}
predicate win? is
return (A1[1]=EmptySpace) and (D1!=0) and (D2!=0);
const
ctotal := 1, cremove := 2, ccancel := 3;
var
total, scard : integer;
procedure CheckStack(mode : integer) is
var i : integer;
begin
total:=0;
scard:=0;
with it do
begin
i:=1;
while i<=it! do
begin
if (it[i] / DeckSize)=Shaded then
begin
scard:=scard+1;
if mode=ctotal then total:=total+(it[i] mod 13)+1
else if mode=cremove then it[i]:=EmptySpace
else Turn it[i] side up;
end;
i:=i+1;
end;
end
for A1, A2, A3, A4, A5, A6, A7;
with it do
if (it[it!] / DeckSize)=Shaded then
begin
scard:=scard+1;
if mode=ctotal then total:=total+(it[it!] mod 13)+1
else if mode=cremove then remove it[it!]
else Turn it[it!] side up;
end
for D1, D2;
end;
predicate Integrity? is
begin
CheckStack(ctotal);
if total=13 then CheckStack(cremove)
else if scard>=2 then CheckStack(ccancel);
return TRUE;
end;
function BitAvail : integer is
var r, i : integer;
nx : stack;
begin
r:=0;
with it do
if it!>0 then r:=r or (1 << (it[it!] mod 13))
for D1, D2;
with it do
begin
i:=1;
nx:=NextStack(it);
while i<=it! do
begin
if (it=nx) or
((nx[i]=EmptySpace) and (nx[i + 1]=EmptySpace)) then
if it[i]<>EmptySpace then
r:=r or (1 << (it[i] mod 13));
i:=i+1;
end;
end
for A1, A2, A3, A4, A5, A6, A7;
return r;
end;
predicate Loose? is
var r, i : integer;
begin
if D1!>0 then return FALSE;
r:=BitAvail;
i:=0;
while i<6 do
begin
if ((r and (1 << i))>0) and ((r and (1 << (11-i)))>0) then
return FALSE;
i:=i+1;
end;
if (r and (1 << 12))>0 then return FALSE;
return TRUE;
end;
order D1, D2, A1, A2, A3, A4, A5, A6, A7.