home *** CD-ROM | disk | FTP | other *** search
/ Simtel MSDOS - Coast to Coast / simteldosarchivecoasttocoast.iso / pcmag / vol9n04.zip / POKERSOL.PAS < prev    next >
Pascal/Delphi Source File  |  1989-10-22  |  7KB  |  220 lines
  1. PROGRAM PokerSolitaire;
  2. USES crt, cards;
  3.  
  4. TYPE
  5.   PokerHand = (nothing, OnePair, TwoPair, ThreeOfAKind,
  6.                straight, flush, FullHouse, FourOfAKind,
  7.                StraightFlush, RoyalFlush);
  8.   PokerSol = OBJECT (game)
  9.     topcard     : LCardP;
  10.     places      : array[0..24] of LCardP;
  11.     cur, played : Byte;
  12.     CONSTRUCTOR Init;
  13.     DESTRUCTOR Done; virtual;
  14.     PROCEDURE display; virtual;
  15.     PROCEDURE Play;
  16.   END;
  17.  
  18.   CONSTRUCTOR PokerSol.Init;
  19.   VAR N : Byte;
  20.   BEGIN
  21.     Game.Init($1E);
  22.     D := New(LDeckP, Init(61, 15, TableColor)); D^.shuffle;
  23.     TopCard := LCardP(D^.FromTop);
  24.     TopCard^.TurnUp;
  25.     FillChar(places, SizeOf(places), 0);
  26.     cur := 0; played := 0;
  27.   END;
  28.  
  29.   DESTRUCTOR PokerSol.Done;
  30.   VAR N : Byte;
  31.   BEGIN
  32.     FOR N := 0 to 24 DO
  33.       IF places[N] <> NIL THEN Dispose(Places[N], done);
  34.     Game.done;
  35.   END;
  36.  
  37.   PROCEDURE PokerSol.display;
  38.   VAR ro, co, N : Byte;
  39.   BEGIN
  40.     TextAttr := TableColor;
  41.     ClrScr;
  42.     Frame(1, 1, 40, 23, 2, true, ' ');
  43.  
  44.     Frame(50, 1, 80, 11, 2, true, ' ');
  45.     GotoXY(53, 2);  WriteLn('    *** SCORING ***');
  46.     GotoXY(53, 3);  WriteLn('Straight Flush       30');
  47.     GotoXY(53, 4);  WriteLn('Four of a kind       16');
  48.     GotoXY(53, 5);  WriteLn('Straight             12');
  49.     GotoXY(53, 6);  WriteLn('Full house           10');
  50.     GotoXY(53, 7);  WriteLn('Three of a kind       6');
  51.     GotoXY(53, 8);  WriteLn('Flush                 5');
  52.     GotoXY(53, 9);  WriteLn('Two pairs             3');
  53.     GotoXY(53, 10); WriteLn('One pair              1');
  54.  
  55.     Frame(60, 14, 64, 17, 2, true, ' ');
  56.     D^.Display;
  57.     Frame(50, 14, 54, 17, 2, true, ' ');
  58.     TopCard^.DrawAt(51, 15);
  59.   END;
  60.  
  61.   PROCEDURE PokerSol.Play;
  62.   TYPE OneRow = ARRAY [0..4] of Byte;
  63.   VAR co, ro : Byte;
  64.     YourScore : Word;
  65.     CH : Char;
  66.  
  67.     FUNCTION Analyze(O : OneRow) : PokerHand;
  68.     VAR
  69.       valu, suit   : OneRow;
  70.       same1, same2, 
  71.       N, M, P      : Byte;
  72.       IsF, IsS     : boolean; {IsFlush and IsStraight}
  73.     BEGIN
  74.       FOR N := 0 to 4 DO
  75.         BEGIN
  76.           valu[N] := O[N] MOD 13; 
  77.           suit[N] := O[N] DIV 13; 
  78.         END; 
  79.       {Sort the values into order}
  80.       FOR N := 4 DOWNTO 1 DO
  81.         FOR M := 0 to pred(N) DO
  82.           IF valu[M] > valu[N] THEN
  83.             BEGIN
  84.               P := valu[M]; valu[M] := valu[N]; valu[N] := P; 
  85.             END; 
  86.  
  87.       IsF := true; IsS := true; {-- true 'til proven false --}
  88.       FOR M := 1 to 4 DO IF suit[M]<>suit[0] THEN IsF := false; 
  89.  
  90.       FOR N := 3 downto 1 DO IF valu[N+1]-valu[N]<>1 THEN IsS := false;
  91.       IF IsS THEN IsS := valu[1]-valu[0] IN [1, 9]; 
  92.  
  93.       IF IsF THEN
  94.         BEGIN
  95.           IF IsS THEN
  96.             IF valu[1] = 10 THEN Analyze := RoyalFlush
  97.             ELSE Analyze := StraightFlush
  98.           ELSE Analyze := Flush;
  99.           EXIT; 
  100.         END;
  101.       IF IsS THEN BEGIN Analyze := Straight; EXIT; END; 
  102.  
  103.       {-- no straight, no flush, try same-rank hands --}
  104.       same1 := 0; same2 := 0; 
  105.       FOR N := 0 to 3 DO
  106.         IF valu[N] = valu[succ(N)] THEN
  107.           BEGIN
  108.             inc(same1); 
  109.             P := valu[N]; 
  110.           END; 
  111.       IF same1 > 0 THEN
  112.         FOR N := 0 to 4 DO IF valu[N] = P THEN Inc(same2); 
  113.       CASE same1 OF
  114.         0 : Analyze := nothing; 
  115.         1 : Analyze := OnePair; 
  116.         2 : CASE same2 OF
  117.               2 : Analyze := TwoPair; 
  118.               3 : Analyze := ThreeOfAKind; 
  119.             END; 
  120.         3 : CASE same2 OF
  121.               2, 3 : Analyze := FullHouse;
  122.               4 : Analyze := FourOfAKind; 
  123.             END; 
  124.       END; 
  125.     END;
  126.  
  127.     PROCEDURE NameScore(S : PokerHand);
  128.     BEGIN
  129.       GotoXY(1, 24); ClrEol;
  130.       CASE S OF
  131.         nothing       : Write('Nothing               0'); 
  132.         OnePair       : Write('One pair              1'); 
  133.         TwoPair       : Write('Two pairs             3'); 
  134.         ThreeOfAKind  : Write('Three of a kind       6'); 
  135.         straight      : Write('Straight             12'); 
  136.         flush         : Write('Flush                 5'); 
  137.         FullHouse     : Write('Full house           10'); 
  138.         FourOfAKind   : Write('Four of a kind       16'); 
  139.         StraightFlush, 
  140.         RoyalFlush    : Write('Straight Flush       30'); 
  141.       END; 
  142.     END; 
  143.  
  144.     FUNCTION Score : Word; 
  145.     VAR col, row : Byte;
  146.       arow : OneRow; 
  147.       temp : Word; 
  148.     CONST
  149.       scoreFor : ARRAY[PokerHand] of Byte =
  150.                  (0, 1, 3, 6, 12, 5, 10, 16, 30, 30);
  151.  
  152.     BEGIN
  153.       temp := 0;
  154.       FOR row := 0 to 4 DO
  155.         BEGIN
  156.           Frame(4,row*4+2,36,row*4+5,1,false,' ');
  157.           FOR col := 0 to 4 DO arow[col] := places[col+5*row]^.GetValue;
  158.           NameScore(Analyze(aRow));
  159.           Inc(Temp, ScoreFor[Analyze(aRow)]);
  160.           ReadLn;
  161.           Frame(4,row*4+2,36,row*4+5,0,false,' ');
  162.         END;
  163.       FOR col := 0 to 4 DO
  164.         BEGIN
  165.           Frame(col*7+4,2,col*7+8,21,1,false,' ');
  166.           FOR row := 0 to 4 DO arow[row] := places[col+5*row]^.GetValue;
  167.           NameScore(Analyze(aRow));
  168.           Inc(Temp, ScoreFor[Analyze(aRow)]);
  169.           ReadLn;
  170.           Frame(col*7+4,2,col*7+8,21,0,false,' ');
  171.         END;
  172.       score := temp;
  173.     END;
  174.  
  175.     PROCEDURE BkwdNonNIL;
  176.     BEGIN WHILE places[cur]<>NIL DO cur := (cur+24) MOD 25; END;
  177.  
  178.     PROCEDURE FrwdNonNIL;
  179.     BEGIN WHILE places[cur]<>NIL DO cur := (cur+ 1) MOD 25; END;
  180.  
  181.   BEGIN
  182.     REPEAT
  183.       co := (cur MOD 5)*7+4;
  184.       ro := (cur DIV 5)*4+2;
  185.       Frame(co, ro, co+4, ro+3, 1, true, ' ');
  186.       CH := ReadKey;
  187.       Frame(co, ro, co+4, ro+3, 0, true, ' ');
  188.       CASE CH OF
  189.     #0 : CASE ReadKey OF
  190.            #$48 : BEGIN cur := (cur+20) MOD 25; BkwdNonNIL; END;
  191.            #$50 : BEGIN cur := (cur+ 5) MOD 25; FrwdNonNIL; END;
  192.            #$4B : BEGIN cur := (cur+24) MOD 25; BkwdNonNIL; END;
  193.            #$4D : BEGIN cur := (cur+ 1) MOD 25; FrwdNonNIL; END;
  194.          END;
  195.     #27 : ; 
  196.     #13 : BEGIN
  197.                Inc(played);
  198.                Places[cur] := topCard;
  199.                Places[cur]^.DrawAt(succ(co), succ(ro));
  200.            TopCard := LCardP(D^.FromTop);
  201.                WITH TopCard^ DO BEGIN TurnUp; DrawAt(51, 15); END;
  202.                IF played < 25 THEN FrwdNonNIL;
  203.              END;
  204.       END;
  205.     UNTIL (CH = #27) OR (played = 25);
  206.     IF CH <> #27 THEN
  207.       BEGIN
  208.         YourScore := Score;
  209.         TextAttr := $2E; GotoXY(1, 24); ClrEOL;
  210.         Write('Your final score is ', YourScore);
  211.       END;
  212.   END;
  213.  
  214. VAR
  215.   pgame :    PokerSol;
  216. BEGIN
  217.   pgame.Init;
  218.   pgame.display;
  219.   pgame.play;
  220. END.