File Coverage

blib/lib/Poker/Score/LowA5.pm
Criterion Covered Total %
statement 4 6 66.6
branch n/a
condition n/a
subroutine 2 2 100.0
pod n/a
total 6 8 75.0


line stmt bran cond sub pod time code
1             package Poker::Score::LowA5;
2 1     1   1891 use Moo;
  1         2  
  1         7  
3 1     1   653 use Algorithm::Combinatorics qw(combinations);
  0            
  0            
4              
5             =head1 NAME
6              
7             Poker::Score::LowA5 - Identify and score lowball A-5 poker hand.
8              
9             =head1 VERSION
10              
11             Version 0.01
12              
13             =cut
14              
15             our $VERSION = '0.01';
16              
17             =head1 INTRODUCTION
18              
19             Straights and flushes do not affect the strengh of your hand and Aces always play low.
20              
21             =head1 SYNOPSIS
22              
23             See Poker::Score for code example.
24              
25             =cut
26              
27             extends 'Poker::Score';
28              
29             sub _build_rank_map {
30             my $self = shift;
31             $self->_rank_map({
32             'A' => '01',
33             '2' => '02',
34             '3' => '03',
35             '4' => '04',
36             '5' => '05',
37             '6' => '06',
38             '7' => '07',
39             '8' => '08',
40             '9' => '09',
41             'T' => '10',
42             'J' => '11',
43             'Q' => '12',
44             'K' => '13',
45             });
46             }
47              
48             sub _build_hands { # generates all possible lowA5 hands
49             my $self = shift;
50             my %map = ( 1 => 'Five-of-a-Kind' );
51             my @hands = @{ $self->fives };
52             $map{ $#hands } = 'Four-of-a-Kind';
53             push(@hands, @{ $self->fours });
54             $map{ $#hands } = 'a Full House';
55             push(@hands, @{ $self->houses });
56             $map{ $#hands } = 'Three-of-a-Kind';
57             push(@hands, @{ $self->threes });
58             $map{ $#hands } = 'Two Pair';
59             push(@hands, @{ $self->two_pair });
60             $map{ $#hands } = 'One Pair';
61             push(@hands, @{ $self->one_pair });
62             $map{ $#hands } = 'a High Card';
63             push(@hands, @{ $self->unpaired });
64             $self->hands( [ @hands ] );
65             $self->_hand_map( \%map );
66             }
67              
68             sub unpaired {
69             my $self = shift;
70             my @scores;
71             my $iter = combinations([1..13], 5);
72             while (my $c = $iter->next) {
73             push( @scores, join( "", map { sprintf("%02d", $_) } sort { $b <=> $a } @$c ) );
74             }
75             #$self->hands([ sort { $b <=> $a } @scores ]);
76             return [ sort { $b <=> $a } @scores ];
77             }
78              
79             # one pair
80             sub one_pair {
81             my @temp;
82             for my $card ( 1 .. 13 ) {
83             for my $c (
84             reverse combinations( [ reverse grep { $_ != $card } ( 1 .. 13 ) ], 3 ) )
85             #reverse combinations( [ grep { $_ != $card } ( 1 .. 13 ) ], 3 ) )
86             {
87             push @temp,
88             join( '',
89             map { sprintf( "%02d", $_ ) }
90             sort { $b <=> $a } ( ($card) x 2, @$c ) );
91             }
92             }
93             return [reverse @temp];
94             }
95              
96             # two pair
97             sub two_pair {
98             my @temp;
99             for my $c ( reverse combinations( [ reverse( 1 .. 13 ) ], 2 ) ) {
100             for my $card ( grep { $_ != $c->[0] && $_ != $c->[1] } ( 1 .. 13 ) ) {
101             push @temp,
102             join( '',
103             map { sprintf( "%02d", $_ ) }
104             sort { $b <=> $a } ( ( $c->[0] ) x 2, ( $c->[1] ) x 2, $card ) );
105             }
106             }
107             return [reverse @temp];
108             }
109              
110             # three-of-a-kind
111             sub threes {
112             my @temp;
113             for my $card ( 1 .. 13 ) {
114             for my $c (
115             reverse combinations( [ reverse grep { $_ != $card } ( 1 .. 13 ) ], 2 ) )
116             {
117             push @temp, join(
118             '',
119             map { sprintf( "%02d", $_ ) }
120              
121             sort { $b <=> $a } ($card) x 3, @$c
122             );
123             }
124             }
125             return [reverse @temp];
126             }
127              
128             # full house
129             sub houses {
130             my @temp;
131             for my $card1 ( 1 .. 13 ) {
132             for my $card2 ( grep { $_ != $card1 } ( 1 .. 13 ) ) {
133             push @temp,
134             join( '',
135             map { sprintf( "%02d", $_ ) }
136             sort { $b <=> $a } ( ($card1) x 3, ($card2) x 2 ) );
137             }
138             }
139             return [reverse @temp];
140             }
141              
142             # four-of-a-kind
143             sub fours {
144             my @temp;
145             for my $card1 ( 1 .. 13 ) {
146             for my $card2 ( grep { $_ != $card1 } ( 1 .. 13 ) ) {
147             push @temp,
148             join( '',
149             map { sprintf( "%02d", $_ ) }
150             sort { $b <=> $a } ( ($card1) x 4, $card2 ) );
151             }
152             }
153             return [reverse @temp];
154             }
155              
156             # five-of-a-kind
157             sub fives {
158             my @temp;
159             for my $card ( 1 .. 13 ) {
160             push @temp,
161             join( '',
162             map { sprintf( "%02d", $_ ) }
163             ($card) x 5);
164             }
165             return [reverse @temp];
166             }
167              
168             =head1 AUTHOR
169              
170             Nathaniel Graham, C<< >>
171              
172             =head1 LICENSE AND COPYRIGHT
173              
174             Copyright 2016 Nathaniel Graham.
175              
176             This program is free software; you can redistribute it and/or modify it
177             under the terms of the the Artistic License (2.0). You may obtain a
178             copy of the full license at:
179              
180             L
181              
182             =cut
183              
184             1;