From 41d77f292fd149615afdac2bce410a937db4f6d4 Mon Sep 17 00:00:00 2001 From: Alex Karle Date: Mon, 23 Mar 2020 00:10:07 -0400 Subject: [PATCH] Implement first pass at core game logic This commit steps away from the webserver stuff and just focuses on the core game logic. I've detailed in NOTES my thoughts on how the game plays out. In particular, my first instinct was to reach to OOP to create objects of cards, people, teams, games, etc. But I wanted to push myself to try to create a super-minimal number based game (after all, math is fun!). One can deduce the value and suit of a card just from the value 0..23, which opens nice doors into how to determine the winner of a trick (just use the card value!). I _believe_ the game state is simple enough to be held in a primitive structure with "globals", and without the need for objects. I reserve the right to double back and rewrite this in Moo though :) Set up some basic testing to ensure the math is all correct. --- Makefile | 3 +++ NOTES | 49 +++++++++++++++++++++++++++++++++++++++++++++++++ cli.pl | 24 ++++++++++++++++++++++++ gloat.pl | 2 +- lib/Euchre/Card.pm | 50 ++++++++++++++++++++++++++++++++++++++++++++++++++ lib/Euchre/Game.pm | 104 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++--- t/Card.t | 27 +++++++++++++++++++++++++++ t/Game.t | 68 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 8 files changed, 323 insertions(+), 4 deletions(-) create mode 100644 Makefile create mode 100644 NOTES create mode 100755 cli.pl create mode 100644 lib/Euchre/Card.pm create mode 100644 t/Card.t create mode 100644 t/Game.t diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..5866330 --- /dev/null +++ b/Makefile @@ -0,0 +1,3 @@ +test: + perl t/Card.t + perl t/Game.t diff --git a/NOTES b/NOTES new file mode 100644 index 0000000..f7c1423 --- /dev/null +++ b/NOTES @@ -0,0 +1,49 @@ +NOTES +===== + +Just some implementation details / thoughts. + + +In an OOP world... +------------------ + +Game has + Teams has + score + Players have + is_dealer + will_start + tricks_won + Hand has + Cards has + id + name + +In a functional world... +------------------------ +Key: cards are just ints (can derive class/value from int) + +subs: + trick_winner + score_tricks/round + deal_hands + +global state: + leader + dealer_id + calling_team + trump_suit + scores[2] + tricks[4] + +Round: + 1. deal cards + 2. + 3. leader = 1 + 4. for i 0..5 # play hand + a. + b. leader = trick_winner, tricks[$winner]++ + 5. scores += score_round(tricks) + 6. If max(scores) >= 10 -- DONE + +(note: <> means interactive) diff --git a/cli.pl b/cli.pl new file mode 100755 index 0000000..c52a39c --- /dev/null +++ b/cli.pl @@ -0,0 +1,24 @@ +#!/usr/bin/env perl +# cli.pl -- CLI version of the game +# good for testing +use strict; +use warnings; +use FindBin; +use lib "$FindBin::RealBin/lib"; +use Euchre::Game; +use Euchre::Card; + +my ($hands, $kiddey) = deal(); + +my %players = ( + Alex => $hands->[0], + Dad => $hands->[1], + Jennie => $hands->[2], + Mom => $hands->[3], +); + +for my $p (sort keys %players) { + print "$p\t"; + print map { "\t" . cid_to_name($_) } @{$players{$p}}; + print "\n"; +} diff --git a/gloat.pl b/gloat.pl index 60d0112..76c2a8a 100755 --- a/gloat.pl +++ b/gloat.pl @@ -9,6 +9,6 @@ use lib "$FindBin::RealBin/lib"; use Euchre::Game; -get '/' => { text => play() }; +get '/' => { text => deal() }; app->start; diff --git a/lib/Euchre/Card.pm b/lib/Euchre/Card.pm new file mode 100644 index 0000000..8763e2d --- /dev/null +++ b/lib/Euchre/Card.pm @@ -0,0 +1,50 @@ +# Euchre::Card -- Conversion routines for Cards +use strict; +use warnings; + +package Euchre::Card; + +require Exporter; +our @ISA = qw(Exporter); +our @EXPORT = qw(cid_to_name cname_to_id suit_to_id); + +our @SUITS = qw(H D S C); +our @CARDS = qw(N T J Q K A); + +# Put the indices of the above in a hash for ~speed~ +our %SUIT_IDS = ( + H => 0, + D => 1, + S => 2, + C => 3, +); + +our %CARD_IDS = ( + N => 0, + T => 1, + J => 2, + Q => 3, + K => 4, + A => 5, +); + +sub cid_to_name { + my $card_id = shift; + + my $suit = $SUITS[int($card_id / 6)]; + my $val = $CARDS[$card_id % 6]; + + return "$val$suit"; +} + +sub cname_to_id { + my $card_name = shift; + my ($val, $suit) = split('', $card_name); + return (6 * $SUIT_IDS{$suit}) + $CARD_IDS{$val}; +} + +sub suit_to_id { + return $SUIT_IDS{$_[0]}; +} + +1; diff --git a/lib/Euchre/Game.pm b/lib/Euchre/Game.pm index 961ae69..6663cd8 100644 --- a/lib/Euchre/Game.pm +++ b/lib/Euchre/Game.pm @@ -1,4 +1,6 @@ # 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; @@ -6,11 +8,107 @@ package Euchre::Game; require Exporter; our @ISA = qw(Exporter); +our @EXPORT = qw( + deal + trick_winner + score_round +); -our @EXPORT = qw(play); +use Euchre::Card; +use List::Util qw(shuffle); -sub play { - return "Let's play some Euchre!"; +sub deal { + my @cards = shuffle (0 .. 23); + + 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; +} + +sub trick_winner { + my ($trump, @cards) = @_; + + # Assign each card a value based on trump + led, either + # Bower: card + 50 + # Trump: card + 25 (including Bower) + # Suit Led: card + # Other: 0 + my $led = int($cards[0] / 6); + my @values = @cards; + for (my $i = 0; $i < @values; $i++) { + # Identify the card + my $c = $cards[$i]; + my $suit = int($c / 6); + my $is_jack = ($c % 6 == 2); + my $is_tcolor = (int($suit / 2) == int($trump / 2)); + my $is_bower = ($is_jack && $is_tcolor); + + # Assign it a value + if ($is_bower) { + $values[$i] += 50; + } + if ($suit == $trump) { + $values[$i] += 25; + } elsif ($suit != $led && !$is_bower) { + # throwoff -> set value to zero + $values[$i] = 0; + } else { + # non-trump led card -> use regular value + } + } + + 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. $callers either 0 or 1 +sub score_round { + my ($callers, @tricks) = @_; + + 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]; + } + } + + my @points = (0, 0); + $DB::single = 1; + if ($totals[$callers] == 5) { + if ($loner) { + # Hot diggity dog! + $points[$callers] = 4; + } else { + # Respectable + $points[$callers] = 2; + } + } elsif($totals[$callers] > $totals[$setters]) { + # Made your point... + $points[$callers] = 1; + } else { + # We've been Euched, Bill! + $points[$setters] = 2; + } + + return \@points; } 1; diff --git a/t/Card.t b/t/Card.t new file mode 100644 index 0000000..111c67d --- /dev/null +++ b/t/Card.t @@ -0,0 +1,27 @@ +#!/usr/bin/env perl +# Card.t -- tests for Euchre::Card +use strict; +use warnings; + +use FindBin; +use lib "$FindBin::Bin/../lib"; + +use Euchre::Card; +use Test::More; + +is(cname_to_id('AH'), 5, 'AH -> 5'); +is(cname_to_id('AD'), 11, 'AD -> 11'); +is(cname_to_id('NH'), 0, 'NH -> 0'); +is(cname_to_id('TS'), 13, 'TS -> 13'); + +is(cid_to_name(5), 'AH', '5 -> AH'); +is(cid_to_name(11), 'AD', '11 -> AD'); +is(cid_to_name(0), 'NH', '0 -> NH'); +is(cid_to_name(13), 'TS', '13 -> TS'); + +is(suit_to_id('H'), 0, 'Hearts suit to ID'); +is(suit_to_id('D'), 1, 'Diamonds suit to ID'); +is(suit_to_id('S'), 2, 'Spades suit to ID'); + + +done_testing(); diff --git a/t/Game.t b/t/Game.t new file mode 100644 index 0000000..afaf9d9 --- /dev/null +++ b/t/Game.t @@ -0,0 +1,68 @@ +#!/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 Euchre::Card; +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 @deck = sort { $a <=> $b } (@cards, @{$kiddey}); + is_deeply(\@deck, [0 .. 23], 'All 24 cards unique'); + +} + +sub test_trick_winner { + my @tests = ( + # [Trump, Cards], Winner Idx, Desc + [['H', 'NH', 'TS', 'AS', 'QS'], 0, 'Trump suit led'], + [['D', 'JH', 'TS', 'JD', 'QD'], 2, 'Jack trump beats all'], + [['D', 'NC', 'JH', 'AD', 'AC'], 1, 'Jack color beats all others'], + [['S', 'NS', 'JH', 'AD', 'JC'], 3, 'Jack color beats all others (2)'], + [['C', 'NH', 'JH', 'QH', 'AH'], 3, 'No trump, highest of led'], + [['C', 'NH', 'JH', 'AH'], 2, 'No trump, highest of led, 3 cards'], + ); + + for my $t (@tests) { + # Unpack, transform, test + my ($trump, @cards) = @{$t->[0]}; + $trump = suit_to_id($trump); + @cards = map { cname_to_id($_) } @cards; + is(trick_winner($trump, @cards), $t->[1], $t->[2]); + } + +} + +sub test_score_round { + my @tests = ( + [[0, 1,2,1,1], [0, 2], 'Euched!'], + [[1, 2,1,1,1], [2, 0], 'Euched again!'], + [[1, 2,3,0,0], [0,1], 'Made your point'], + [[1, 0,3,0,2], [0,2], 'Got em all!'], + [[0, 5,0,'X',0], [4,0], 'Loneeeer!'], + [[0, 3,1,'X',1], [1,0], 'Failed loner'], + ); + + for my $t (@tests) { + is_deeply(score_round(@{$t->[0]}), $t->[1], $t->[2]); + } +} + +test_deal(); +test_trick_winner(); +test_score_round(); + +done_testing(); -- libgit2 1.1.1