Object Oriented Perl Demo - Simulation of a Deck of Cards
CardDeck is a module/class which simulates a traditional deck of cards with the capability of dealing out a single card. The cardsim.pl program which accompanies the module is the procedurally-programmed application implementing it. CardDeck has the ability to shuffle the deck and returns any previously-dealt card to the bottom of the deck every time a new card is dealt. The deck starts out very orderly, prior to shuffling. You can shuffle the deck whether or not any card has yet been dealt. It will be simple to extend this module to simulate hands containing multiple cards and multiple hands so that a true card game can be built. The next phase would be to create an additional class for the hands themselves and even a separate class for the individual cards.
Source Files:
First, here is the cardsim.pl program which uses the CardDeck.pm module. There are lots of useful comments in the code.
#!/usr/bin/perl
# File: cardsim.pl
# Console-based simulation of a deck of cards.
# This application uses the CardDeck class.
# All application and class code by Jim Mannix. January, 2010.
$VERSION = 1.0.09
use strict;
use warnings;
use lib '.'; # Directory containing the CardDeck.pm file.
use CardDeck;
# Instantiate a fresh deck object, which initially contains a full deck
# of unshuffled cards (nicely ordered by color, suit and type).
my $deck_obj = CardDeck->new();
&show_instructions();
my $exit; # Flag: exit the menu loop
while ( ! $exit ) {
&display_shuffled_state();
&display_hand();
&show_menu();
my $in = 0; # Flag: recognized input seen
my $input = <STDIN>;
print "\n";
chomp($input);
if ( $input eq '1' ) {
$in = 1;
&display_deck();
}
if ( $input eq '2' ) {
$in = 1;
&shuffle_deck();
&display_deck();
}
if ( $input eq '3' ) {
$in = 1;
&deal_card();
}
if ( $input eq '4' ) {
$in = 1;
&show_instructions();
}
if ( $input =~ /^5|q$/i ) {
$in = 1;
$exit = 1;
print "CardSim Exiting.\n\n";
} else {
unless ( $in ) { print "* * * unrecognized selection * * *\n" }
}
} # End while - main execution loop
exit (0);
sub display_deck {
my @show_deck = $deck_obj->current_deck;
print "\nCURRENT DECK OF CARDS:\n";
print "----------------------\n";
foreach my $show_card ( @show_deck ) {
print $show_card . "\n";
}
} # End sub display_deck
sub shuffle_deck {
$deck_obj->shuffle;
print "\nTHE DECK HAS BEEN SHUFFLED.\n";
} # End sub shuffle_deck
sub deal_card {
print "\nYOU HAVE JUST BEEN DEALT THIS CARD:\n";
print $deck_obj->deal_card . "\n";
print "Any previous card you had was put back onto the bottom of the deck.\n";
print "The card you were just dealt is no longer in the deck.\n";
} # End sub deal_card
sub display_shuffled_state {
print "\nSHUFFLED STATE: This deck is currently: ";
print $deck_obj->current_shuffled_state . "\n";
} # End sub display_shuffled_state
sub display_hand {
print "\n---- CURRENT HAND ----> ";
print $deck_obj->current_hand . "\n";
} # End sub display_hand
sub show_menu {
print "\nMENU:\n";
print "1 .. Display the current deck of cards.\n";
print "2 .. Shuffle and then display the deck of cards.\n";
print "3 .. Deal me a card from the top of the deck.\n";
print "4 .. Instructions.\n";
print "5/Q .. Exit.\n";
print "SELECT 1-5 or Q and PRESS ENTER: ";
} # End sub show_menu
sub show_instructions {
print "\n********************************************************************\n";
print "* CardSim * A simulation of a deck of cards.\n";
print "* The deck is displayed as it is stacked, top card to bottom card.\n";
print "* Before you shuffle the deck, it starts out very organized.\n";
print "* (Try displaying the fresh deck both before and then after shuffling!)\n";
print "* Cards are dealt from the top of the deck.\n";
print "* A card is no longer a member of the deck once it has been dealt.\n";
print "* The current simulation will only deal 1 card at a time.\n";
print "* If you have a card, it will be returned to the bottom of the deck\n";
print "* when you ask to be dealt another one.\n";
print "* You can shuffle the deck at any time, with a dealt card or not.\n";
print "* Type a number and press ENTER to make your menu selections.\n";
print "********************************************************************\n";
} # End sub show_instructions
##
#
And now the module itself. Have a look at the code comments for a fairly detailed explanation of the important parts.
# File: CardDeck.pm
# Class code by Jim Mannix. January 2010.
# Some accepted 'Best-Practice' code by Damian Conway adapted from
# 'Object Oriented Perl', Manning Publications, 2000, mostly in the
# AUTOLOAD and the constructor. All object methods, primary data
# structures and solution strategy by Jim Mannix.
package CardDeck;
$VERSION = 1.0.14;
# Class to implement a traditional deck of playing cards.
# Capability to shuffle, deal a card and remember the state of the deck.
# The current version can only deal a single card at a time but future
# versions could conceivably deal hands of specified sizes, deal multiple
# hands to multiple players or perform other specialized tasks to support
# various card games.
# Deck can be shuffled whether or not a card has been dealt from it.
# Cards are dealt from the top of the deck. If a card has already been
# dealt, then it is returned to the bottom of the deck at the time that
# another card is dealt.
#
# The deck is initialized in an organized state.
# To help demonstrate this class, it's data and the shuffling operation,
# the deck is not shuffled as part of initialization. The application is
# allowed the opportunity to display the 'unshuffled' new deck.
use strict;
use vars qw( $AUTOLOAD ); # strict would complain otherwise
use warnings;
use Carp;
# These constants are interpolated into all code in this file at compile time.
use constant { COLOR => 0, SUIT => 1, CARD => 2 };
# A variable or method beginning with an underscore _ is considered private
{
# This closure serves to encapsulate all class data and methods. No indentation
# is added for this standard, large block as a matter of style and to ease editing.
#### Definition of how the data for the deck is stored and translated
# @_deck is defined outside of the general attribute data hash for readability
# then specified via reference within the usual %_attr_data hash.
#
# @_deck is defind via an array of references to anonymous arrays
# of card attributes. As an array, the deck naturally retains its sort order.
# The attributes could have been implemented with anaymous hashes so that they
# could be referred to using nicely-named keys such as: color, suit, card
# but for compactness in the data as well as in the code, we will use an array
# and access via the numerical index/position, albeit through constants in the source.
# We make the code more readable than [0] [1] [2] when using these constants to
# refer to the attribute array indices. In some processing, such as our shuffling of
# the deck, we might also appreciate a slight performance gain with the use of
# an array over a hash. For larger data sets it can be a good performance strategy
# to use arrays with constants in this manner, rather than hashes. In this case
# of our deck of cards, the main benefit is in not having a cluttered initialization.
#
# Position Keys for the Attributes:
# [ COLOR, SUIT, CARD ]
# Position 0 = COLOR: B=Black, R=Red
# Position 1 = SUIT: C=Clubs, S=Spades, H=Hearts, D=Diamonds
# Position 2 = CARD: Specific card is stored explicitly without a lookup
my @_deck = (
[ 'B', '', 'Joker'],
[ 'R', '', 'Joker'],
[ 'B', 'C', 'Ace'],
[ 'B', 'C', '2'],
[ 'B', 'C', '3'],
[ 'B', 'C', '4'],
[ 'B', 'C', '5'],
[ 'B', 'C', '6'],
[ 'B', 'C', '7'],
[ 'B', 'C', '8'],
[ 'B', 'C', '9'],
[ 'B', 'C', '10'],
[ 'B', 'C', 'Jack'],
[ 'B', 'C', 'Queen'],
[ 'B', 'C', 'King'],
[ 'B', 'S', 'Ace'],
[ 'B', 'S', '2'],
[ 'B', 'S', '3'],
[ 'B', 'S', '4'],
[ 'B', 'S', '5'],
[ 'B', 'S', '6'],
[ 'B', 'S', '7'],
[ 'B', 'S', '8'],
[ 'B', 'S', '9'],
[ 'B', 'S', '10'],
[ 'B', 'S', 'Jack'],
[ 'B', 'S', 'Queen'],
[ 'B', 'S', 'King'],
[ 'R', 'H', 'Ace'],
[ 'R', 'H', '2'],
[ 'R', 'H', '3'],
[ 'R', 'H', '4'],
[ 'R', 'H', '5'],
[ 'R', 'H', '6'],
[ 'R', 'H', '7'],
[ 'R', 'H', '8'],
[ 'R', 'H', '9'],
[ 'R', 'H', '10'],
[ 'R', 'H', 'Jack'],
[ 'R', 'H', 'Queen'],
[ 'R', 'H', 'King'],
[ 'R', 'D', 'Ace'],
[ 'R', 'D', '2'],
[ 'R', 'D', '3'],
[ 'R', 'D', '4'],
[ 'R', 'D', '5'],
[ 'R', 'D', '6'],
[ 'R', 'D', '7'],
[ 'R', 'D', '8'],
[ 'R', 'D', '9'],
[ 'R', 'D', '10'],
[ 'R', 'D', 'Jack'],
[ 'R', 'D', 'Queen'],
[ 'R', 'D', 'King'],
); # End of @_deck array of references to anonymous arrays
# Lookups for Color and Suit since we prefer a compact definition of the deck.
# This would be more relevant to an application with large data sets where
# ad-hoc compression like this might be very important to reduce data size and
# speed up various operations.
# Rather than clutter up the definition of %_attr_data below, we define these hashes
# outside and then make a reference to them inside of %_attr_data as we did for @_deck
my %_color_lookup = ( 'B' => 'Black', 'R' => 'Red' );
my %_suit_lookup = (
'C' => 'Clubs',
'S' => 'Spades',
'H' => 'Hearts',
'D' => 'Diamonds',
);
my %_attr_data = # DEFAULT ACCESSIBILITY
( _deck => [ \@_deck, 'read/write' ],
_shuffled_state => [ '0', 'read/write' ],
_hand => [ '', 'read/write' ], # SEE NOTE *HAND1
_color_lookup => [ \%_color_lookup, 'read' ],
_suit_lookup => [ \%_suit_lookup, 'read' ],
);
# NOTE *HAND1: This scalar represents the single dealt card, but would likely become
# an array if future versions were to support dealing multiple cards.
# This is a reference to the anonymous array of the attributes of the single dealt card.
# In the 'deal_card' method, if _hand is not an empty string, that indicates a card has
# already been dealt and thus a reference to a single card's anon array would be in _hand.
# As a general rule, the class will keep track of how many CardDeck objects have been
# instantiated. If we build a multi-user online casino with this class, this class
# variable would tell us how many decks of cards are currently in use.
my $_deck_count = 0;
# Is a specified object attribute accessible in a given mode?
sub _accessible {
my ( $self, $attr, $mode ) = @_;
$_attr_data{$attr}[1] =~ /$mode/
}
# Classwide default value for a specified object attribute
sub _default_for {
my ( $self, $attr ) = @_;
$_attr_data{$attr}[0];
}
# Private method returns list of names of all specified object attributes
sub _standard_keys { keys %_attr_data; }
sub get_deck_count { $_deck_count; } # Public method to retrieve the object (deck) count
sub _incr_deck_count { ++$_deck_count } # Private method to increment object count
sub _decr_deck_count { --$_deck_count } # Private method to decrement object count
} # End of block enclosing/encapsulating class data and class methods
# new() Constructor:
# The constructor is dual-purpose in the sense that it can both create a fresh
# new instance of the class (object), initialized with defaults or it can clone
# an existing object by copying all of that objects attributes, possibly tweaking some of
# those attributes. Calling through the class name like this creates a fresh object:
# Class->new( %args_for_new_object )
# Thus new() is considered a class method in that case. Unspecified args defer to defaults.
#
# Calling through an existing object reference as below clones/customizes that object:
# $obj_ref->new( %args_to_customize_cloned_object )
# Thus new() is considered an object method in that scenario.
sub new {
my ( $caller, %arg ) = @_;
my $caller_is_obj = ref($caller);
my $class = $caller_is_obj || $caller;
my $self = bless {}, $class;
foreach my $attrname ( $self->_standard_keys() )
{
my ( $argname ) = ( $attrname =~ /^_(.*)/);
if ( exists $arg{$argname} )
{ $self->{$attrname} = $arg{$argname} } # Class uses supplied attr for new obj
elsif ( $caller_is_obj )
{ $self->{$attrname} = $caller->{$attrname} } # Cloning uses attr of orig object
else
{ $self->{$attrname} = $self->_default_for( $attrname ) } # Class uses default
} # End foreach _standard_keys
$self->_incr_deck_count();
return $self;
} # End new constructor
# Destructor decrements the classes count of deck objects
sub DESTROY {
$_[0]->_decr_deck_count();
}
# OBJECT METHODS
# Returns an array of the current state of the deck with nicely formatted
# names for each card. Top to bottom of the deck is first to last element of the array.
sub current_deck {
my ( $self, %arg ) = @_;
my $deck_arr_ref = $self->get_deck;
my @deck = @{$deck_arr_ref};
my @formatted_deck;
my %suit_lu = %{$self->get_suit_lookup};
my %color_lu = %{$self->get_color_lookup};
foreach my $card_arr_ref ( @deck ) {
my $formatted_card = $self->formatted_card( $card_arr_ref );
push( @formatted_deck, $formatted_card );
} # End foreach $card_arr_ref
return( @formatted_deck );
} # End sub current_deck
# Randomly reorders all cards currently in the deck and sets the shuffled flag
# Does not return anything.
sub shuffle {
my ( $self, %arg ) = @_;
my $deck_arr_ref = $self->get_deck;
my @deck = @{$deck_arr_ref}; # Copied the existing deck to work with temporarily
my @shuffled_deck; # Also a temporary deck array we will reconstruct randomly
my %randomizer_hash;
foreach my $card ( @deck ) {
my $lg_random_key = int( rand(9999) + 1 );
$randomizer_hash{$lg_random_key} = $card;
}
foreach my $key ( sort keys %randomizer_hash ) {
push( @shuffled_deck, $randomizer_hash{$key} );
}
$self->set_deck( \@shuffled_deck );
$self->set_shuffled_state( 1 );
} # End sub shuffle
# Returns a string indicating the shuffled state of the deck
sub current_shuffled_state {
my ( $self, %arg ) = @_;
my @shuffle_words = ( 'NOT shuffled', 'shuffled' );
return $shuffle_words[$self->get_shuffled_state];
} # End sub current_shuffled_state
# Returns a formatted string describing the current single dealt card/hand
sub current_hand {
my ( $self, %arg ) = @_;
my $card_arr_ref = $self->get_hand;
my $formatted_hand;
if ( $card_arr_ref eq '' ) {
$formatted_hand = "NO CARD DEALT. NO HAND.";
return( $formatted_hand );
}
$formatted_hand = $self->formatted_card( $card_arr_ref );
return( $formatted_hand );
} # End sub current_hand
# Moves the card on the top of the deck into the _hand attribute and if there was a
# pre-existing _hand, moves that onto the bottom of the deck.
# Returns a formatted string describing the single card just dealt.
sub deal_card {
my ( $self, %arg ) = @_;
my $deck_arr_ref = $self->get_deck;
my @deck = @{$deck_arr_ref}; # Copied the existing deck to work with temporarily
my $current_hand = $self->get_hand;
# If a card has already been dealt (the player has a single card 'hand'),
# then first -push- that card back onto the bottom of the deck.
if ( $current_hand ne '' ) {
push( @deck, $current_hand );
}
# Now we can deal a new card by -shifting- it off the top of the deck
my $new_hand = shift( @deck );
# Store the reference to the new/modified deck in the object attributes
$self->set_deck( \@deck );
# Store the reference to the single dealt card/hand in the object attributes
$self->set_hand( $new_hand ); # This was never copied but remains the same reference
# to the same card, just now maintained in a different place (in hand not in the deck.)
my $formatted_hand = $self->formatted_card( $new_hand );
return( $formatted_hand );
} # End sub deal_card
# Takes a reference to an array of a card, which can be in the deck or in the single dealt
# hand and returns a formatted string describing that card, using lookups and constants
# and some logic upon the data to perform the formatting.
sub formatted_card {
my ( $self, $card_attr_arr_ref ) = @_;
my %suit_lu = %{$self->get_suit_lookup};
my %color_lu = %{$self->get_color_lookup};
my @card_attr = @{$card_attr_arr_ref};
my $formatted_card = $card_attr[CARD];
if ( $formatted_card ne 'Joker' ) {
$formatted_card .= " of " . $suit_lu{$card_attr[SUIT]};
}
$formatted_card .= " (" . $color_lu{$card_attr[COLOR]} . ")";
return( $formatted_card );
} # End sub formatted_card
# END OBJECT METHODS
# Dynamically generate basic attribute accessor methods (get/set) for elements
# of our object's attributes, honoring the accessibility settings in %_attr_data.
# The basic accessor subroutines spring into existence when first called if
# access is permitted and those dynamic subs remain after their first invocation,
# so subsequent calls are as efficient as a hardcoded subrountine.
sub AUTOLOAD {
no strict "refs";
# my $self = shift;
# my $newval = shift;
my ( $self, $newval ) = @_;
# As yet unseen get_* method called?
if ( $AUTOLOAD =~ /.*::get(_\w+)/ && $self->_accessible( $1, 'read' ) ) {
my $attr_name = $1;
*{$AUTOLOAD} = sub { return $_[0]->{$attr_name} };
return $self->{$attr_name}
}
# As yet unseen set_* method called?
if ( $AUTOLOAD =~ /.*::set(_\w+)/ && $self->_accessible( $1, 'write' ) ) {
my $attr_name = $1;
*{$AUTOLOAD} = sub { $_[0]->{$attr_name} = $_[1]; return };
$self->{$1} = $newval;
return
}
croak( "No such method: $AUTOLOAD" );
} # End sub AUTOLOAD
1;
##
#
