File Coverage

blib/lib/Games/Cards/Pair.pm
Criterion Covered Total %
statement 94 139 67.6
branch 12 26 46.1
condition 0 3 0.0
subroutine 19 27 70.3
pod 7 7 100.0
total 132 202 65.3


line stmt bran cond sub pod time code
1             package Games::Cards::Pair;
2              
3             $Games::Cards::Pair::VERSION = '0.20';
4             $Games::Cards::Pair::AUTHORITY = 'cpan:MANWAR';
5              
6             =head1 NAME
7              
8             Games::Cards::Pair - Interface to the Pelmanism (Pair) Card Game.
9              
10             =head1 VERSION
11              
12             Version 0.20
13              
14             =cut
15              
16 3     3   59548 use 5.006;
  3         19  
17 3     3   1736 use Data::Dumper;
  3         17840  
  3         199  
18              
19 3     3   1103 use Attribute::Memoize;
  3         15062  
  3         119  
20 3     3   19 use List::Util qw(shuffle);
  3         5  
  3         288  
21 3     3   1583 use List::MoreUtils qw(first_index);
  3         32015  
  3         17  
22 3     3   3832 use Term::Screen::Lite;
  3         76851  
  3         99  
23 3     3   1422 use Types::Standard qw(Int);
  3         188961  
  3         31  
24 3     3   3300 use Games::Cards::Pair::Params qw(ZeroOrOne Cards);
  3         10  
  3         51  
25 3     3   2632 use Games::Cards::Pair::Card;
  3         10  
  3         121  
26              
27 3     3   22 use Moo;
  3         6  
  3         20  
28 3     3   885 use namespace::autoclean;
  3         7  
  3         22  
29              
30 3     3   259 use overload ('""' => \&as_string);
  3         5  
  3         21  
31              
32             has [ qw(bank seen) ] => (is => 'rw', isa => Cards);
33             has 'cards' => (is => 'rw', default => sub { 12 });
34             has 'board' => (is => 'rw');
35             has 'available' => (is => 'ro', isa => Cards);
36             has 'screen' => (is => 'ro', default => sub { Term::Screen::Lite->new; });
37             has 'count' => (is => 'rw', isa => Int, default => sub { 0 });
38             has 'debug' => (is => 'rw', isa => ZeroOrOne, default => sub { 0 });
39              
40             =head1 DESCRIPTION
41              
42             A single-player game of Pelmanism, played with minimum of 12 cards and maximum up
43             to 54 cards. Depending on number of cards choosen the user, it prepares the game.
44              
45             Cards picked up from the collection comprises each of the thirteen values (2,3,4,
46             5,6,7,8,9,10,Queen,King,Ace and Jack) in each of the four suits (Clubs,Diamonds,
47             Hearts and Spades) plus two jokers. The Joker will not have any suit.
48              
49             The game script C is supplied with the distribution and on install
50             is available to play with.
51              
52             USAGE: play-pelmanism [-h] [long options...]
53              
54             --cards=Int Cards count (min:12, max:54).
55             --verbose Play the game in verbose mode.
56              
57             --usage show a short help message
58             -h show a compact help message
59             --help show a long help message
60             --man show the manual
61              
62             =head1 METHODS
63              
64             =head2 play($index)
65              
66             Accepts comma separated card indices and play the game.
67              
68             =cut
69              
70             sub play {
71 2     2 1 751 my ($self, $index) = @_;
72              
73 2         9 my ($card, $new) = $self->_pick($index);
74              
75 1 50       5 if ($new->equal($card)) {
76 0         0 $self->_process($new, $card);
77             }
78             else {
79 1         20 $self->{deck}->{$new->index} = $new;
80 1         19 $self->{deck}->{$card->index} = $card;
81             }
82             }
83              
84             =head2 is_over()
85              
86             Returns 1 or 0 depending if the deck is empty or not.
87              
88             =cut
89              
90             sub is_over {
91 1     1 1 13 my ($self) = @_;
92              
93 1         2 return (scalar(@{$self->{available}}) == 0);
  1         8  
94             }
95              
96             =head2 get_board()
97              
98             Return game board with hidden card, showing only the card index.
99              
100             =cut
101              
102             sub get_board {
103 0     0 1 0 return $_[0]->as_string(0);
104             }
105              
106             =head2 is_valid_card_count($count)
107              
108             Valid card count is any number between 12 and 54 (both inclusive). Also it should
109             be a multiple of 4.
110              
111             =cut
112              
113             sub is_valid_card_count {
114 0     0 1 0 my ($self, $count) = @_;
115              
116 0   0     0 return (defined $count
117             && ($count =~ /^\d+$/)
118             && ($count >=12 || $count <= 54)
119             && ($count % 4 == 0));
120             }
121              
122             =head2 init()
123              
124             Shuffles the pack and then pick required number of cards.
125              
126             =cut
127              
128             sub init {
129 2     2 1 114 my ($self) = @_;
130              
131 2         4 my $cards = [];
132 2         6 $self->{available} = [];
133 2         12 my $i = $self->cards / 4;
134 2         6 foreach my $suit (qw(C D H S)) {
135 8         12 my $j = 1;
136 8         17 foreach my $value (qw(A 2 3 4 5 6 7 8 9 10 J Q K)) {
137 104 100       161 next if ($j > $i);
138 24         333 push @$cards, Games::Cards::Pair::Card->new({ suit => $suit, value => $value });
139 24         482 $j++;
140             }
141             }
142              
143             # Adding two Jokers to the Suit.
144 2         31 push @$cards, Games::Cards::Pair::Card->new({ value => 'Joker' });
145 2         68 push @$cards, Games::Cards::Pair::Card->new({ value => 'Joker' });
146 2         49 push @{$self->{available}}, $_ for (0..$self->cards-1);
  24         40  
147              
148             # Index card after shuffle.
149 2         8 $self->_index($cards);
150             }
151              
152             =head2 get_matched_pairs()
153              
154             Returns all the matching pair, if any found, from the bank.
155              
156             =cut
157              
158             sub get_matched_pairs {
159 0     0 1 0 my ($self) = @_;
160              
161 0         0 my $string = '';
162 0         0 foreach (@{$self->{bank}}) {
  0         0  
163 0         0 $string .= sprintf("%s %s\n", $_->[0], $_->[1]);
164             }
165              
166 0         0 return $string;
167             }
168              
169             =head2 as_string()
170              
171             Returns deck arranged as 4 in a row blocks. This is overloaded as string context.
172              
173             =cut
174              
175             sub as_string {
176 1     1 1 4 my ($self, $hide) = @_;
177              
178 1         2 my $deck = '';
179 1         5 foreach my $i (1..$self->cards) {
180 12         24 my $card = $self->{deck}->{$i-1};
181 12         14 my $c = ' ';
182 12 50       16 if (defined $card) {
183 12 50       16 if ($hide) {
184 0         0 $c = $i;
185             }
186             else {
187 12         23 $c = $card->as_string;
188             }
189             }
190              
191 12         23 $deck .= sprintf("[ %5s ]", $c);
192 12 100       26 $deck .= "\n" if ($i % 4 == 0);
193             }
194              
195 1         4 return $deck;
196             }
197              
198             #
199             #
200             # PRIVATE METHODS
201              
202             sub _pick {
203 2     2   5 my ($self, $index) = @_;
204              
205 2         4 $self->{count}++;
206              
207 2         9 my ($i, $j) = split /\,/, $index, 2;
208 2         8 --$i; --$j;
  2         3  
209 2         9 my $c1 = $self->{deck}->{$i};
210 2 100       12 die "ERROR: Invalid card received [$i].\n" unless defined $c1;
211              
212 1         3 my $c2 = $self->{deck}->{$j};
213 1 50       5 die "ERROR: Invalid card received [$j].\n" unless defined $c2;
214              
215 1         3 push @{$self->{seen}}, $c1, $c2;
  1         3  
216              
217 1         40 return ($c1, $c2);
218             }
219              
220             sub _save {
221 0     0   0 my ($self, @cards) = @_;
222              
223 0 0       0 die("ERROR: Expecting atleast a pair of cards.\n") unless (scalar(@cards) == 2);
224              
225 0         0 push @{$self->{bank}}, [@cards];
  0         0  
226             }
227              
228             sub _process {
229 0     0   0 my ($self, $card, $new) = @_;
230              
231 0         0 $self->{deck}->{$new->index} = undef;
232 0         0 $self->{deck}->{$card->index} = undef;
233 0         0 $self->_save($card, $new);
234              
235 0     0   0 my $index = first_index { $_ == $new->index } @{$self->{available}};
  0         0  
  0         0  
236 0 0       0 splice(@{$self->{available}}, $index, 1) if ($index != -1);
  0         0  
237              
238 0     0   0 $index = first_index { $_ == $card->index } @{$self->{available}};
  0         0  
  0         0  
239 0 0       0 splice(@{$self->{available}}, $index, 1) if ($index != -1);
  0         0  
240             }
241              
242             sub _index {
243 2     2   7 my ($self, $cards) = @_;
244              
245 2         3 $cards = [shuffle @{$cards}];
  2         44  
246 2         6 my $index = 0;
247 2         4 foreach my $card (@{$cards}) {
  2         5  
248 24         332 $card->index($index);
249 24         484 $self->{deck}->{$index} = $card;
250 24         29 $index++;
251 24 100       60 last if ($self->cards == $index);
252             }
253             }
254              
255             sub _draw {
256 0     0     my ($self) = @_;
257              
258 0           my @random = shuffle(@{$self->{available}});
  0            
259 0           my $index = shift @random;
260              
261 0 0         return $self->{deck}->{$index} if defined $index;
262 0           return;
263             }
264              
265             sub _seen :Memoize {
266 0         0 my ($self, $card) = @_;
267              
268 0         0 my $index = 0;
269 0         0 foreach (@{$self->{seen}}) {
  0         0  
270 0 0       0 if ($card->equal($_)) {
271 0         0 splice(@{$self->{seen}}, $index, 1);
  0         0  
272 0         0 return $_;
273             }
274 0         0 $index++;
275             }
276              
277 0         0 return;
278 3     3   4101 }
  3         6  
  3         23  
279              
280             =head1 AUTHOR
281              
282             Mohammad S Anwar, C<< >>
283              
284             =head1 REPOSITORY
285              
286             L
287              
288             =head1 BUGS
289              
290             Please report any bugs / feature requests to C
291             or through the web interface at L.
292             I will be notified and then you'll automatically be notified of progress on your
293             bug as I make changes.
294              
295             =head1 SUPPORT
296              
297             You can find documentation for this module with the perldoc command.
298              
299             perldoc Games::Cards::Pair
300              
301             You can also look for information at:
302              
303             =over 4
304              
305             =item * RT: CPAN's request tracker (report bugs here)
306              
307             L
308              
309             =item * AnnoCPAN: Annotated CPAN documentation
310              
311             L
312              
313             =item * CPAN Ratings
314              
315             L
316              
317             =item * Search CPAN
318              
319             L
320              
321             =back
322              
323             =head1 LICENSE AND COPYRIGHT
324              
325             Copyright (C) 2012 - 2016 Mohammad S Anwar.
326              
327             This program is free software; you can redistribute it and / or modify it under
328             the terms of the the Artistic License (2.0). You may obtain a copy of the full
329             license at:
330              
331             L
332              
333             Any use, modification, and distribution of the Standard or Modified Versions is
334             governed by this Artistic License.By using, modifying or distributing the Package,
335             you accept this license. Do not use, modify, or distribute the Package, if you do
336             not accept this license.
337              
338             If your Modified Version has been derived from a Modified Version made by someone
339             other than you,you are nevertheless required to ensure that your Modified Version
340             complies with the requirements of this license.
341              
342             This license does not grant you the right to use any trademark, service mark,
343             tradename, or logo of the Copyright Holder.
344              
345             This license includes the non-exclusive, worldwide, free-of-charge patent license
346             to make, have made, use, offer to sell, sell, import and otherwise transfer the
347             Package with respect to any patent claims licensable by the Copyright Holder that
348             are necessarily infringed by the Package. If you institute patent litigation
349             (including a cross-claim or counterclaim) against any party alleging that the
350             Package constitutes direct or contributory patent infringement,then this Artistic
351             License to you shall terminate on the date that such litigation is filed.
352              
353             Disclaimer of Warranty: THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER AND
354             CONTRIBUTORS "AS IS' AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES. THE IMPLIED
355             WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, OR
356             NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY YOUR LOCAL LAW. UNLESS
357             REQUIRED BY LAW, NO COPYRIGHT HOLDER OR CONTRIBUTOR WILL BE LIABLE FOR ANY DIRECT,
358             INDIRECT, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING IN ANY WAY OUT OF THE USE
359             OF THE PACKAGE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
360              
361             =cut
362              
363             1; # End of Games::Cards::Pair