euchre-live

Euchre web-app for the socially distant family
git clone git://git.alexkarle.com/euchre-live.git
Log | Files | Refs | README | LICENSE

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:
MMakefile | 2+-
Mlib/Euchre/Dealer.pm | 2+-
Dlib/Euchre/Game.pm | 158-------------------------------------------------------------------------------
Alib/Euchre/Rules.pm | 158+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Dt/Game.t | 84-------------------------------------------------------------------------------
At/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();