File Coverage

blib/lib/Poker/Score.pm
Criterion Covered Total %
statement 9 47 19.1
branch 0 4 0.0
condition n/a
subroutine 3 14 21.4
pod 2 7 28.5
total 14 72 19.4


line stmt bran cond sub pod time code
1             package Poker::Score;
2 1     1   1710 use strict;
  1         2  
  1         28  
3 1     1   6 use warnings FATAL => 'all';
  1         1  
  1         34  
4 1     1   5 use Moo;
  1         1  
  1         6  
5              
6             =head1 NAME
7              
8             Poker::Score - Identify and score specific poker hands. Base class for specific scoring systems.
9              
10             =head1 VERSION
11              
12             Version 0.01
13              
14             =cut
15              
16             our $VERSION = '0.01';
17              
18             =head1 SYNOPSIS
19            
20             # This is just a base class. Poker::Score::High shows a real example.
21              
22             use Poker::Score::High; #standard highball
23             use Poker::Dealer;
24             use feature qw(say);
25              
26             # Create highball score object
27             my $scorer = Poker::Score::High->new;
28              
29             # Create dealer, shuffle deck and deal out five cards
30             my $dealer = Poker::Dealer->new;
31             $dealer->shuffle_deck;
32             my $cards = $dealer->deal_up(5);
33              
34             # Numerical score of five card poker hand
35             my $score = $scorer->score($cards);
36             say $score;
37              
38             # English name of hand (e.g. 'Two Pair')
39             say $scorer->hand_name($score);
40              
41             =cut
42              
43              
44             has 'hands' => (
45             is => 'rw',
46             isa => sub { die "Not an array_ref!" unless ref( $_[0] ) eq 'ARRAY' },
47             default => sub { [] },
48             );
49              
50             has '_hand_lookup' => (
51             is => 'rw',
52             isa => sub { die "Not an hash_ref!" unless ref( $_[0] ) eq 'HASH' },
53             init_arg => undef,
54             );
55              
56             has '_hand_map' => (
57             is => 'rw',
58             isa => sub { die "Not an hash_ref!" unless ref( $_[0] ) eq 'HASH' },
59             default => sub { {} },
60             );
61              
62             has '_rank_map' => (
63             is => 'rw',
64             isa => sub { die "Not an hash_ref!" unless ref( $_[0] ) eq 'HASH' },
65             );
66              
67             sub _build_rank_map {
68 0     0     my $self = shift;
69 0           $self->_rank_map(
70             {
71             '2' => '02',
72             '3' => '03',
73             '4' => '04',
74             '5' => '05',
75             '6' => '06',
76             '7' => '07',
77             '8' => '08',
78             '9' => '09',
79             'T' => '10',
80             'J' => '11',
81             'Q' => '12',
82             'K' => '13',
83             'A' => '14',
84             }
85             );
86             }
87              
88             has '_suit_map' => (
89             is => 'rw',
90             isa => sub { die "Not an hash_ref!" unless ref( $_[0] ) eq 'HASH' },
91             );
92              
93             sub _build_suit_map {
94 0     0     my $self = shift;
95 0           $self->_suit_map(
96             {
97             'c' => '01',
98             'd' => '02',
99             'h' => '03',
100             's' => '04',
101             }
102             );
103             }
104              
105             =head1 METHODS
106              
107             =head2 hand_name
108              
109             English name of given hand (e.g., 'Two Pair')
110              
111             =cut
112              
113             sub hand_name {
114 0     0 1   my ( $self, $score ) = @_;
115 0           for my $key ( sort { $b <=> $a } keys %{ $self->_hand_map } ) {
  0            
  0            
116 0 0         if ( $score > $key ) {
117 0           return $self->_hand_map->{$key};
118             }
119             }
120             }
121              
122             sub rank_val {
123 0     0 0   my ( $self, $rank ) = @_;
124 0           return $self->_rank_map->{$rank};
125             }
126              
127             sub suit_val {
128 0     0 0   my ( $self, $suit ) = @_;
129 0           return $self->_suit_map->{$suit};
130             }
131              
132             sub hand_score {
133 0     0 0   my ( $self, $hand ) = @_;
134 0           return $self->_hand_lookup->{$hand};
135             }
136              
137             =head2 score
138              
139             Numercal score of given hand (higher is better)
140              
141             =cut
142              
143             sub score {
144 0     0 1   my ( $self, $cards ) = @_;
145 0           return $self->hand_score( $self->stringify_cards($cards) );
146             }
147              
148             sub stringify_cards {
149 0     0 0   my ( $self, $cards ) = @_;
150 0           my %suit;
151 0           for my $card (@$cards) {
152 0           $suit{ $card->suit }++;
153             }
154             my $flat = join( '',
155 0           sort { $b <=> $a }
156 0           map { sprintf( "%02d", $self->rank_val( $_->rank ) ) } @$cards );
  0            
157 0 0         $flat .= 's' if scalar keys %suit == 1;
158 0           return $flat;
159             }
160              
161             sub _build_hand_lookup {
162 0     0     my $self = shift;
163 0           my %look;
164 0           for my $i ( 0 .. $#{ $self->hands } ) {
  0            
165 0           $look{ $self->hands->[$i] } = $i;
166             }
167 0           $self->_hand_lookup( \%look );
168             }
169              
170       0     sub _build_hands { }
171              
172             sub BUILD {
173 0     0 0   my $self = shift;
174 0           $self->_build_hands;
175 0           $self->_build_hand_lookup;
176 0           $self->_build_rank_map;
177 0           $self->_build_suit_map;
178             }
179              
180             =head1 SEE ALSO
181              
182             Poker::Score::High, Poker::Score::Low8, Poker::Score::Low27, Poker::Score::LowA5, Poker::Score::Badugi, Poker::Score::Badugi27, Poker::Score::Chinese, Poker::Score::HighSuit, Poker::Score::Bring::High, Poker::Score::Bring::Low, Poker::Score::Bring::Wild
183              
184             =head1 AUTHOR
185              
186             Nathaniel Graham, C<< >>
187              
188             =head1 LICENSE AND COPYRIGHT
189              
190             Copyright 2016 Nathaniel Graham.
191              
192             This program is free software; you can redistribute it and/or modify it
193             under the terms of the the Artistic License (2.0). You may obtain a
194             copy of the full license at:
195              
196             L
197              
198             =cut
199              
200             1;