Simtel MSDOS 1992 September/Simtel20_Sept92.cdr/msdos/ddjmag/ddj8602.arc/JONES.FEB

Text File | 1986-02-27 | 19KB | 690 lines

        LISTING 1 - Draw Poker Program written in Ada

begin
  Open_New(STOCK);
  loop
    put("How many dollars do you want to bet? "); get(WAGER);
    exit when WAGER = 0;
    Shuffle(STOCK);
    Open_New(PLAYERS_HAND);
    for i in 1 .. 5 loop
      Deal_A_Card(PLAYERS_HAND,STOCK);
    end loop;
    put(PLAYERS_HAND);
    Discard_From(PLAYERS_HAND);
    loop
      exit when Filled(PLAYERS_HAND);
      Deal_A_Card(PLAYERS_HAND, STOCK);
    end loop;
    put(PLAYERS_HAND);
    VALUE := Value_Of(PLAYERS_HAND);
    case VALUE is
      when ROYAL_FLUSH => PAYOFF := 250;
      when STRAIGHT_FLUSH => PAYOFF := 50;
      when FOUR_OF_A_KIND => PAYOFF := 25;
      when FULL_HOUSE => PAYOFF := 6;
      when FLUSH => PAYOFF := 5;
      when STRAIGHT => PAYOFF := 4;
      when THREE_OF_A_KIND => PAYOFF := 3;
      when TWO_PAIR => PAYOFF := 2;
      when others => PAYOFF := 0;
    end case;
    if PAYOFF = 0
      then put_line("Sorry, you lose.");
      else put("You have ");put(VALUE);put("!");new_line;
           put("You win"); put(WAGER*PAYOFF); put_line(" dollars!");
    end if;
  end loop;
end Draw_Poker;

------------------------------------------------------------

        LISTING 2 - The general form of a procedure

        procedure *1 is
          *2
        begin
          *3
        exception
          *4
        end *5;

-----------------------------------------------------------------

        LISTING 3 - The Open_New procedure

  procedure Open_New(DECK : out Decks) is
    i : integer := 0;
    CARD : Cards;
  begin
    for S in Suits loop
      for R in Ranks loop
        CARD.SUIT := S;
        CARD.RANK := R;
        i := i+1;
        DECK.FAN(i) := CARD;
      end loop;
    end loop;
    DECK.CARDS_LEFT := i;
    if i /= CARDS_IN_DECK then raise DECK_ERROR; end if;
  exception
    -- CONSTRAINT_ERROR or DECK_ERROR may be raised by this
    -- procedure if the number of cards in a deck does not
    -- equal the number of cards generated.
    when DECK_ERROR | CONSTRAINT_ERROR =>
      raise DECK_ERROR; -- convert all errors to DECK_ERROR;
  end Open_New;



-------------------------------------------------------------
        Listing 4 (Part A) - PLAYING_CARDS package specification


--                      CARDS.ADA
--                      19 JULY 1984
--                      DO-WHILE JONES

package PLAYING_CARDS is

  CARDS_IN_DECK : constant integer := 52;
  CARDS_IN_HAND : constant integer := 5;

  DECK_ERROR    : exception; -- raised by Open_New
  DECK_EXHAUSED : exception; -- raised by Deal_A_Card
  HAND_FULL     : exception; -- raised by Deal_A_Card

  type Suits is (CLUBS, DIAMONDS, HEARTS, SPADES);
  type Ranks is (TWO, THREE, FOUR, FIVE, SIX, SEVEN, EIGHT, NINE, TEN,
    JACK, QUEEN, KING, ACE);

  type Cards is
    record
      SUIT : Suits;
      RANK : Ranks;
    end record;

  type Fans is array(integer range <>) of Cards;
  type Status is array(integer range <>) of boolean;

  type Decks is
    record
      CARDS_LEFT : integer;
      FAN        : Fans(1..CARDS_IN_DECK);
    end record;

  type Hands is
    record
      PLAYED : Status(1..CARDS_IN_HAND);
      FAN    : Fans(1..CARDS_IN_HAND);
    end record;

  function Card_Number(X : integer; HAND : Hands) return Cards;
  function Played_Card_Number(X : integer; HAND : Hands) return boolean;

  function Suit_of(CARD : Cards) return Suits;
  function Rank_of(CARD : Cards) return Ranks;



  procedure put(SUIT : Suits);
  procedure put(RANK : Ranks);
  procedure put(CARD : Cards);
  procedure put(HAND : Hands);


  procedure Open_New(DECK : out Decks);         -- create a new deck
  procedure Shuffle(DECK : in out Decks);       -- shuffle a deck

  procedure Open_New(HAND : out Hands);         -- create a new hand
  procedure Sort(HAND : in out Hands);  -- sort by rank, ignore suits
  procedure Discard_From(HAND : in out Hands);
  function Filled(HAND : Hands) return boolean; -- is the hand full?

  procedure Deal_A_Card(HAND : in out Hands; DECK : in out Decks);

end PLAYING_CARDS;

-------------------------------------------------------------
        LISTING 4 (Part B) - PLAYING_CARDS package body


--                      CARDB.ADA
--                      19 JULY 1984
--                      DO-WHILE JONES

with CON_IO; use CON_IO;
with APL; use APL;
package body PLAYING_CARDS is

  CONSTRAINT_ERROR : exception; -- required only by Maranatha A

  function Card_Number(X : integer; HAND : Hands) return Cards is
  begin
    return HAND.FAN(X);
  end Card_Number;

  function Played_Card_Number(X : integer; HAND : Hands) return boolean is
  begin
    return HAND.PLAYED(X);
  end Played_Card_Number;

  function Suit_of(CARD : Cards) return Suits is
  begin
    return CARD.SUIT;
  end Suit_of;

  function Rank_of(CARD : Cards) return Ranks is
  begin
    return CARD.RANK;
  end Rank_of;

  procedure put(SUIT : Suits) is
  begin
  case SUIT is
    when CLUBS => put("CLUBS");
    when DIAMONDS => put("DIAMONDS");
    when HEARTS => put("HEARTS");
    when SPADES => put("SPADES");
  end case;
  end put;







  procedure put(RANK : Ranks) is
  begin
  case RANK is
    when TWO => put("TWO");
    when THREE => put("THREE");
    when FOUR => put("FOUR");
    when FIVE => put("FIVE");
    when SIX => put("SIX");
    when SEVEN => put("SEVEN");
    when EIGHT => put("EIGHT");
    when NINE => put("NINE");
    when TEN => put("TEN");
    when JACK => put("JACK");
    when QUEEN => put("QUEEN");
    when KING => put("KING");
    when ACE => put("ACE");
  end case;
  end put;

  procedure put(CARD : Cards) is
    RANK : Ranks;
    SUIT : Suits;
  begin
    put(Rank_of(CARD)); put(" of "); put(Suit_of(CARD));
  end put;

  procedure put(HAND : Hands) is
  begin
  for i in 1..CARDS_IN_HAND loop
    if Played_Card_Number(i,HAND) then
      null; -- don't display a card that isn't there
    else
      put(Card_Number(i,HAND));
      put("  "); -- separate cards with two blanks
    end if;
  end loop;
  new_line;
  end put;





  procedure Open_New(DECK : out Decks) is
    i : integer := 0;
    CARD : Cards;
  begin
    for S in Suits loop
      for R in Ranks loop
        CARD.SUIT := S;
        CARD.RANK := R;
        i := i+1;
        DECK.FAN(i) := CARD;
      end loop;
    end loop;
    DECK.CARDS_LEFT := i;
    if i /= CARDS_IN_DECK then raise DECK_ERROR; end if;
  exception
    -- CONSTRAINT_ERROR or DECK_ERROR may be raised by this
    -- procedure if the number of cards in a deck does not
    -- equal the number of cards generated.
    when DECK_ERROR | CONSTRAINT_ERROR =>
      raise DECK_ERROR; -- convert all errors to DECK_ERROR;
  end Open_New;

  procedure Shuffle(DECK : in out Decks) is
    SEQUENCE : Random_Sequence(1..CARDS_IN_DECK);
    TEMP     : DECKS;
  begin
    TEMP.CARDS_LEFT := CARDS_IN_DECK;
    SEQUENCE := Deal(CARDS_IN_DECK, CARDS_IN_DECK);
    for i in 1..CARDS_IN_DECK loop
      TEMP.FAN(i) := DECK.FAN(SEQUENCE(i));
    end loop;
    DECK := TEMP;
  end Shuffle;





  procedure Deal_A_Card(HAND : in out Hands; DECK : in out Decks) is
    X : integer := 0;
  begin
    -- find an empty slot in the hand
    loop
      X := X+1;
      if X > CARDS_IN_HAND then raise HAND_FULL; end if;
      exit when Played_Card_Number(X, HAND);
    end loop;
    -- draw a card from the deck and put it in the empty slot
    if DECK.CARDS_LEFT < 1
      then raise DECK_EXHAUSED;
      else DECK.CARDS_LEFT := DECK.CARDS_LEFT-1;
    end if;
    HAND.FAN(X) := DECK.FAN(CARDS_IN_DECK - DECK.CARDS_LEFT);
    HAND.PLAYED(X) := FALSE;
  end Deal_A_Card;

  procedure Sort(HAND : in out Hands) is
    SORTED : boolean;
    TEMP : Cards;
  begin
    loop
      SORTED := TRUE;
      for i in 1..CARDS_IN_HAND loop
        if Rank_of(Card_Number(i, HAND)) > Rank_of(Card_Number(i+1, HAND)) then
          TEMP := Card_Number(i, HAND);
          HAND.FAN(i) := Card_Number(i+1, HAND);
          HAND.FAN(i+1) := TEMP;
          SORTED := FALSE;
        end if;
      end loop;
    exit when SORTED;
    end loop;
  end Sort;

  procedure Open_New(HAND : out Hands) is
  begin
    for i in 1..CARDS_IN_HAND loop
      HAND.PLAYED(i) := TRUE; -- hand is empty (all cards have been played)
    end loop;
  end Open_New;


  procedure Discard_From(HAND : in out Hands) is
    RESPONSE : character;
  begin
    for i in 1..CARDS_IN_HAND loop
      put("Do you want to discard the ");
      put(Card_Number(i, HAND));
      put("? (Y/N) ");
      get(RESPONSE); new_line;
      if RESPONSE = 'Y' or RESPONSE = 'y'
        then HAND.PLAYED(i) := TRUE;
      end if;
    end loop;
  end Discard_From;

  function Filled(HAND : Hands) return boolean is
  begin
    for i in 1..CARDS_IN_HAND loop
      if Played_Card_Number(i, HAND) then
        return FALSE; -- if any card is played, hand is not filled
      end if;
    end loop;
    return TRUE;  -- if no cards played, hand is filled
  end Filled;

end PLAYING_CARDS;



        LISTING 5 (Part A) - APL package specification


--                      APLS.ADA
--                      20 JULY 1984
--                      DO-WHILE JONES

--      This package simulates some APL functions.

--      Roll(X) returns a random integer in the range 1..X.

--      Deal(X,Y) returns a random sequence of X elements all
--        of which are in the range 1..Y. No element appears
--        twice in the random sequence.

package APL is

  subtype positive is integer range 1..integer'last;
  -- The above line is not required in Ada.
  -- (It is required for Maranatha A.)

  type Random_Sequence is array(positive range <>) of positive;

  function Roll(LIMIT : positive) return positive;

  function Deal(NUMBER, LIMIT : positive) return Random_Sequence;

end APL;



        LISTING 5 (Part B) - APL package body


--                      APLB.ADA
--                      20 JULY 1984
--                      DO-WHILE JONES

--      This package simulates two APL functions.

--      Note: Roll uses the RND function which returns a random
--      real number between 0.0 and 1.0. The RND function is
--      implementation specific to Maranatha A.

package body APL is

  function Roll(LIMIT : positive) return positive is
    RANDOM : float;
  begin
    RANDOM := float(LIMIT)*RND(0.0);  -- RND is implementation specific.
    return positive(RANDOM+0.5);
  end Roll;

  function Deal(NUMBER, LIMIT : positive) return Random_Sequence is
    MAX    : positive := LIMIT;
    RS     : Random_Sequence(1..NUMBER);
    SOURCE : Random_Sequence(1..LIMIT);
    RANDOM_INDEX : positive;
  begin
    for i in 1..LIMIT loop
      SOURCE(i) := i; -- SOURCE has one of every number
    end loop;
    for i in 1..NUMBER loop
      RANDOM_INDEX := Roll(MAX);
      RS(i) := SOURCE(RANDOM_INDEX); -- pick a random number from SOURCE
      for j in RANDOM_INDEX..MAX-1 loop
        SOURCE(j) := SOURCE(j+1); -- remove that number from the SOURCE
      end loop;
      MAX := MAX-1; -- there is now 1 less number in the source array
    end loop;
    return RS;
  end Deal;

end APL;

        LISTING 6 - Complete Draw Poker program


--                      DPOKER.ADA
--                      19 JULY 1984
--                      DO-WHILE JONES

with CON_IO; use CON_IO;
with PLAYING_CARDS; use PLAYING_CARDS;
procedure Draw_Poker is

  type Values is (NOTHING, TWO_PAIR, THREE_OF_A_KIND, STRAIGHT,
    FLUSH, FULL_HOUSE, FOUR_OF_A_KIND, STRAIGHT_FLUSH, ROYAL_FLUSH);

  STOCK         : Decks;
  PLAYERS_HAND  : Hands;
  WAGER, PAYOFF : integer;
  VALUE         : Values;

  procedure put(X : Values) is
  begin
    case X is
      when TWO_PAIR => put("Two Pair");
      when THREE_OF_A_KIND => put("Three of a Kind");
      when STRAIGHT => put("a Straight");
      when FLUSH => put("a Flush");
      when FULL_HOUSE => put("a Full House");
      when FOUR_OF_A_KIND => put("Four of a Kind");
      when STRAIGHT_FLUSH => put("a Straight Flush");
      when ROYAL_FLUSH => put("a Royal Flush");
      when NOTHING => put("a losing hand");
    end case;
  end put;

  function Value_of(HAND : Hands) return Values is separate;





begin
  Open_New(STOCK);
loop
  put("How many dollars do you want to bet? "); get(WAGER);
  exit when WAGER = 0;
  Shuffle(STOCK);
  Open_New(PLAYERS_HAND);
  for i in 1 .. 5 loop
    Deal_A_Card(PLAYERS_HAND,STOCK);
  end loop;
  put(PLAYERS_HAND);
  Discard_From(PLAYERS_HAND);
  loop
    exit when Filled(PLAYERS_HAND);
    Deal_A_Card(PLAYERS_HAND, STOCK);
  end loop;
  put(PLAYERS_HAND);
  VALUE := Value_Of(PLAYERS_HAND);
  case VALUE is
    when ROYAL_FLUSH => PAYOFF := 250;
    when STRAIGHT_FLUSH => PAYOFF := 50;
    when FOUR_OF_A_KIND => PAYOFF := 25;
    when FULL_HOUSE => PAYOFF := 6;
    when FLUSH => PAYOFF := 5;
    when STRAIGHT => PAYOFF := 4;
    when THREE_OF_A_KIND => PAYOFF := 3;
    when TWO_PAIR => PAYOFF := 2;
    when others => PAYOFF := 0;
  end case;
  if PAYOFF = 0
    then put_line("Sorry, you lose.");
    else put("You have ");put(VALUE);put("!");new_line;
         put("You win"); put(WAGER*PAYOFF); put_line(" dollars!");
  end if;
end loop;
end Draw_Poker;

                LISTING 7 - Value_of subprogram


--                      VALUE.ADA
--                      19 JULY 1984
--                      DO-WHILE JONES


  separate (Draw_Poker); -- real Ada doesn't have a semicolon here
  function Value_of(HAND : Hands) return Values is

    PATTERN : String(1..CARDS_IN_HAND-1);
    X : Hands;

    function Flush_in(HAND : Hands) return boolean is
    begin
      for i in 1..CARDS_IN_HAND-1 loop
        if Suit_of(Card_Number(i, HAND)) /= Suit_of(Card_Number(i+1, HAND))
          then return FALSE;
        end if;
      end loop;
      return TRUE;
    end Flush_in;

    function Straight_in(HAND : Hands) return boolean is
    begin
      for i in 1..CARDS_IN_HAND-1 loop
        if Ranks'pos(Rank_of(Card_Numeer(i, HAND)))
         /= Ranks'pos(Rank_of(Card_Number(i+1, HAND)))-1 then
          return FALSE;
        end if;
      end loop;
      return TRUE;
    end Straight_in;





  begin
    X := HAND; -- make a copy of HAND so it can be sorted
    Sort(X);
    for i in 1..CARDS_IN_HAND-1 loop
      if Rank_of(Card_Number(i, X)) = Rank_of(Card_Number(i+1, X)) then
        PATTERN(i) := 'S'; -- adjacent cards have SAME rank
      else
        PATTERN(i) := 'D'; -- adjacent cards have DIFFERENT rank
      end if;
    end loop;
    if Flush_in(X) and Straight_in(X) then
      if Rank_of(Card_Number(5, X)) = ACE then
        return ROYAL_FLUSH;
      else
        return STRAIGHT_FLUSH;
      end if;
    end if;

    if PATTERN = "SSSD" or PATTERN = "DSSS" then
      return FOUR_OF_A_KIND;
    end if;

    if PATTERN = "SSDS" or PATTERN = "SDSS" then
      return FULL_HOUSE;
    end if;

    if Flush_in(X) then
      return FLUSH;
    end if;

    if Straight_in(X) then
      return STRAIGHT;
    end if;

    if PATTERN = "SSDD" or PATTERN = "DSSD" or PATTERN = "DDSS" then
      return THREE_OF_A_KIND;
    end if;

    if PATTERN = "SDSD" or PATTERN = "DSDS" or PATTERN = "SDDS" then
      return TWO_PAIR;
    end if;

    return NOTHING;

  end Value_of;




        LISTING 8 - Corrected Value_of subprogram

--                      VALUE2.ADA
--                      9 NOVEMBER 1984
--                      DO-WHILE JONES

--      This revision recognizes that TWO, THREE, FOUR,
--      FIVE, ACE is a straight (but not a royal flush).



  separate (Draw_Poker); -- real Ada doesn't have a semicolon
  function Value_of(HAND : Hands) return Values is

    PATTERN : String(1..CARDS_IN_HAND-1);
    X : Hands;

    function Flush_in(HAND : Hands) return boolean is
    begin
      for i in 1..CARDS_IN_HAND-1 loop
        if Suit_of(Card_Number(i, HAND)) /= Suit_of(Card_Number(i+1, HAND))
          then return FALSE;
        end if;
      end loop;
      return TRUE;
    end Flush_in;

    function Straight_in(HAND : Hands) return boolean is
    -- HAND must already be sorted for this procedure to work
    begin
      if Rank_of(Card_Number(1,HAND)) = TWO   and
         Rank_of(Card_Number(2,HAND)) = THREE and
         Rank_of(Card_Number(3,HAND)) = FOUR  and
         Rank_of(Card_Number(4,HAND)) = FIVE  and
         Rank_of(Card_Number(5,HAND)) = ACE then
           return TRUE;
       end if;
      for i in 1..CARDS_IN_HAND-1 loop
        if Ranks'pos(Rank_of(Card_Number(i, HAND)))
         /= Ranks'pos(Rank_of(Card_Number(i+1, HAND)))-1 then
          return FALSE;
        end if;
      end loop;
      return TRUE;
    end Straight_in;





  begin
    X := HAND; -- make a copy of HAND so it can be sorted
    Sort(X);
    for i in 1..CARDS_IN_HAND-1 loop
      if Rank_of(Card_Number(i, X)) = Rank_of(Card_Number(i+1, X)) then
        PATTERN(i) := 'S'; -- adjacent cards have SAME rank
      else
        PATTERN(i) := 'D'; -- adjacent cards have DIFFERENT rank
      end if;
    end loop;
    if Flush_in(X) and Straight_in(X) then
      if Rank_of(Card_Number(4, X)) = KING then
        return ROYAL_FLUSH;
      else
        return STRAIGHT_FLUSH;
      end if;
    end if;

    if PATTERN = "SSSD" or PATTERN = "DSSS" then
      return FOUR_OF_A_KIND;
    end if;

    if PATTERN = "SSDS" or PATTERN = "SDSS" then
      return FULL_HOUSE;
    end if;

    if Flush_in(X) then
      return FLUSH;
    end if;

    if Straight_in(X) then
      return STRAIGHT;
    end if;

    if PATTERN = "SSDD" or PATTERN = "DSSD" or PATTERN = "DDSS" then
      return THREE_OF_A_KIND;
    end if;

    if PATTERN = "SDSD" or PATTERN = "DSDS" or PATTERN = "SDDS" then
      return TWO_PAIR;
    end if;

    return NOTHING;

  end Value_of;
;

  end Value_of;