commit 2bff8330026a2dfeeb2a307b35dc2bd9dc39a018 (patch)
parent 572631e4d6e172d9c6e4c6c1e93a679607b9f964
Author: Alex Karle <alex@karle.co>
Date: Sat, 2 May 2020 16:47:32 -0400
refactor: Rename Euchre::Game -> Euchre::Rules
I'm about to embark on a large OOP refactor, and Game will be an object.
It makes sense to leave these functions as-is (not object methods), but
they should be under the name Rules to avoid confusion.
Diffstat:
| M | Makefile | | | 2 | +- |
| M | lib/Euchre/Dealer.pm | | | 2 | +- |
| D | lib/Euchre/Game.pm | | | 158 | ------------------------------------------------------------------------------- |
| A | lib/Euchre/Rules.pm | | | 158 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| D | t/Game.t | | | 84 | ------------------------------------------------------------------------------- |
| A | t/Rules.t | | | 84 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
6 files changed, 244 insertions(+), 244 deletions(-)
diff --git a/Makefile b/Makefile
@@ -8,7 +8,7 @@ tags:
.PHONY: test
test:
perl -c gloat.pl
- perl t/Game.t
+ perl t/Rules.t
.PHONY: release
release: test
diff --git a/lib/Euchre/Dealer.pm b/lib/Euchre/Dealer.pm
@@ -7,7 +7,7 @@ package Euchre::Dealer;
use Mojo::IOLoop;
use List::Util qw(sum);
-use Euchre::Game;
+use Euchre::Rules;
require Exporter;
our @ISA = qw(Exporter);
diff --git a/lib/Euchre/Game.pm b/lib/Euchre/Game.pm
@@ -1,158 +0,0 @@
-# Euchre::Game -- the Game Logic
-# All card interactions are based on ID for ~speed~
-# Leaves it to client to map from 'names' (i.e. AH -> 5)
-use strict;
-use warnings;
-
-package Euchre::Game;
-
-require Exporter;
-our @ISA = qw(Exporter);
-our @EXPORT = qw(
- deal
- trick_winner
- score_round
- card_value
-);
-
-use List::Util qw(shuffle);
-
-# Numeric values for trick_winner
-our %SUIT_VALS = (H => 0, D => 1, S => 2, C => 3);
-our %CARD_VALS = (N => 0, T => 1, J => 2, Q => 3, K => 4, A => 5);
-
-our @FULL_DECK = qw(
- NH TH JH QH KH AH
- ND TD JD QD KD AD
- NS TS JS QS KS AS
- NC TC JC QC KC AC
-);
-
-sub raw_card_value {
- my ($c) = @_;
- if ($c eq 'X') {
- return -1;
- }
- my ($val, $suit) = split('', $c);
- return (6 * $SUIT_VALS{$suit} + $CARD_VALS{$val});
-}
-
-sub card_value {
- my ($c, $trump, $led) = @_;
-
- # Lower to numeric value
- my $cval = raw_card_value($c);
-
- return $cval if $cval < 0;
-
- # If neither trump or led defined, we just use raw_value
- # (useful for initial deal hand orderings)
- return $cval unless defined $trump;
-
- # Gather more data on it
- $trump = $SUIT_VALS{$trump};
- my $suit = int($cval / 6);
- my $is_jack = ($cval % 6 == 2);
- my $is_trump = ($suit == $trump);
- my $is_tcolor = (int($suit / 2) == int($trump / 2));
- my $is_bower = ($is_jack && $is_tcolor);
-
- # To create a absolute ordering we give
- # +50 -- all bowers
- # +25 -- all trump (not incl. J of color)
- # +0 -- all others (use raw value)
- $cval += 50 if $is_bower;
- $cval += 25 if $is_trump;
-
- # If we are ranking based on suit led, all throwoffs are
- # considered value 0
- # NOTE: not always defined, i.e. when sorting hand
- if (defined $led) {
- $led = $SUIT_VALS{$led};
- if ($suit != $led && !($is_trump || $is_bower)) {
- # throwoff -> set value to zero
- $cval = 0;
- }
- }
-
- return $cval;
-}
-
-sub deal {
- my @cards = shuffle @FULL_DECK;
-
- my @hands;
- for (my $i = 0; $i < 4; $i++) {
- push @{$hands[$i]}, @cards[((5*$i) .. (5*($i+1)-1))];
- }
- my @kiddey = @cards[20 .. 23];
-
- return \@hands, \@kiddey;
-}
-
-# This is the only sub left that uses the original numeric
-# approach to tracking cards, due to the convenience of
-# sorting by a numeric value. To provide a consistent interace,
-# it takes in the character representations, but immediately
-# "lowers" them to the integer counterparts
-#
-# 0 1 2 3 4 5
-# Suits: H D S C
-# Cards: N T J Q K A
-#
-# A card of 'X' denotes a loner
-sub trick_winner {
- my ($trump, $led, @cards) = @_;
-
- my @values = map { card_value($_, $trump, $led) } @cards;
-
- my $winning_ind = -1;
- my $winning_val = -1;
- for (my $i = 0; $i < @values; $i++) {
- if ($values[$i] > $winning_val) {
- $winning_ind = $i;
- $winning_val = $values[$i];
- }
- }
-
- return $winning_ind;
-}
-
-# Given # tricks per player, who won? What score?
-# Use X to indicate sat-out. $caller is a seat_no
-# Returns idx of team, points to give
-sub score_round {
- my ($caller, @tricks) = @_;
-
- my $callers = $caller % 2;
- my $setters = 1 - $callers;
- my $loner = 0;
- my @totals;
- for (my $i = 0; $i < 4; $i++) {
- if ($tricks[$i] eq 'X') {
- $loner = 1;
- } else {
- $totals[$i % 2] += $tricks[$i];
- }
- }
-
- if ($totals[$callers] == 5) {
- if ($loner) {
- # Hot diggity dog!
- return $callers, 4;
- } else {
- # Respectable
- return $callers, 2;
- }
- } elsif($totals[$callers] > $totals[$setters]) {
- # Made your point...
- return $callers, 1;
- } else {
- # We've been Euched, Bill!
- return $setters, 2;
- }
-
- die 'assert';
-}
-
-1;
diff --git a/lib/Euchre/Rules.pm b/lib/Euchre/Rules.pm
@@ -0,0 +1,158 @@
+# Euchre::Rules -- the core Game Logic
+#
+# (previously called Euchre::Game before the great(?) OOP refactor)
+use strict;
+use warnings;
+
+package Euchre::Rules;
+
+require Exporter;
+our @ISA = qw(Exporter);
+our @EXPORT = qw(
+ deal
+ trick_winner
+ score_round
+ card_value
+);
+
+use List::Util qw(shuffle);
+
+# Numeric values for trick_winner
+our %SUIT_VALS = (H => 0, D => 1, S => 2, C => 3);
+our %CARD_VALS = (N => 0, T => 1, J => 2, Q => 3, K => 4, A => 5);
+
+our @FULL_DECK = qw(
+ NH TH JH QH KH AH
+ ND TD JD QD KD AD
+ NS TS JS QS KS AS
+ NC TC JC QC KC AC
+);
+
+sub raw_card_value {
+ my ($c) = @_;
+ if ($c eq 'X') {
+ return -1;
+ }
+ my ($val, $suit) = split('', $c);
+ return (6 * $SUIT_VALS{$suit} + $CARD_VALS{$val});
+}
+
+sub card_value {
+ my ($c, $trump, $led) = @_;
+
+ # Lower to numeric value
+ my $cval = raw_card_value($c);
+
+ return $cval if $cval < 0;
+
+ # If neither trump or led defined, we just use raw_value
+ # (useful for initial deal hand orderings)
+ return $cval unless defined $trump;
+
+ # Gather more data on it
+ $trump = $SUIT_VALS{$trump};
+ my $suit = int($cval / 6);
+ my $is_jack = ($cval % 6 == 2);
+ my $is_trump = ($suit == $trump);
+ my $is_tcolor = (int($suit / 2) == int($trump / 2));
+ my $is_bower = ($is_jack && $is_tcolor);
+
+ # To create a absolute ordering we give
+ # +50 -- all bowers
+ # +25 -- all trump (not incl. J of color)
+ # +0 -- all others (use raw value)
+ $cval += 50 if $is_bower;
+ $cval += 25 if $is_trump;
+
+ # If we are ranking based on suit led, all throwoffs are
+ # considered value 0
+ # NOTE: not always defined, i.e. when sorting hand
+ if (defined $led) {
+ $led = $SUIT_VALS{$led};
+ if ($suit != $led && !($is_trump || $is_bower)) {
+ # throwoff -> set value to zero
+ $cval = 0;
+ }
+ }
+
+ return $cval;
+}
+
+sub deal {
+ my @cards = shuffle @FULL_DECK;
+
+ my @hands;
+ for (my $i = 0; $i < 4; $i++) {
+ push @{$hands[$i]}, @cards[((5*$i) .. (5*($i+1)-1))];
+ }
+ my @kiddey = @cards[20 .. 23];
+
+ return \@hands, \@kiddey;
+}
+
+# This is the only sub left that uses the original numeric
+# approach to tracking cards, due to the convenience of
+# sorting by a numeric value. To provide a consistent interace,
+# it takes in the character representations, but immediately
+# "lowers" them to the integer counterparts
+#
+# 0 1 2 3 4 5
+# Suits: H D S C
+# Cards: N T J Q K A
+#
+# A card of 'X' denotes a loner
+sub trick_winner {
+ my ($trump, $led, @cards) = @_;
+
+ my @values = map { card_value($_, $trump, $led) } @cards;
+
+ my $winning_ind = -1;
+ my $winning_val = -1;
+ for (my $i = 0; $i < @values; $i++) {
+ if ($values[$i] > $winning_val) {
+ $winning_ind = $i;
+ $winning_val = $values[$i];
+ }
+ }
+
+ return $winning_ind;
+}
+
+# Given # tricks per player, who won? What score?
+# Use X to indicate sat-out. $caller is a seat_no
+# Returns idx of team, points to give
+sub score_round {
+ my ($caller, @tricks) = @_;
+
+ my $callers = $caller % 2;
+ my $setters = 1 - $callers;
+ my $loner = 0;
+ my @totals;
+ for (my $i = 0; $i < 4; $i++) {
+ if ($tricks[$i] eq 'X') {
+ $loner = 1;
+ } else {
+ $totals[$i % 2] += $tricks[$i];
+ }
+ }
+
+ if ($totals[$callers] == 5) {
+ if ($loner) {
+ # Hot diggity dog!
+ return $callers, 4;
+ } else {
+ # Respectable
+ return $callers, 2;
+ }
+ } elsif($totals[$callers] > $totals[$setters]) {
+ # Made your point...
+ return $callers, 1;
+ } else {
+ # We've been Euched, Bill!
+ return $setters, 2;
+ }
+
+ die 'assert';
+}
+
+1;
diff --git a/t/Game.t b/t/Game.t
@@ -1,84 +0,0 @@
-#!/usr/bin/env perl
-# Game.t -- tests for Euchre::Game
-use strict;
-use warnings;
-
-use FindBin;
-use lib "$FindBin::Bin/../lib";
-
-use Euchre::Game;
-use List::Util;
-use Test::More;
-
-sub test_deal {
- my ($handsA, $kiddey) = deal();
- is(scalar @{$handsA}, 4, '4 hands dealt');
- is(scalar @{$kiddey}, 4, '4 cards in kiddey');
-
- my @cards;
- push @cards, @{$_} for @{$handsA};
- is(scalar @cards, 20, '20 cards dealt to hands');
-
- my @all_suits = qw(H D S C);
- my @all_cards = qw(N T J Q K A);
- my @full_deck;
- for my $c (@all_cards) {
- for my $s (@all_suits) {
- push @full_deck, "$c$s";
- }
- }
-
- my @dealt = sort(@cards, @{$kiddey});
- is_deeply(\@dealt, [sort @full_deck], 'All 24 cards dealt');
-
-}
-
-sub test_trick_winner {
- my @tests = (
- # [Trump, Led, Cards], Winner Idx, Desc
- [['H', 'H', 'NH', 'TS', 'AS', 'QS'], 0, 'Trump suit led'],
- [['D', 'H', 'JH', 'TS', 'JD', 'QD'], 2, 'Jack trump beats all'],
- [['D', 'C', 'NC', 'JH', 'AD', 'AC'], 1, 'Jack color beats all others'],
- [['S', 'S', 'NS', 'JH', 'AD', 'JC'], 3, 'Jack color beats all others (2)'],
- [['S', 'H', 'NS', 'JH', 'AD', 'AH'], 0, 'Trump beats ace'],
- [['C', 'H', 'NH', 'JH', 'QH', 'AH'], 3, 'No trump, highest of led'],
- [['C', 'H', 'NH', 'JH', 'AH'], 2, 'No trump, highest of led, 3 cards'],
- [['C', 'S', 'NH', 'JH', 'AH', 'NS'], 3, 'No trump, suit led wins'],
- );
-
- for my $t (@tests) {
- my ($trump, $led, @cards) = @{$t->[0]};
- is(trick_winner($trump, $led, @cards), $t->[1], $t->[2]);
- }
-
-}
-
-sub test_score_round {
- my @tests = (
- [[0, 1,2,1,1], [1, 2], 'Euched!'],
- [[1, 2,1,1,1], [0, 2], 'Euched again!'],
- [[3, 2,3,0,0], [1,1], 'Made your point'],
- [[1, 0,3,0,2], [1,2], 'Got em all!'],
- [[0, 5,0,'X',0], [0,4], 'Loneeeer!'],
- [[2, 3,1,'X',1], [0,1], 'Failed loner'],
- );
-
- for my $t (@tests) {
- my ($winners, $points) = score_round(@{$t->[0]});
- is_deeply([$winners, $points], $t->[1], $t->[2]);
- }
-}
-
-sub test_card_value {
- ok(card_value('AH', 'H') < card_value('JH', 'H'), 'right bower highest');
- ok(card_value('AH', 'H') < card_value('JD', 'H'), 'left bower higher than ace');
- ok(card_value('JH', 'H') > card_value('JD', 'H'), 'left bower lower');
- ok(card_value('ND', 'H', 'D') > card_value('TC', 'H', 'D'), 'throwoff');
-}
-
-test_deal();
-test_trick_winner();
-test_score_round();
-test_card_value();
-
-done_testing();
diff --git a/t/Rules.t b/t/Rules.t
@@ -0,0 +1,84 @@
+#!/usr/bin/env perl
+# Rules.t -- tests for Euchre::Rules
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/../lib";
+
+use Euchre::Rules;
+use List::Util;
+use Test::More;
+
+sub test_deal {
+ my ($handsA, $kiddey) = deal();
+ is(scalar @{$handsA}, 4, '4 hands dealt');
+ is(scalar @{$kiddey}, 4, '4 cards in kiddey');
+
+ my @cards;
+ push @cards, @{$_} for @{$handsA};
+ is(scalar @cards, 20, '20 cards dealt to hands');
+
+ my @all_suits = qw(H D S C);
+ my @all_cards = qw(N T J Q K A);
+ my @full_deck;
+ for my $c (@all_cards) {
+ for my $s (@all_suits) {
+ push @full_deck, "$c$s";
+ }
+ }
+
+ my @dealt = sort(@cards, @{$kiddey});
+ is_deeply(\@dealt, [sort @full_deck], 'All 24 cards dealt');
+
+}
+
+sub test_trick_winner {
+ my @tests = (
+ # [Trump, Led, Cards], Winner Idx, Desc
+ [['H', 'H', 'NH', 'TS', 'AS', 'QS'], 0, 'Trump suit led'],
+ [['D', 'H', 'JH', 'TS', 'JD', 'QD'], 2, 'Jack trump beats all'],
+ [['D', 'C', 'NC', 'JH', 'AD', 'AC'], 1, 'Jack color beats all others'],
+ [['S', 'S', 'NS', 'JH', 'AD', 'JC'], 3, 'Jack color beats all others (2)'],
+ [['S', 'H', 'NS', 'JH', 'AD', 'AH'], 0, 'Trump beats ace'],
+ [['C', 'H', 'NH', 'JH', 'QH', 'AH'], 3, 'No trump, highest of led'],
+ [['C', 'H', 'NH', 'JH', 'AH'], 2, 'No trump, highest of led, 3 cards'],
+ [['C', 'S', 'NH', 'JH', 'AH', 'NS'], 3, 'No trump, suit led wins'],
+ );
+
+ for my $t (@tests) {
+ my ($trump, $led, @cards) = @{$t->[0]};
+ is(trick_winner($trump, $led, @cards), $t->[1], $t->[2]);
+ }
+
+}
+
+sub test_score_round {
+ my @tests = (
+ [[0, 1,2,1,1], [1, 2], 'Euched!'],
+ [[1, 2,1,1,1], [0, 2], 'Euched again!'],
+ [[3, 2,3,0,0], [1,1], 'Made your point'],
+ [[1, 0,3,0,2], [1,2], 'Got em all!'],
+ [[0, 5,0,'X',0], [0,4], 'Loneeeer!'],
+ [[2, 3,1,'X',1], [0,1], 'Failed loner'],
+ );
+
+ for my $t (@tests) {
+ my ($winners, $points) = score_round(@{$t->[0]});
+ is_deeply([$winners, $points], $t->[1], $t->[2]);
+ }
+}
+
+sub test_card_value {
+ ok(card_value('AH', 'H') < card_value('JH', 'H'), 'right bower highest');
+ ok(card_value('AH', 'H') < card_value('JD', 'H'), 'left bower higher than ace');
+ ok(card_value('JH', 'H') > card_value('JD', 'H'), 'left bower lower');
+ ok(card_value('ND', 'H', 'D') > card_value('TC', 'H', 'D'), 'throwoff');
+}
+
+test_deal();
+test_trick_winner();
+test_score_round();
+test_card_value();
+
+done_testing();
