File Coverage

blib/lib/Games/Domino.pm
Criterion Covered Total %
statement 73 244 29.9
branch 4 60 6.6
condition 0 12 0.0
subroutine 17 35 48.5
pod 8 13 61.5
total 102 364 28.0


line stmt bran cond sub pod time code
1             package Games::Domino;
2              
3             $Games::Domino::VERSION = '0.30';
4             $Games::Domino::AUTHORITY = 'cpan:MANWAR';
5              
6             =head1 NAME
7              
8             Games::Domino - Interface to the Domino game.
9              
10             =head1 VERSION
11              
12             Version 0.30
13              
14             =cut
15              
16 4     4   20021 use 5.006;
  4         15  
17 4     4   2150 use Data::Dumper;
  4         30785  
  4         236  
18 4     4   1740 use Term::ReadKey;
  4         6832  
  4         303  
19 4     4   1756 use Term::Screen::Lite;
  4         92455  
  4         133  
20 4     4   29 use List::Util qw(shuffle);
  4         8  
  4         294  
21 4     4   1382 use Term::ANSIColor::Markup;
  4         43839  
  4         21  
22              
23 4     4   1539 use Games::Domino::Tile;
  4         17  
  4         118  
24 4     4   1428 use Games::Domino::Player;
  4         12  
  4         172  
25 4     4   31 use Games::Domino::Params qw(ZeroOrOne ZeroToSix);
  4         10  
  4         19  
26              
27 4     4   1515 use Moo;
  4         9  
  4         16  
28 4     4   1146 use namespace::clean;
  4         7  
  4         16  
29              
30 4     4   1320 use overload q{""} => 'as_string', fallback => 1;
  4         7  
  4         17  
31              
32             has 'stock' => (is => 'rw');
33             has 'board' => (is => 'rw');
34             has 'human' => (is => 'rw');
35             has 'computer' => (is => 'rw');
36             has 'current' => (is => 'rw');
37             has 'board_l' => (is => 'rw', isa => ZeroToSix);
38             has 'board_r' => (is => 'rw', isa => ZeroToSix);
39             has 'cheat' => (is => 'ro', isa => ZeroOrOne, default => sub { 0 });
40             has 'debug' => (is => 'rw', isa => ZeroOrOne, default => sub { 0 });
41             has 'action' => (is => 'rw', default => sub { [] });
42             has 'screen' => (is => 'ro', default => sub { Term::Screen::Lite->new; });
43              
44             =head1 DESCRIPTION
45              
46             This is a very basic Domino game played by two players (Computer vs Human) at the
47             moment. This is just an initial draft of Proof of Concept, also to get my head
48             around the game which I have never played in my life before.There is a cheat flag
49             which makes tiles for "Computer" visible to the other player "Human". Avoid this
50             flag if possible.By default the cheat flag is turned off.There is verbose switch
51             as well which is turned off by default. They are arranged like here before we
52             shuffle to start the the game.
53              
54             [0 | 0]
55             [0 | 1] [1 | 1]
56             [0 | 2] [1 | 2] [2 | 2]
57             [0 | 3] [1 | 3] [2 | 3] [3 | 3]
58             [0 | 4] [1 | 4] [2 | 4] [3 | 4] [4 | 4]
59             [0 | 5] [1 | 5] [2 | 5] [3 | 5] [4 | 5] [5 | 5]
60             [0 | 6] [1 | 6] [2 | 6] [3 | 6] [4 | 6] [5 | 6] [6 | 6]
61              
62             =head1 SYNOPSIS
63              
64             Below is the working code for the Domino game using the L package.
65             The game script C is supplied with the distribution and on install,
66             is available to play with.
67              
68             USAGE: play-domino [-h] [long options...]
69              
70             --verbose Play the game in verbose mode.
71             --cheat Play the game in cheat mode.
72              
73             --usage show a short help message
74             -h show a compact help message
75             --help show a long help message
76             --man show the manual
77              
78             =cut
79              
80             sub BUILD {
81 1     1 0 42 my ($self) = @_;
82              
83 1         9 $self->{human} = Games::Domino::Player->new({ name => 'H', show => 1 });
84 1 50       54 if ($self->cheat) {
85 0         0 $self->{computer} = Games::Domino::Player->new({ name => 'C', show => 1 });
86             }
87             else {
88 1         16 $self->{computer} = Games::Domino::Player->new({ name => 'C' });
89             }
90              
91 1         5 $self->_init;
92             }
93              
94             =head1 METHODS
95              
96             =head2 play()
97              
98             Pick a tile from the current player. If no matching tile found then picks it from
99             the stock until it found one or the stock has only 2 tiles left at that time the
100             game is over.
101              
102             =cut
103              
104             sub play {
105 0     0 1 0 my ($self, $index) = @_;
106              
107 0         0 my $player = $self->current;
108 0         0 my $name = $player->name;
109              
110 0 0       0 if (defined $index) {
111 0 0       0 if ($index =~ /^B$/i) {
112 0         0 $self->_pick_from_bank($player);
113             }
114             else {
115 0         0 my $tile = $player->_tile($index);
116 0 0       0 print {*STDOUT} "[H] [P]: $tile [S]\n" if $self->debug;
  0         0  
117 0         0 splice(@{$player->{bank}}, $index-1, 1);
  0         0  
118 0         0 $self->_save($tile);
119             }
120             }
121             else {
122 0         0 my $tile = $player->pick($self->board_l, $self->board_r);
123 0 0       0 if (defined $tile) {
124 0 0       0 print {*STDOUT} "[C] [P]: $tile [S]\n" if $self->debug;
  0         0  
125 0         0 $self->_save($tile);
126             }
127             else {
128 0         0 $self->_pick_from_bank($player);
129             }
130             }
131             }
132              
133             =head2 get_available_tiles()
134              
135             Returns all available tile's index.
136              
137             =cut
138              
139             sub get_available_tiles {
140 0     0 1 0 my ($self) = @_;
141              
142 0         0 return $self->current->_available_indexes;
143             }
144              
145             =head2 is_valid_tile($index)
146              
147             Return 1/0 depending on whether the tile at the given C<$index> is valid or not.
148              
149             =cut
150              
151             sub is_valid_tile {
152 0     0 1 0 my ($self, $index) = @_;
153              
154 0   0     0 return (defined($index)
155             && (($index =~ /^B$/i)
156             ||
157             ($self->current->_validate_index($index)
158             && $self->current->_validate_tile($index, $self->board_l, $self->board_r))
159             ));
160             }
161              
162             =head2 is_over()
163              
164             Returns 1 or 0 depending whether the game is over or not.The game can be declared
165             over in the following circumstances:
166              
167             =over 2
168              
169             =item * Any one of the two players have used all his tiles.
170              
171             =item * There are only two (2) tiles left in the bank.
172              
173             =back
174              
175             =cut
176              
177             sub is_over {
178 0     0 1 0 my ($self) = @_;
179              
180             return ((scalar(@{$self->{stock}}) == 2)
181             ||
182             (scalar(@{$self->{human}->{bank}}) == 0)
183             ||
184 0   0     0 (scalar(@{$self->{computer}->{bank}}) == 0));
185             }
186              
187             =head2 result()
188              
189             Declares who is the winner against whom and by how much margin.
190              
191             =cut
192              
193             sub result {
194 0     0 1 0 my ($self) = @_;
195              
196 0         0 my ($result);
197 0 0       0 if (scalar(@{$self->stock}) == 2) {
  0         0  
198 0         0 my $c_b = scalar(@{$self->computer->bank});
  0         0  
199 0         0 my $h_b = scalar(@{$self->human->bank});
  0         0  
200 0         0 my $msg = 'Bank has only 2 tiles left. ';
201 0 0       0 if ($c_b < $h_b) {
    0          
202 0         0 $result = $self->_result("${msg}. Therefore, computer is declared the winner, having less tiles than you.", $c_b, $h_b);
203             }
204             elsif ($c_b > $h_b) {
205 0         0 $result = $self->_result("${msg}. Therefore, you are declared the winner, having less tiles than computer.", $h_b, $c_b);
206             }
207             else {
208 0         0 $result = $self->_result('${msg}. Therefore, game is declared draw as both players have the same number of tiles.', $h_b, $c_b);
209             }
210             }
211             else {
212 0         0 my $h = $self->human->value;
213 0         0 my $c = $self->computer->value;
214              
215 0 0       0 if (scalar(@{$self->human->bank}) == 0) {
  0 0       0  
216 0         0 $result = $self->_result('Congratulation, you are the winner as you have no tiles left.', $h, $c);
217             }
218 0         0 elsif (scalar(@{$self->computer->bank}) == 0) {
219 0         0 $result = $self->_result('Sorry, computer is the winner as it has no tiles left.', $c, $h);
220             }
221             else {
222 0 0       0 if ($h < $c) {
    0          
223 0         0 $result = $self->_result('Congratulation, you are the winner as your remaining tiles value is less than computer.', $h, $c);
224             }
225             elsif ($h > $c) {
226 0         0 $result = $self->_result('Sorry, computer is the winner as it\'s remaining tiles value is less than yours.', $c, $h);
227             }
228             else {
229 0         0 $result = $self->_result('Game is declared draw as both the players reamaining tiles value is the same.', $c, $h);
230             }
231             }
232             }
233              
234 0 0       0 if ($self->debug) {
235 0         0 $result = sprintf("STOCK : %s\n%s", $self->as_string, $result);
236             }
237              
238 0         0 return Term::ANSIColor::Markup->colorize($result);
239             }
240              
241             =head2 show()
242              
243             Returns the current state of the game.
244              
245             =cut
246              
247             sub show {
248 0     0 1 0 my ($self) = @_;
249              
250 0         0 my $game = sprintf("%s\n", $self->_line);
251 0         0 $game .= sprintf("[C]: %s\n", $self->computer->as_string);
252 0         0 $game .= sprintf("[H]: %s\n", $self->human->as_string);
253 0         0 $game .= "[G]: " . $self->_board . "\n";
254 0         0 $game .= sprintf("%s", $self->_line);
255              
256 0         0 return $game;
257             }
258              
259             =head2 reset()
260              
261             Reset the game.
262              
263             =cut
264              
265             sub reset {
266 0     0 1 0 my ($self) = @_;
267              
268 0         0 $self->human->reset;
269 0         0 $self->computer->reset;
270 0         0 $self->_init;
271             }
272              
273             =head2 as_string()
274              
275             Returns all the unused tiles remained in the bank.
276              
277             =cut
278              
279             sub as_string {
280 1     1 1 42 my ($self) = @_;
281              
282 1 50       2 return '[EMPTY]' unless scalar(@{$self->{stock}});
  1         4  
283              
284 1         2 my $domino = '';
285 1         2 foreach (@{$self->{stock}}) {
  1         2  
286 14         283 $domino .= sprintf("%s==", $_);
287             }
288              
289 1         38 $domino =~ s/[\=]+\s?$//;
290 1         6 $domino =~ s/\s+$//;
291 1         4 return $domino;
292             }
293              
294             sub pause {
295 0     0 0 0 my ($self, $message) = @_;
296              
297 0 0       0 $message = "Press any key to continue..." unless defined $message;
298 0         0 print {*STDOUT} $message;
  0         0  
299              
300 0         0 $self->read_mode('cbreak');
301 0         0 ReadKey(0);
302 0         0 $self->read_mode;
303             }
304              
305             sub read_mode {
306 0     0 0 0 my ($self, $state) = @_;
307              
308 0 0       0 $state = 'normal' unless defined $state;
309 0         0 ReadMode $state;
310             }
311              
312             sub about_game {
313 0     0 0 0 my ($self) = @_;
314              
315 0         0 return qq {
316             +-------------------------------------------------------------------------------+
317             | |
318             | Games::Domino v$Games::Domino::VERSION |
319             | |
320             +-------------------------------------------------------------------------------+
321             Tiles are numbered left to right starting with 1. Symbols used in this game are:
322             [C]: Code for the computer player
323             [H]: Code for the human player
324             [P]: Personal tile
325             [B]: Tile picked from the bank
326             [S]: Successfully found the matching tile
327             [F]: Unable to find the matching tile
328             [G]: All matched tiles so far
329             +-------------------------------------------------------------------------------+
330             };
331             }
332              
333             sub how_to_play {
334 0     0 0 0 my ($self) = @_;
335              
336 0         0 return qq {
337             Example:
338              
339             [C] [P]: [5 | 6] [S]
340             Computer picked the tile [5 | 6] from his own collection and successfully found
341             the matching on board.
342              
343             [H] [P]: [6 | 6] [S]
344             Human picked the tile [6 | 6] from his own collection and successfully found the
345             matching on board.
346              
347             [C] [B]: [2 | 6] [S]
348             Computer randomly picked the tile [2 | 6] from the bank and successfully found the
349             matching on board.
350              
351             [C] [B]: [3 | 4] [F]
352             Computer randomly picked the tile [3 | 4] from the bank and but failed to find the
353             matching on board.
354              
355             [H] [B]: [2 | 2] [S]
356             Human randomly picked the tile [2 | 2] from the bank and successfully found the
357             matching on board.
358              
359             [H] [B]: [3 | 6] [F]
360             Human randomly picked the tile [3 | 6] from the bank and but failed to find the
361             matching on board.
362             +-------------------------------------------------------------------------------+
363             };
364             }
365              
366             #
367             #
368             # PRIVATE METHODS
369              
370             sub _pick_from_bank {
371 0     0   0 my ($self, $player) = @_;
372              
373 0         0 my $name = $player->name;
374 0         0 while (scalar(@{$self->{stock}}) > 2) {
  0         0  
375 0         0 my $_tile = $self->_pick();
376 0         0 $player->save($_tile);
377 0         0 my $tile = $player->pick($self->board_l, $self->board_r);
378 0 0       0 if (defined $tile) {
379 0 0       0 print {*STDOUT} "[$name] [B]: $tile [S]\n" if $self->debug;
  0         0  
380 0         0 $self->_save($tile);
381 0         0 last;
382             }
383             else {
384 0 0       0 print {*STDOUT} "[$name] [B]: $_tile [F]\n" if $self->debug;
  0         0  
385             }
386             }
387             }
388              
389             sub _save {
390 0     0   0 my ($self, $tile) = @_;
391              
392 0 0 0     0 if (!defined($self->{board}) || (scalar(@{$self->{board}}) == 0)) {
  0         0  
393 0         0 push @{$self->{board}}, $tile;
  0         0  
394 0         0 $self->{board_l} = $tile->left;
395 0         0 $self->{board_r} = $tile->right;
396 0         0 $self->_action($tile);
397 0         0 $self->_next;
398 0         0 return;
399             }
400              
401 0 0       0 if ($self->{board_r} == $tile->left) {
    0          
402 0         0 push @{$self->{board}}, $tile;
  0         0  
403 0         0 $self->{board_r} = $tile->right;
404 0         0 $self->_action($tile);
405 0         0 $self->_next;
406 0         0 return;
407              
408             }
409             elsif ($self->{board_r} == $tile->right) {
410 0         0 my $L = $tile->left;
411 0         0 my $R = $tile->right;
412 0         0 $tile->right($L);
413 0         0 $tile->left($R);
414 0         0 push @{$self->{board}}, $tile;
  0         0  
415 0         0 $self->{board_r} = $L;
416 0         0 $self->_action($tile);
417 0         0 $self->_next;
418 0         0 return;
419             }
420              
421 0 0       0 if ($self->{board_l} == $tile->left) {
    0          
422 0         0 my $L = $tile->left;
423 0         0 my $R = $tile->right;
424 0         0 $tile->right($L);
425 0         0 $tile->left($R);
426 0         0 unshift @{$self->{board}}, $tile;
  0         0  
427 0         0 $self->{board_l} = $R;
428 0         0 $self->_action($tile);
429 0         0 $self->_next;
430 0         0 return;
431             }
432             elsif ($self->{board_l} == $tile->right) {
433 0         0 unshift @{$self->{board}}, $tile;
  0         0  
434 0         0 $self->{board_l} = $tile->left;
435 0         0 $self->_action($tile);
436 0         0 $self->_next;
437 0         0 return;
438             }
439              
440 0         0 return;
441             }
442              
443             sub _action {
444 0     0   0 my ($self, $tile) = @_;
445              
446 0 0 0     0 if (defined $self->{action} && scalar(@{$self->{action}}) == 2) {
  0         0  
447 0         0 foreach (@{$self->board}) {
  0         0  
448 0         0 $_->color('blue');
449             }
450 0         0 $self->{action} = [ $tile ];
451             }
452             else {
453 0         0 push @{$self->{action}}, $tile;
  0         0  
454             }
455              
456 0 0       0 if ($self->current->name eq 'H') {
457 0         0 $tile->color('green');
458             }
459             else {
460 0         0 $tile->color('red');
461             }
462             }
463              
464             sub _board {
465 0     0   0 my ($self) = @_;
466              
467 0         0 my $board = '';
468 0 0       0 if (scalar(@{$self->board})) {
  0         0  
469 0         0 foreach (@{$self->board}) {
  0         0  
470 0         0 $board .= sprintf("<%s>%s<\/%s>==", $_->color, $_, $_->color);
471             }
472             }
473             else {
474 0         0 $board .= 'EMPTY';
475             }
476              
477 0         0 $board =~ s/[\=]+\s?$//;
478 0         0 $board =~ s/\s+$//;
479 0         0 return Term::ANSIColor::Markup->colorize($board);
480             }
481              
482             sub _result {
483 0     0   0 my ($self, $title, $a, $b) = @_;
484              
485 0         0 my $result = sprintf("%s ", $title);
486 0         0 $result .= sprintf("Final score [%d", $a);
487 0         0 $result .= sprintf("] against [%d", $b);
488 0         0 $result .= '].';
489              
490 0         0 return $result;
491             }
492              
493             sub _line {
494 0     0   0 my ($self) = @_;
495              
496 0         0 return "="x81;
497             }
498              
499             sub _init {
500 1     1   3 my ($self) = @_;
501              
502 1         4 $self->{stock} = $self->_prepare();
503 1         4 $self->{board} = [];
504 1         7 $self->{human}->save($self->_pick) for (1..7);
505 1         8 $self->{computer}->save($self->_pick) for (1..7);
506 1         9 $self->{current} = $self->{human};
507             }
508              
509             sub _pick {
510 14     14   26 my ($self) = @_;
511              
512 14         16 return shift @{$self->{stock}};
  14         35  
513             }
514              
515             sub _prepare {
516 1     1   2 my ($self) = @_;
517              
518 1         2 my $tiles = [];
519 1         9 my $tile = Games::Domino::Tile->new({ left => 0, right => 0, double => 1 });
520 1         23 push @$tiles, $tile;
521 1         4 foreach my $R (1..6) {
522 6         10 my $L = 0;
523 6         8 my $D = 0;
524 6         12 while ($R >= $L) {
525 27 100       57 ($R == $L)?($D = 1):($D = 0);
526 27         392 push @$tiles, Games::Domino::Tile->new({ left => $L, right => $R, double => $D });
527 27         629 $L++;
528             }
529             }
530              
531 1         2 $tiles = [shuffle @{$tiles}];
  1         41  
532 1         6 return $tiles;
533             }
534              
535             sub _next {
536 0     0     my ($self) = @_;
537              
538 0 0         if ($self->current->name eq 'H') {
539 0           $self->current($self->computer);
540             }
541             else {
542 0           $self->current($self->human);
543             }
544             }
545              
546             =head1 AUTHOR
547              
548             Mohammad S Anwar, C<< >>
549              
550             =head1 REPOSITORY
551              
552             L
553              
554             =head1 BUGS
555              
556             Please report any bugs or feature requests to C,
557             or through the web interface at L.
558             I will be notified, and then you'll automatically be notified of progress on your
559             bug as I make changes.
560              
561             =head1 SUPPORT
562              
563             You can find documentation for this module with the perldoc command.
564              
565             perldoc Games::Domino
566              
567             You can also look for information at:
568              
569             =over 4
570              
571             =item * RT: CPAN's request tracker (report bugs here)
572              
573             L
574              
575             =item * AnnoCPAN: Annotated CPAN documentation
576              
577             L
578              
579             =item * CPAN Ratings
580              
581             L
582              
583             =item * Search CPAN
584              
585             L
586              
587             =back
588              
589             =head1 LICENSE AND COPYRIGHT
590              
591             Copyright 2012 - 2016 Mohammad S Anwar.
592              
593             This program is free software; you can redistribute it and / or modify it under
594             the terms of the the Artistic License (2.0). You may obtain a copy of the full
595             license at:
596              
597             L
598              
599             Any use, modification, and distribution of the Standard or Modified Versions is
600             governed by this Artistic License.By using, modifying or distributing the Package,
601             you accept this license. Do not use, modify, or distribute the Package, if you do
602             not accept this license.
603              
604             If your Modified Version has been derived from a Modified Version made by someone
605             other than you,you are nevertheless required to ensure that your Modified Version
606             complies with the requirements of this license.
607              
608             This license does not grant you the right to use any trademark, service mark,
609             tradename, or logo of the Copyright Holder.
610              
611             This license includes the non-exclusive, worldwide, free-of-charge patent license
612             to make, have made, use, offer to sell, sell, import and otherwise transfer the
613             Package with respect to any patent claims licensable by the Copyright Holder that
614             are necessarily infringed by the Package. If you institute patent litigation
615             (including a cross-claim or counterclaim) against any party alleging that the
616             Package constitutes direct or contributory patent infringement,then this Artistic
617             License to you shall terminate on the date that such litigation is filed.
618              
619             Disclaimer of Warranty: THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER AND
620             CONTRIBUTORS "AS IS' AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES. THE IMPLIED
621             WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, OR
622             NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY YOUR LOCAL LAW. UNLESS
623             REQUIRED BY LAW, NO COPYRIGHT HOLDER OR CONTRIBUTOR WILL BE LIABLE FOR ANY DIRECT,
624             INDIRECT, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING IN ANY WAY OUT OF THE USE
625             OF THE PACKAGE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
626              
627             =cut
628              
629             1; # End of Games::Domino