Rules.pm (3776B) [raw]
1 # Euchre::Rules -- the core Game Logic 2 # 3 # (previously called Euchre::Game before the great(?) OOP refactor) 4 use strict; 5 use warnings; 6 7 package Euchre::Rules; 8 9 require Exporter; 10 our @ISA = qw(Exporter); 11 our @EXPORT = qw( 12 deal 13 trick_winner 14 score_round 15 card_value 16 ); 17 18 use List::Util qw(shuffle); 19 20 # Numeric values for trick_winner 21 our %SUIT_VALS = (H => 0, D => 1, S => 2, C => 3); 22 our %CARD_VALS = (N => 0, T => 1, J => 2, Q => 3, K => 4, A => 5); 23 24 our @FULL_DECK = qw( 25 NH TH JH QH KH AH 26 ND TD JD QD KD AD 27 NS TS JS QS KS AS 28 NC TC JC QC KC AC 29 ); 30 31 sub raw_card_value { 32 my ($c) = @_; 33 if ($c eq 'X') { 34 return -1; 35 } 36 my ($val, $suit) = split('', $c); 37 return (6 * $SUIT_VALS{$suit} + $CARD_VALS{$val}); 38 } 39 40 sub card_value { 41 my ($c, $trump, $led) = @_; 42 43 # Lower to numeric value 44 my $cval = raw_card_value($c); 45 46 return $cval if $cval < 0; 47 48 # If neither trump or led defined, we just use raw_value 49 # (useful for initial deal hand orderings) 50 return $cval unless defined $trump; 51 52 # Gather more data on it 53 $trump = $SUIT_VALS{$trump}; 54 my $suit = int($cval / 6); 55 my $is_jack = ($cval % 6 == 2); 56 my $is_trump = ($suit == $trump); 57 my $is_tcolor = (int($suit / 2) == int($trump / 2)); 58 my $is_bower = ($is_jack && $is_tcolor); 59 60 # To create a absolute ordering we give 61 # +50 -- all bowers 62 # +25 -- all trump (not incl. J of color) 63 # +0 -- all others (use raw value) 64 $cval += 50 if $is_bower; 65 $cval += 25 if $is_trump; 66 67 # If we are ranking based on suit led, all throwoffs are 68 # considered value 0 69 # NOTE: not always defined, i.e. when sorting hand 70 if (defined $led) { 71 $led = $SUIT_VALS{$led}; 72 if ($suit != $led && !($is_trump || $is_bower)) { 73 # throwoff -> set value to zero 74 $cval = 0; 75 } 76 } 77 78 return $cval; 79 } 80 81 sub deal { 82 my @cards = shuffle @FULL_DECK; 83 84 my @hands; 85 for (my $i = 0; $i < 4; $i++) { 86 push @{$hands[$i]}, @cards[((5*$i) .. (5*($i+1)-1))]; 87 } 88 my @kiddey = @cards[20 .. 23]; 89 90 return \@hands, \@kiddey; 91 } 92 93 # This is the only sub left that uses the original numeric 94 # approach to tracking cards, due to the convenience of 95 # sorting by a numeric value. To provide a consistent interace, 96 # it takes in the character representations, but immediately 97 # "lowers" them to the integer counterparts 98 # 99 # 0 1 2 3 4 5 100 # Suits: H D S C 101 # Cards: N T J Q K A 102 # 103 # A card of 'X' denotes a loner 104 sub trick_winner { 105 my ($trump, $led, @cards) = @_; 106 107 my @values = map { card_value($_, $trump, $led) } @cards; 108 109 my $winning_ind = -1; 110 my $winning_val = -1; 111 for (my $i = 0; $i < @values; $i++) { 112 if ($values[$i] > $winning_val) { 113 $winning_ind = $i; 114 $winning_val = $values[$i]; 115 } 116 } 117 118 return $winning_ind; 119 } 120 121 # Given # tricks per player, who won? What score? 122 # Use X to indicate sat-out. $caller is a seat_no 123 # Returns idx of team, points to give 124 sub score_round { 125 my ($caller, @tricks) = @_; 126 127 my $callers = $caller % 2; 128 my $setters = 1 - $callers; 129 my $loner = 0; 130 my @totals; 131 for (my $i = 0; $i < 4; $i++) { 132 if ($tricks[$i] eq 'X') { 133 $loner = 1; 134 } else { 135 $totals[$i % 2] += $tricks[$i]; 136 } 137 } 138 139 if ($totals[$callers] == 5) { 140 if ($loner) { 141 # Hot diggity dog! 142 return $callers, 4; 143 } else { 144 # Respectable 145 return $callers, 2; 146 } 147 } elsif($totals[$callers] > $totals[$setters]) { 148 # Made your point... 149 return $callers, 1; 150 } else { 151 # We've been Euched, Bill! 152 return $setters, 2; 153 } 154 155 die 'assert'; 156 } 157 158 1;