Encyclopedia of Games/eog_disc2.iso/encyclop/wingames/cardws12/pyramid.cdl

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.