home *** CD-ROM | disk | FTP | other *** search
/ Encyclopedia of Games / eog_disc2.iso / encyclop / wingames / cardws12 / klondike.cdl < prev    next >
Text File  |  1993-09-21  |  9KB  |  402 lines
  1. //⌐ David Jean, 1993
  2. game klondike is 29 by 20;
  3.  
  4. //   D1 D2    A1 A2 A3 A4
  5. //   B1 B2 B3 B4 B5 B6 B7
  6.  
  7. {--------------------------------------------------------------------------}
  8.  
  9. {****c1 et c2 sont de meme sorte}
  10. predicate SameSuite?(c1, c2 : Card) is
  11.   return (c1 / 13) = (c2 / 13);
  12.  
  13. {****c2 est un de plus que c1}  
  14. predicate FollowSuiteWrap?(c1, c2 : Card) is
  15.   return ((c1 + 1) mod 13) = (c2 mod 13);
  16.  
  17. {****c1 et c2 sont de couleurs diffente}
  18. predicate AlternateColor?(c1, c2 : Card) is
  19.   return (((c1 / 13) + (c2 / 13)) mod 2) = 1;
  20.  
  21. {****c1 et c2 sont du meme Rang}
  22. predicate SameRank?(c1, c2 : Card) is
  23.   return (c1 mod 13) = (c2 mod 13);
  24.  
  25. {****c1 et c2 ont la meme face}
  26. predicate SameCard?(c1, c2 : Card) is
  27.   return (c1 mod DeckSize) = (c2 mod DeckSize);
  28.  
  29. {****verifie si c1 est un roi}
  30. predicate IsKing?(c1 : card) is
  31.   return (c1 mod 13)=King;
  32.  
  33. function min(a, b : integer): integer is
  34.   if a<b then return a else return b;
  35.  
  36. predicate IsSideDown?(c1 : card) is 
  37.   return (c1 / DeckSize)=down;
  38.  
  39. {--------------------------------------------------------------------------}
  40.  
  41. procedure About is
  42. begin
  43.   Clear 'About Klondike';
  44.   write('Rules from : RΘglements officiels des jeux de cartes, Intl. playing card company limited, 1977.\n');
  45.   write('Program : ⌐ David Jean, 1993.\n');
  46. end;
  47.  
  48. procedure RButton is
  49. begin
  50.   Clear 'Right Mouse Button';
  51.   Write('If you click here with the right button, the card will automatically ');
  52.   Write('go to the most appropriate place, looking for a spot in The Foundation first ');
  53.   Write('and then to the Tableau.\n');
  54.   Write('If the card can\'t be played nothing will happen.\n');
  55.   Wait 'About...' About;
  56. end;
  57.  
  58. var f : integer;
  59.  
  60. stack D2;
  61. stack A1;
  62. stack A2;
  63. stack A3;
  64. stack A4;
  65. stack B1;
  66. stack B2;
  67. stack B3;
  68. stack B4;
  69. stack B5;
  70. stack B6;
  71. stack B7;
  72.  
  73. stack D1 is
  74.   X := 2;
  75.   Y := 2;
  76.   Direction := over;
  77.   W := 3;
  78.   H := 4;
  79.   //****************************
  80.   Start is
  81.     begin
  82.     Add Ace+Spade .. King+Diamond;
  83.     Turn [1..52] side down;
  84.     Shuffle;
  85.     end;
  86.   //****************************
  87.   SelectLeftFrom(Spos : Index) is
  88.   var i : integer;
  89.     begin
  90.     i:=Min(!,3);
  91.     if i=0 then
  92.       begin
  93.       Pull D2! From D2;
  94.       Turn [1..!] Side Down;
  95.       Inverse [1..!];
  96.       [0]:=EmptyCard;
  97.       f:=1;
  98.       end
  99.     else
  100.       begin
  101.       Turn [!-i+1..!] Side Up;
  102.       Inverse [!-i+1..!];
  103.       Pull 3 To D2;
  104.       if (!=0) and (f=1) then [0]:=CrossCard;
  105.       end;
  106.     end;
  107.   //****************************
  108.   Help is
  109.     begin
  110.     Clear 'The Stock';
  111.     Write('You can click here to move three cards to The Waste Pile or ');
  112.     Write('to turn The Waste Pile over when The Stock is empty.\n');
  113.     Wait 'About...' About;
  114.     end;
  115. end D1;
  116.  
  117. stack D2 is
  118.   X := 6;
  119.   Y := 2;
  120.   Direction := over;
  121.   W := 3;
  122.   H := 4;
  123.   //****************************
  124.   Start is f:=1;
  125.   //****************************
  126.   SelectLeftFrom(Spos : Index) is
  127.     begin
  128.     if !<>0 then
  129.       begin
  130.       f:=2;
  131.       Pull 1 To Cursor;
  132.       end;
  133.     end;
  134.   //****************************
  135.   SelectRightFrom(Spos : Index) is
  136.     begin
  137.     with it do
  138.       if !<>0 then
  139.         if ((it!=0) and SameCard?([!],it[0])) or
  140.            (SameSuite?(it[it!],[!]) and FollowSuiteWrap?(it[it!],[!])) then
  141.           begin
  142.           Pull 1 To it;
  143.           f:=2;
  144.           break procedure;
  145.           end
  146.     for A1, A2, A3, A4;
  147.     with it do
  148.       if !<>0 then
  149.         if ((it!=0) and IsKing?([!])) or 
  150.            (AlternateColor?(it[it!],[!]) and
  151.             FollowSuiteWrap?([!],it[it!])) then
  152.           begin
  153.           Pull 1 To it;
  154.           f:=2;
  155.           break procedure;
  156.           end
  157.     for B1, B2, B3, B4, B5, B6, B7;
  158.     end;
  159.   //****************************
  160.   Help is
  161.     begin
  162.     Clear 'The Waste Pile';
  163.     Write('The topmost card of this pile is available to play on The Tableau or The Foundation.\n\n');
  164.     Write('You can Drag cards from here by using the left mouse button.\n');
  165.     Wait 'Right Button...' RButton;
  166.     Wait 'About...' About;
  167.     end;
  168. end D2;
  169.  
  170. {--------------------------------------------------------------------------}
  171.  
  172. stack A1 is
  173.   X := 14;
  174.   Y := 2;
  175.   Direction := over;
  176.   W := 3;
  177.   H := 4;
  178.   //****************************
  179.   Start is
  180.     begin
  181.     [0]:=Ace+Spade;
  182.     Turn [0] Side Shaded;
  183.     end;
  184.   //****************************
  185.   SelectLeftTo(Spos : Index) is
  186.     begin
  187.     if Cursor!=1 then
  188.       if (!=0) and SameCard?([0],Cursor[1]) then
  189.         Pull 1 From Cursor
  190.       else if SameSuite?(Cursor[1],[!]) and
  191.               FollowSuiteWrap?([!],Cursor[1]) then
  192.         Pull 1 From Cursor;
  193.     end;
  194.   //****************************
  195.   Help is
  196.     begin
  197.     Clear 'Foundations';
  198.     Write('Plays are made to the Foundations in the same suit and in ascending order.\n\n');
  199.     Write('The goal is to move all 52 cards here.\n\n');
  200.     Write('At the start, this stack is grayed to indicate which card must be played here first.\n');
  201.     Wait 'About...' About;
  202.     end;
  203. end A1;
  204.  
  205. stack A2 from A1 is
  206.   X := 18;
  207.   Y := 2;
  208.   //****************************
  209.   Start is
  210.     begin
  211.     [0]:=Ace+Heart;
  212.     Turn [0] Side Shaded;
  213.     end;
  214. end A2;
  215.  
  216. stack A3 from A1 is
  217.   X := 22;
  218.   Y := 2;
  219.   //****************************
  220.   Start is
  221.     begin
  222.     [0]:=Ace+Club;
  223.     Turn [0] Side Shaded;
  224.     end;
  225. end A3;
  226.  
  227. stack A4 from A1 is
  228.   X := 26;
  229.   Y := 2;
  230.   //****************************
  231.   Start is
  232.     begin
  233.     [0]:=Ace+Diamond;
  234.     Turn [0] Side Shaded;
  235.     end;
  236. end A4;
  237.  
  238. {--------------------------------------------------------------------------}
  239.  
  240. stack B1 is
  241.   X := 2;
  242.   Y := 7;
  243.   Direction := down;
  244.   W := 3;
  245.   H := 13;
  246.   //****************************
  247.   Start is
  248.   begin
  249.     Pull 1 From D1;
  250.     Turn [1] Side Up;
  251.     Draw D1;
  252.   end;
  253.   //****************************
  254.   SelectLeftFrom(Spos : Index) is
  255.   begin
  256.     if SPos>! then SPos:=!;
  257.     if IsSideDown?([Spos]) then break procedure;
  258.     Pull !-Spos+1 To Cursor;
  259.   end;
  260.   //****************************
  261.   SelectLeftTo(Spos : Index) is
  262.   begin
  263.     if (!=0) and IsKing?(Cursor[1]) then
  264.       Pull Cursor! From Cursor
  265.     else if AlternateColor?(Cursor[1],[!]) and
  266.             FollowSuiteWrap?(Cursor[1],[!]) then
  267.       Pull Cursor! From Cursor;
  268.   end;
  269.   //****************************
  270.   SelectRightFrom(Spos : Index) is
  271.   begin
  272.     if SPos>! then SPos:=!;
  273.  
  274.     if IsSideDown?([Spos]) then break procedure;
  275.  
  276.     if Spos=! then
  277.       with it do
  278.         if !<>0 then
  279.           if ((it!=0) and SameCard?([!],it[0])) or
  280.              (SameSuite?(it[it!],[!]) and FollowSuiteWrap?(it[it!],[!])) then
  281.             begin
  282.             Pull 1 To it;
  283.             break procedure;
  284.             end
  285.       for A1, A2, A3, A4;
  286.  
  287.     with it do
  288.       if !<>0 then
  289.         if ((it!=0) and IsKing?([Spos])) or 
  290.            (AlternateColor?(it[it!],[Spos]) and
  291.             FollowSuiteWrap?([Spos],it[it!])) then
  292.           begin
  293.           Pull !-Spos+1 To it;
  294.           break procedure;
  295.           end
  296.     for B1, B2, B3, B4, B5, B6, B7;
  297.   end;
  298.   //****************************
  299.   Help is
  300.     begin
  301.     Clear 'The Tableau';
  302.     Write('Each card played here must be in descending sequence and of alternating color ');
  303.     Write('to the card on which it is played.\n\n');
  304.     Write('The bottommost card can be played to The Foundation.\n\n');  
  305.     Write('You can pick any sequence of cards, ending with the bottommost card, ');
  306.     Write('to move to another pile in The Tableau.\n\n'); 
  307.     Write('Only Kings can be moved in an empty spot on The Tableau.\n');
  308.     Wait 'Right Button...' RButton;
  309.     Wait 'About...' About;
  310.     end;
  311. end B1;
  312.  
  313.  
  314. stack B2 from B1 is
  315.   X := 6;
  316.   Y := 7;
  317.   //****************************
  318.   Start is
  319.   begin
  320.     Pull 2 From D1;
  321.     Turn [2] Side Up;
  322.     Draw D1;
  323.   end;
  324. end B2;
  325.  
  326. stack B3 from B1 is
  327.   X := 10;
  328.   Y := 7;
  329.   //****************************
  330.   Start is
  331.   begin
  332.     Pull 3 From D1;
  333.     Turn [3] Side Up;
  334.     Draw D1;
  335.   end;
  336. end B3;
  337.  
  338. stack B4 from B1 is
  339.   X := 14;
  340.   Y := 7;
  341.   //****************************
  342.   Start is
  343.   begin
  344.     Pull 4 From D1;
  345.     Turn [4] Side Up;
  346.     Draw D1;
  347.   end;
  348. end B4;
  349.  
  350. stack B5 from B1 is
  351.   X := 18;
  352.   Y := 7;
  353.   //****************************
  354.   Start is
  355.   begin
  356.     Pull 5 From D1;
  357.     Turn [5] Side Up;
  358.     Draw D1;
  359.   end;
  360. end B5;
  361.  
  362. stack B6 from B1 is
  363.   X := 22;
  364.   Y := 7;
  365.   //****************************
  366.   Start is
  367.   begin
  368.     Pull 6 From D1;
  369.     Turn [6] Side Up;
  370.     Draw D1;
  371.   end;
  372. end B6;
  373.  
  374. stack B7 from B1 is
  375.   X := 26;
  376.   Y := 7;
  377.   //****************************
  378.   Start is
  379.   begin
  380.     Pull 7 From D1;
  381.     Turn [7] Side Up;
  382.     Draw D1;
  383.   end;
  384. end B7;
  385.  
  386. {--------------------------------------------------------------------------}
  387.  
  388. predicate Win? is return (A1!=13) and (A2!=13) and (A3!=13) and (A4!=13);
  389. predicate Loose? is return FALSE;
  390.  
  391.  
  392. predicate Integrity? is
  393. begin
  394.   with it do
  395.     if (it!>0) and IsSideDown?(it[it!]) then Turn it[it!] Side Up
  396.   for B1, B2, B3, B4, B5, B6, B7;
  397.  
  398.   return TRUE;
  399. end;
  400.  
  401. order D1, D2, A1, A2, A3, A4, B1, B2, B3, B4, B5, B6, B7.
  402.