commit f0950f856035500bc3cdb2a8cf909fa35cd0e8fd (patch)
parent d9f1528631e35f64f9cb490472a73b9d0c86fde9
Author: Alex Karle <alex@karle.co>
Date: Mon, 4 May 2020 00:23:07 -0400
Euchre::Host: Demote the Dealer, long live the Host
So all this work on OOP cleanup has been to support three things:
1. No circular object dependencies
2. Clearer separation of roles
3. Stricter accessors to prevent bugs
So why split the Dealer's responsibilities between a new Host class and
the existing Dealer (now with many Dealers)? Well the OOP hierarchy
looks like this:
gloat.pl (server) ----.
|
v
Host (table manager)
/ | \
v v v
Dealer Dealer Dealer
Where each Dealer represents a conceptual "Table" (Players and Game).
So the Host is responsible for getting you to a "Table" (join / create /
list / leave tables), which is done by registering you with the Dealer
associated with that Table.
The Table doesn't really exist as an object, more of a concept. The name
Dealer was kept because the core reason to have a Table is to allow for
communication within that group without crazy cross referencing. It felt
weird to have a Table talking to you :) (it is pretty late at night...)
So the main benefit here is that the Game no longer needs to know about
Players (at all). It doesn't even need to know what seat is calling it
-- it already knows who's turn it is and the Dealer ensures Players take
turns fairly.
Likewise, Players are now free to sit/stand willy nilly, as the Game
holds the hands. This simplifies the "dropped connection" workflow, as
we don't need to the whole "force join" concept. If a connection drops,
remove the player and they (or any other spectator) can sit back down
and resume.
Diffstat:
7 files changed, 605 insertions(+), 555 deletions(-)
diff --git a/gloat.pl b/gloat.pl
@@ -8,7 +8,7 @@ use Mojo::JSON qw(decode_json);
use FindBin;
use lib "$FindBin::RealBin/lib";
-use Euchre::Dealer;
+use Euchre::Host;
plugin Webpack => {process => [qw(js css sass)]};
@@ -33,7 +33,7 @@ websocket '/play' => sub {
my $id = ''.$c->tx;
app->log->debug("New player: $id");
- # Register the player with the Dealer
+ # Register the player with the server
register_player($c->tx);
$c->on(message => sub {
diff --git a/lib/Euchre/Dealer.pm b/lib/Euchre/Dealer.pm
@@ -1,84 +1,53 @@
-# Euchre::Dealer -- the Server API
+# Euchre::Dealer -- enforcer of turns, speaker of state
+# * Communicates Game state to Players at table
+# * Ensures everyone is following the rules
use strict;
use warnings;
package Euchre::Dealer;
-use Mojo::IOLoop;
-use List::Util qw(sum);
-
use Euchre::Errors;
use Euchre::Game;
-use Euchre::Player;
-use Euchre::Rules;
-
-require Exporter;
-our @ISA = qw(Exporter);
-our @EXPORT = qw(
- handle_msg
- register_player
- gloaters_never_win
- stats
-);
-
-# Global State
-our %GAMES;
-our %PLAYERS;
-
-# Stats
-our $TOTAL_PLAYERS = 0;
-our $TOTAL_GAMES = 0;
-our $START_TIME = localtime(time);
-
-# On ws connection, we add the player to %PLAYERS so that all
-# future handle_msg's know how to send messages back to the
-# player. No name or game_id known (yet). Player in lobby
-sub register_player {
- my ($tx) = @_;
- my $id = ''.$tx;
- $PLAYERS{$id} = Euchre::Player->new(id => $id, ws => $tx);
- print "Player $id has joined the server\n";
-
- $TOTAL_PLAYERS++;
-}
-# finish handler to cleanup state
-sub gloaters_never_win {
- my ($id) = @_;
- if (!exists $PLAYERS{$id}) {
- warn "gloaters_never_win called on unknown player\n";
- return;
+use Class::Tiny qw(id start_time), {
+ password => '',
+ game => sub { Euchre::Game->new() },
+ players => sub { {} },
+};
+
+sub add_player {
+ my ($self, $p, $password) = @_;
+
+ $password //= '';
+ if ($self->password && $password ne $self->password) {
+ return BAD_PASS;
}
- my $p = $PLAYERS{$id};
- my $game = $p->game;
-
- $p->active(0);
- if (defined $game) {
- # Player was in a game... if no one else is still there,
- # we should clean up the game after some inactivity
- my $timeout = $ENV{DEBUG} ? 1 : (60 * 30); # 30 mins
- Mojo::IOLoop->timer($timeout => sub {
- if (!grep { defined($_) && $_->active } @{$game->players}) {
- print "Deleting inactive Game $game->id\n";
- delete $GAMES{$game->id};
- }
- });
+
+ if (grep { $_->name eq $p->{name} } values %{$self->players}) {
+ return UNIQUE_USER;
}
+ $self->players->{$p->{id}} = $p;
+ $self->broadcast_gamestate();
+
+ return SUCCESS;
+}
- my $name = $p->name ? $p->name : 'UnnamedPlayer';
- print "Player $name went inactive\n";
+sub remove_player {
+ my ($self, $p) = @_;
- # Remove reference in %PLAYERS, but NOTE: still referenced in $game
- # potentially. This is by design. Don't throw away their hand / seat
- # whatever until no active players are at the game and a timeout passes
- delete $PLAYERS{$id};
+ $p->stand_up();
+ delete $self->players->{$p->{id}};
+ $self->broadcast_gamestate();
+
+ return SUCCESS;
}
# Top level handler to dispatch into the appropriate message.
-# Takes in the client ws id and the JSON msg and runs the
+# Called by the Host for table specific routines
+# Takes in the player id and the JSON msg and runs the
# appropriate handler, which is responsible for responding via ws
sub handle_msg {
- my ($cid, $msg) = @_;
+ my ($self, $cid, $msg) = @_;
# Crazy magic dispatch of
#
@@ -88,565 +57,193 @@ sub handle_msg {
# assertions (like, needs to be their turn)
my %dispatch = (
# Game management endpoints
- ping => [\&pong],
- join_game => [\&join_game],
- leave_game => [\&leave_game],
- take_seat => [\&take_seat, 'lobby', CHANGE_SEAT],
- stand_up => [\&stand_up, 'lobby', STAND_UP],
- start_game => [\&start_game, 'lobby', START_GAME],
- restart_game => [\&restart_game, 'end', RESTART_GAME],
+ chat => [\&chat],
+ take_seat => [\&take_seat],
+ stand_up => [\&stand_up],
+ start_game => [\&start_game, 'lobby', START_GAME],
+ restart_game => [\&restart_game, 'end', RESTART_GAME],
# Gameplay
- order => [\&order, 'vote', ORDER, 1],
- dealer_swap => [\&dealer_swap, 'dealer_swap', DEALER_SWAP, 1],
- play_card => [\&play_card, 'play', PLAY_CARD, 1],
- chat => [\&chat],
+ order => [\&order, 'vote', ORDER, 1],
+ dealer_swap => [\&dealer_swap, 'dealer_swap', DEALER_SWAP, 1],
+ play_card => [\&play_card, 'play', PLAY_CARD, 1],
);
if (!exists $dispatch{$msg->{action}}) {
- die "Unknown API action: $msg->{action}";
+ warn "Unknown dealer API action: $msg->{action}";
+ return;
}
- my $p = $PLAYERS{$cid};
+ my $p = $self->players->{$cid};
my ($handler, $req_phase, $phase_err, $turn_based) = @{$dispatch{$msg->{action}}};
- if ($req_phase && ($p->game->phase ne $req_phase)) {
+ if ($req_phase && ($self->game->phase ne $req_phase)) {
$p->error($phase_err);
- } elsif ($turn_based && ($p->seat != $p->game->turn)) {
+ } elsif ($turn_based && ($p->seat != $self->game->turn)) {
$p->error(TURN);
} else {
- $handler->($p, $msg);
- }
-}
-
-sub pong {
- my ($p) = @_;
- $p->send({ msg_type => 'pong' });
-}
-
-# player_name
-# game_id
-# force
-# password (opt)
-sub join_game {
- my ($p, $msg) = @_;
-
- my $id = $msg->{game_id};
-
- # ckDebug: if env END_DEBUG make score 9-9
- # as in line ~102 above: my $timeout = $ENV{DEBUG} ? 1 : (60 * 30); # 30 mins
-
- # init game if needed
- if (!exists $GAMES{$id}) {
- $GAMES{$id} = Euchre::Game->new(id => $id);
- $TOTAL_GAMES++;
- }
-
- my $game = $GAMES{$id};
-
- # Before adding, verify the password is correct
- if ($game->password && $game->password ne $msg->{password}) {
- $p->error(BAD_PASS);
- return;
- }
-
- # Make sure name is unique to game
- my @all_names = map { $_->name }
- grep { defined }
- (@{$game->players}, @{$game->spectators});
-
- my $player_exists = grep { $_ eq $msg->{player_name} } @all_names;
-
- if ($player_exists) {
- if (!$msg->{force}) {
- $p->error(UNIQUE_USER);
- return;
- }
- $p->name($msg->{player_name});
- swap_player($game, $p, 'players') || swap_player($game, $p, 'spectators');
- } else {
- # Add player object to Game
- # All players start as spectators and have to take a seat explicitly
- $p->name($msg->{player_name});
- $p->hand([]);
- $p->game($game);
- push @{$game->spectators}, $p;
- }
-
- broadcast_gamestate($game);
-}
-
-sub leave_game {
- my ($p) = @_;
-
- my $game = $p->game;
- if (!defined $game) {
- $p->error(NOT_IN_GAME);
- return;
- }
-
- $p->game(undef);
- if (defined $p->seat) {
- $game->players->[$p->seat] = undef;
- $p->seat(undef);
- $p->hand([]);
- } else {
- # Check for specatator
- for (my $i = 0; $i < @{$game->spectators}; $i++) {
- if ($game->spectators->[$i]->id eq $p->id) {
- splice(@{$game->spectators}, $i, 1);
- last;
+ if (my $errno = $handler->($self, $p, $msg)) {
+ $p->error($errno);
+ } else {
+ # All successful Dealer handlers broadcast to all players on success
+ # (except for chat...)
+ if ($msg->{action} ne 'chat') {
+ $self->broadcast_gamestate();
}
}
}
-
- broadcast_gamestate($game); # let others know
}
# seat
sub take_seat {
- my ($p, $msg) = @_;
+ my ($self, $p, $msg) = @_;
- my $game = $p->game;
my $seat = $msg->{seat};
if ($seat > 3 || $seat < 0) {
- $p->error(INVALID_SEAT);
- return;
+ return INVALID_SEAT;
}
- if (defined $game->players->[$seat]) {
- $p->error(TAKEN_SEAT);
- return;
+ if (grep { $_->seat == $seat } values %{$self->players}) {
+ return TAKEN_SEAT;
} else {
# Move from standing (or sitting) to sitting
- stand_up($p) if defined $p->seat;
- $game->players->[$seat] = $p;
- $p->seat($seat);
- for (my $i = 0; $i < @{$game->spectators}; $i++) {
- if ($game->spectators->[$i]->id eq $p->id) {
- splice(@{$game->spectators}, $i, 1);
- }
+ if (!$p->is_spectator()) {
+ $p->stand_up();
}
+ $p->seat($seat);
}
- broadcast_gamestate($game);
+
+ return SUCCESS;
}
sub stand_up {
- my ($p) = @_;
-
- my $game = $p->game;
- my $seat = $p->seat;
-
- if (!defined $seat) {
- $p->error(ALREADY_STANDING);
- } else {
- # Move from sitting to standing
- push @{$game->spectators}, $p;
- $p->seat(undef);
- $game->players->[$seat] = undef;
- broadcast_gamestate($game);
- }
-
+ my ($self, $p) = @_;
+ return $p->stand_up();
}
# start_seat: -1 - 3
sub start_game {
- my ($p, $msg) = @_;
- my $game = $p->game;
+ my ($self, $p, $msg) = @_;
- if (num_players($game->id) < 4) {
- $p->error(PARTIAL_GAME);
- return;
+ if ($self->num_players() < 4) {
+ return PARTIAL_GAME;
+ }
+
+ if ($msg->{start_seat} > 4) {
+ return INVALID_SEAT;
}
if (!defined $msg->{start_seat} || $msg->{start_seat} < 0) {
- $game->dealer(int(rand(4)));
- } elsif ($msg->{start_seat} < 4) {
- # One less since start_new_round will rotate
- $game->dealer(($msg->{start_seat} - 1));
- } else {
- $p->error(INVALID_SEAT);
- return;
+ $msg->{start_seat} = int(rand(4));
}
- start_new_round($game);
+ return $self->game->start_game($msg->{start_seat});
}
sub restart_game {
- my ($p) = @_;
- my $game = $p->game;
-
- $game->score($ENV{END_DEBUG} ? [9,9] : [0,0]);
- $game->phase('lobby');
- broadcast_gamestate($game);
+ my ($self) = @_;
+ $self->game = Euchre::Game->new();
}
sub num_players {
- my ($gid) = @_;
- return scalar grep { defined } @{$GAMES{$gid}->players}
-}
-
-sub start_new_round {
- my ($game) = @_;
-
- # Shift dealer and deal
- $game->dealer(($game->dealer + 1) % 4);
- $game->trump(undef);
- $game->tricks([0,0,0,0]);
- $game->out_player(-1);
- deal_players_hands($game);
-
- # Signal vote of player next to dealer...
- $game->reset_turn();
- $game->phase('vote');
- $game->pass_count(0);
- broadcast_gamestate($game); # includes trump_nominee
-}
-
-# Deal the hands, leave the messaging to broadcast
-sub deal_players_hands {
- my ($game) = @_;
-
- my ($handsA, $kiddeyA) = deal();
- $game->trump_nominee(shift @$kiddeyA);
- for my $p (@{$game->players}) {
- $p->hand(shift @$handsA);
- }
-
- sort_hands($game);
+ my ($self) = @_;
+ return scalar grep { !$_->is_spectator } values %{$self->players};
}
-
# msg.vote = 'suit' or 'pass'
# msg.loner = 0 or 1
sub order {
- my ($p, $msg) = @_;
-
- my $game = $p->game;
- if ($msg->{vote} eq 'pass') {
- $game->next_turn();
- $game->pass_count($game->pass_count + 1);
- if ($game->pass_count >= 8) {
- # Throw em in
- start_new_round($game);
- } else {
- broadcast_gamestate($game);
- }
- } elsif ($msg->{vote}) {
- # Validate its an OK vote
- if ($game->pass_count < 4) {
- if ($game->trump_nominee !~ /$msg->{vote}/) {
- $p->error(VOTE_ON_KITTY);
- return;
- }
- } else {
- if ($game->trump_nominee =~ /$msg->{vote}/) {
- $p->error(VOTE_OFF_KITTY);
- return;
- }
- }
-
- # Accept the vote...
- $game->trump($msg->{vote});
- $game->caller($p->seat);
- if ($msg->{loner}) {
- my $partner_seat = ($p->seat + 2) % 4;
- $game->out_player($partner_seat);
- $game->tricks->[$partner_seat] = 'X';
- }
- if ($game->pass_count < 4) {
- # Setting phase will block all other play actions until the
- # dealer is done swapping. Do still broadcast so dealer knows!
- # Piggy back on the handle_msg turn validation by temporarily
- # setting "turn" to dealer.
- $game->phase('dealer_swap');
- $game->turn($game->dealer);
- } else {
- # Get right to it!
- $game->phase('play');
- $game->reset_turn();
- }
-
- sort_hands($game);
- broadcast_gamestate($game);
- } else {
- $p->error(BAD_VOTE);
- }
+ my ($self, $p, $msg) = @_;
+ return $self->game->order($msg->{vote}, $msg->{loner});
}
# msg.card => 'AH'
sub play_card {
- my ($p, $msg) = @_;
-
- # Identify player
- my $game = $p->game;
- my $seat = $p->seat;
-
- my %colors = (H => 'D', D => 'H', S => 'C', C => 'S');
-
- # Validate they follow suit if they CAN
- if (defined $game->led) {
-
- # Build up a list of valid cards
- my @followers = map { "$_$game->led" } qw(N T Q K A); # no jack
- if ($game->led eq $game->trump) {
- # Trump led, both jacks valid
- push @followers, "J$game->led";
- push @followers, "J$colors{$game->led}";
- } elsif ($colors{$game->led} ne $game->trump) {
- # Off-color, jack is OK
- push @followers, "J$game->led";
- } else {
- # Played same color as trump, don't add jack
- }
- my $follower_re = join("|", @followers);
-
- # Now validate that they are EITHER:
- # 1) Following Suit
- # 2) Can't follow suit
- # By checking negative of both
- if ($msg->{card} !~ /$follower_re/ &&
- grep { $_ =~ /$follower_re/ } @{$p->hand}) {
+ my ($self, $p, $msg) = @_;
+ my ($errno, $do_update) = $self->game->play_card($msg->{card});
- $p->error(FOLLOW_SUIT);
- return;
- }
- }
-
- take_card($p, $msg->{card}) or return;
-
- # Update the table and current player
- $game->table->[$seat] = $msg->{card};
- $game->next_turn();
-
-
- my $played_cards = scalar grep { defined } @{$game->table};
- if ($played_cards == 1) {
- # First card!
- my ($val, $suit) = split('', $msg->{card});
-
- # Special case Jack of Color == trump
- if ($val eq 'J' && $suit eq $colors{$game->trump}) {
- $game->led($game->trump);
- } else {
- $game->led($suit);
- }
- }
-
- # Adjust num cards on table by if there's an out player
- my $out_adj = ($game->out_player >= 0 ? 1 : 0);
- if ($played_cards >= (4 - $out_adj)) {
- # End trick -- update tricks, clear table, and set current player
- my @table = map { defined($_) ? $_ : 'X' } @{$game->table};
- my $winner_id = trick_winner($game->trump, $game->led, @table);
-
- # Update the gamestate and pause so all can see
- $game->tricks->[$winner_id]++;
- $game->turn($winner_id);
- $game->phase('pause');
-
- # Sub to call after pause
- my $post_pause = sub {};
-
- my @num_tricks = grep { /^\d+$/ } @{$game->tricks};
- if (sum(@num_tricks) >= 5) {
- # End round -- update scores, clear tricks, push dealer
- my ($team_id, $score) = score_round($game->caller, @{$game->tricks});
- $game->score->[$team_id] += $score;
-
- if ($game->score->[$team_id] >= 10) {
- $post_pause = sub { signal_game_end($game) };
- } else {
- $post_pause = sub { start_new_round($game) };
- }
+ if ($errno) {
+ return $errno;
+ } else {
+ if ($do_update) {
+ Mojo::IOLoop->timer(2 => sub { $self->broadcast_gamestate() });
}
-
-
- Mojo::IOLoop->timer(2 => sub {
- $game->table([undef, undef, undef, undef]);
- $game->led(undef);
- $game->phase('play');
-
- $post_pause->();
- broadcast_gamestate($game);
- });
-
- }
- broadcast_gamestate($game);
-}
-
-
-sub signal_game_end {
- my ($game) = @_;
-
- $game->phase('end');
-
- # Put all players into spectator roles. This is crucial so that one player
- # doesn't walk away and hold up a seat (assuming others want to play again)
- for my $p (grep { defined } @{$game->players}) {
- $p->seat(undef);
- push @{$game->spectators}, $p;
+ return SUCCESS;
}
- $game->players([undef, undef, undef, undef]);
}
-
# Based on validation, we KNOW $p is the dealer
# msg.card = card to swap
sub dealer_swap {
- my ($p, $msg) = @_;
-
- my $game = $p->game;
-
- # Exchange the cards
- take_card($p, $msg->{card}) or return;
- push @{$p->hand}, $game->trump_nominee;
- sort_hands($game);
-
- # Start the game
- $game->phase('play');
- $game->reset_turn();
- broadcast_gamestate($game);
+ my ($self, $p, $msg) = @_;
+ return $self->game->dealer_swap($msg->{card});
}
-# XXX: The most simplest (bulkiest) message we can send is to just
-# broadcast the gamestate to all clients. This will be our temporary
-# debugging method / MVP. We can trim down the communication later
sub broadcast_gamestate {
- my ($game) = @_;
+ my ($self) = @_;
# Translate to human readable names for clients
- my @pnames = map { defined($_) ? $_->name : 'Empty' } @{$game->players};
- my @snames = map { $_->name } @{$game->spectators};
-
- # Hand lengths are nice for rendering in the clients
- my @hand_lengths =
- map { defined($_) ? scalar @{$_->hand} : 0 } @{$game->players};
+ my @snames = map { $_->name } @{$self->spectators};
my $msg = {
- %$game,
- players => \@pnames,
+ %{$self->game},
+ hands => 'redacted',
+ players => $self->player_names,
spectators => \@snames,
- hand_lengths => \@hand_lengths,
+ hand_lengths => $self->game->hand_lengths,
};
- for my $p (@{$game->players}, @{$game->spectators}) {
- next unless defined $p;
+ for my $p (values %{$self->players}) {
my $json = {
msg_type => 'game_state',
game => $msg,
- hand => $p->hand,
- is_spectator => ($p->seat) ? 0 : 1,
+ is_spectator => $p->is_spectator,
};
- $p->send($json);
- }
-}
-# We only need this when trump suit voted, not every broadcast
-sub sort_hands {
- my ($game) = @_;
-
- my $t = $game->trump;
- for my $p (@{$game->players}) {
- my @sorted = sort { card_value($a, $t) <=> card_value($b, $t) } @{$p->hand};
- $p->hand(\@sorted);
+ if (!$p->is_spectator) {
+ $json->{hand} = $self->game->hands->[$p->seat];
+ }
+ $p->send($json);
}
}
-# Returns 0 or 1 on success
-sub take_card {
- my ($p, $card) = @_;
-
- # Make sure they have the card, and update their hand
- for (my $i = 0; $i < scalar @{$p->hand}; $i++) {
- if ($p->hand->[$i] eq $card) {
- splice(@{$p->hand}, $i, 1);
- return 1;
- }
- }
+# Simple stateless broadcast to all clients in game
+sub chat {
+ my ($self, $p, $msg) = @_;
- $p->error(DONT_HAVE_CARD);
- return 0;
+ my $json = {
+ msg_type => 'chat',
+ msg => "$p->name: $msg->{msg}"
+ };
+ $self->broadcast($json);
}
-# Returns 0 or 1 on success
-sub swap_player {
- my ($game, $new_p, $list) = @_;
-
- for (my $i = 0; $i < @{$game->$list}; $i++) {
- next unless defined $game->$list->[$i]; # undef potentially in lobby
- if ($game->$list->[$i]->name eq $new_p->name) {
- # Ye ole switcheroo
- # Don't delete the old player cuz we need to preserve the hand, etc.
- # Just swap out the WS and ID, and update PLAYERS
- my $old_id = $game->$list->[$i]->id;
- $game->$list->[$i]->id($new_p->id);
- $game->$list->[$i]->ws($new_p->ws);
- $game->$list->[$i]->active(1); # May have disconnected previously
- $PLAYERS{$new_p->id} = $game->$list->[$i];
-
- # NOTE: For now, don't delete from %PLAYERS here...
- # the old WS may still be playing ping/pong, so we just
- # let them hang out until they close themselves or go
- # inactive (and we time them out => delete from %PLAYERS)
- return 1;
- }
+# Send a message to all players at the table
+sub broadcast {
+ my ($self, $json) = @_;
+ for my $p (values %{$self->players}) {
+ $p->send($json);
}
- return 0;
}
-# Global server stats for games in progress
-# Poor man's monitoring :)
-sub stats {
- my $num_players = scalar keys %PLAYERS;
- my $num_games = scalar keys %GAMES;
-
- my $msg = "";
- $msg .= "PLAYERS: Join Time\t\tName\tGame\n";
- $msg .= "===========================================================\n";
- for my $p (values %PLAYERS) {
- my $name = $p->name ? $p->name : 'UnnamedPlayer';
- my $game = $p->game ? $p->game->id : 'Lobby';
- $msg .= localtime($p->joined) . "\t$name\t$game\n";
- }
- $msg .= "-----------------------------------------------------------\n";
- $msg .= "$num_players\tPlayers\n";
-
- $msg .= "\n\nGAMES: Start Time\t\tname\n";
- $msg .= "===========================================================\n";
- for my $g (values %GAMES) {
- $msg .= localtime($g->{start_time}) . "\t$g->{id}\n";
- }
- $msg .= "-----------------------------------------------------------\n";
- $msg .= "$num_games\tGames\n";
-
- $msg .= "\n\nServer Stats\n";
- $msg .= "===========================================================\n";
- $msg .= "Server Start: $START_TIME\n";
- $msg .= "Lifetime Games: $TOTAL_GAMES\n";
- $msg .= "Lifetime Players: $TOTAL_PLAYERS\n";
- $msg .= "-----------------------------------------------------------\n";
- $msg .= "\n\nUptime: " . `uptime`;
-
- return $msg;
+# TODO: When we decide to broadcast Euchre tournies of millions,
+# rewrite this to be an array to minimize number of times we
+# iterate through it on broadcast_gamestate ... until then? prosper
+sub spectators {
+ my ($self) = @_;
+ my @specs = grep { $_->is_spectator } values %{$self->players};
+ return \@specs;
}
-# Simple stateless broadcast to all clients in game
-sub chat {
- my ($p, $msg) = @_;
-
- my $game = $p->game;
- for my $player (@{$game->players}, @{$game->spectators}) {
- next unless defined $player;
-
- my $json = {
- msg_type => 'chat',
- msg => "$p->name: $msg->{msg}"
- };
- $player->send($json);
+sub player_names {
+ my ($self) = @_;
+ my $seated = ['Empty', 'Empty', 'Empty', 'Empty'];
+ for my $p (grep { !$_->is_spectator } values %{$self->players}) {
+ $seated->[$p->seat] = $p->name;
}
+ return $seated;
}
1;
diff --git a/lib/Euchre/Errors.pm b/lib/Euchre/Errors.pm
@@ -6,7 +6,7 @@ package Euchre::Errors;
# NOTE: Append ONLY for client compatibility
use constant {
- CHANGE_SEAT => 0,
+ SUCCESS => 0,
STAND_UP => 1,
START_GAME => 2,
RESTART_GAME => 3,
@@ -21,17 +21,20 @@ use constant {
PARTIAL_GAME => 12,
VOTE_ON_KITTY => 13,
VOTE_OFF_KITTY => 14,
- BAD_VOTE => 14,
+ BAD_VOTE => 15,
FOLLOW_SUIT => 16,
DONT_HAVE_CARD => 17,
NOT_IN_GAME => 18,
BAD_PASS => 19,
+ NOT_AT_TABLE => 20,
+ CHANGE_SEAT => 21,
};
require Exporter;
our @ISA = qw(Exporter);
our @EXPORT = qw(
err_msg
+ SUCCESS
CHANGE_SEAT
STAND_UP
START_GAME
@@ -52,6 +55,7 @@ our @EXPORT = qw(
DONT_HAVE_CARD
NOT_IN_GAME
BAD_PASS
+ NOT_AT_TABLE
);
our @ERR_MSGS = ();
@@ -75,6 +79,7 @@ $ERR_MSGS[FOLLOW_SUIT] = "Have to follow suit!";
$ERR_MSGS[DONT_HAVE_CARD] = "You don't have that card!";
$ERR_MSGS[NOT_IN_GAME] = "You're not in any game";
$ERR_MSGS[BAD_PASS] = "Game exists, password incorrect";
+$ERR_MSGS[NOT_AT_TABLE] = "Need to be at a table for action";
sub err_msg {
my ($errno) = @_;
diff --git a/lib/Euchre/Game.pm b/lib/Euchre/Game.pm
@@ -1,13 +1,20 @@
# Euchre::Game -- the Game object
+# Knows NOTHING about players, simply modifies game state based on seat num and
+# actions (leaves it up to Table to coordinate between who can play when).
use strict;
use warnings;
package Euchre::Game;
-use Class::Tiny qw(id trump out_player turn dealer caller password pass_count led trump_nominee), {
+use List::Util qw(sum);
+use Mojo::IOLoop;
+
+use Euchre::Errors;
+use Euchre::Rules;
+
+use Class::Tiny qw(trump out_player turn dealer caller pass_count led trump_nominee), {
phase => 'lobby',
- players => sub { [undef, undef, undef, undef] },
- spectators => sub { [] },
+ hands => sub { [[],[],[],[]] },
tricks => sub { [0, 0, 0, 0] },
table => sub { [undef, undef, undef, undef] },
score => sub { $ENV{END_DEBUG} ? [9, 9] : [0, 0] },
@@ -31,4 +38,243 @@ sub reset_turn {
$self->next_turn();
}
+sub start_new_round {
+ my ($self) = @_;
+
+ # Shift dealer and deal
+ $self->dealer(($self->dealer + 1) % 4);
+ $self->trump(undef);
+ $self->tricks([0,0,0,0]);
+ $self->out_player(-1);
+ $self->deal_hands();
+
+ # Signal vote of player next to dealer...
+ $self->reset_turn();
+ $self->phase('vote');
+ $self->pass_count(0);
+}
+
+sub deal_hands {
+ my ($self) = @_;
+
+ my ($handsA, $kiddeyA) = deal();
+ $self->trump_nominee(shift @$kiddeyA);
+ $self->hands($handsA);
+ $self->sort_hands();
+}
+
+# We only need this when trump suit voted, not every broadcast
+sub sort_hands {
+ my ($self) = @_;
+
+ my $t = $self->trump;
+ for (my $i = 0; $i < 4; $i++) {
+ my $hand = $self->hands->[$i];
+ my @sorted = sort { card_value($a, $t) <=> card_value($b, $t) } @{$hand};
+ $self->hands->[$i] = \@sorted;
+ }
+}
+
+
+sub play_card {
+ my ($self, $card) = @_;
+
+ # HACK: Return 1 if Table needs to send a second delayed broadcast
+ # Assume we don't
+ my $do_update = 0;
+
+ my %colors = (H => 'D', D => 'H', S => 'C', C => 'S');
+ # Validate they follow suit if they CAN
+ if (defined $self->led) {
+ # Build up a list of valid cards
+ my @followers = map { $_ . $self->led } qw(N T Q K A); # no jack
+ if ($self->led eq $self->trump) {
+ # Trump led, both jacks valid
+ push @followers, "J" . $self->led;
+ push @followers, "J" . $colors{$self->led};
+ } elsif ($colors{$self->led} ne $self->trump) {
+ # Off-color, jack is OK
+ push @followers, "J" . $self->led;
+ } else {
+ # Played same color as trump, don't add jack
+ }
+ my $follower_re = join("|", @followers);
+
+ # Now validate that they are EITHER:
+ # 1) Following Suit
+ # 2) Can't follow suit
+ # By checking negative of both
+ if ($card !~ /$follower_re/ &&
+ grep { $_ =~ /$follower_re/ } @{$self->curr_hand}) {
+ return FOLLOW_SUIT;
+ }
+ }
+
+ $self->take_card($card) or return DONT_HAVE_CARD;
+
+ # Update the table and current player
+ $self->add_to_table($card);
+ $self->next_turn();
+
+
+ my $played_cards = scalar grep { defined } @{$self->table};
+ if ($played_cards == 1) {
+ # First card!
+ my ($val, $suit) = split('', $card);
+
+ # Special case Jack of Color == trump
+ if ($val eq 'J' && $suit eq $colors{$self->trump}) {
+ $self->led($self->trump);
+ } else {
+ $self->led($suit);
+ }
+ }
+
+ # Adjust num cards on table by if there's an out player
+ my $out_adj = ($self->out_player >= 0 ? 1 : 0);
+ if ($played_cards >= (4 - $out_adj)) {
+ # End trick -- update tricks, clear table, and set current player
+ my @table = map { defined($_) ? $_ : 'X' } @{$self->table};
+ my $winner_id = trick_winner($self->trump, $self->led, @table);
+
+ # Update the gamestate and pause so all can see
+ $self->tricks->[$winner_id]++;
+ $self->turn($winner_id);
+ $self->phase('pause');
+
+ # Sub to call after pause
+ my $post_pause = sub {};
+
+ my @num_tricks = grep { /^\d+$/ } @{$self->tricks};
+ if (sum(@num_tricks) >= 5) {
+ # End round -- update scores, clear tricks, push dealer
+ my ($team_id, $score) = score_round($self->caller, @{$self->tricks});
+ $self->score->[$team_id] += $score;
+
+ if ($self->score->[$team_id] >= 10) {
+ $post_pause = sub { $self->phase('end') };
+ } else {
+ $post_pause = sub { $self->start_new_round() };
+ }
+ }
+
+
+ $do_update = 1;
+ Mojo::IOLoop->timer(1.5 => sub {
+ $self->table([undef, undef, undef, undef]);
+ $self->led(undef);
+ $self->phase('play');
+
+ $post_pause->();
+ });
+
+ }
+
+ return SUCCESS, $do_update;
+}
+
+sub take_card {
+ my ($self, $card) = @_;
+
+ my $hand = $self->curr_hand;
+
+ # Make sure they have the card, and update their hand
+ for (my $i = 0; $i < scalar @{$hand}; $i++) {
+ if ($hand->[$i] eq $card) {
+ splice(@{$hand}, $i, 1);
+ return 1;
+ }
+ }
+
+ return 0;
+}
+
+
+sub dealer_swap {
+ my ($self, $card) = @_;
+
+ # Exchange the cards
+ $self->take_card($card) or return DONT_HAVE_CARD;
+
+ push @{$self->hands->[$self->dealer]}, $self->trump_nominee;
+ $self->sort_hands();
+
+ # Start the game
+ $self->phase('play');
+ $self->reset_turn();
+
+ return SUCCESS;
+}
+
+
+sub order {
+ my ($self, $vote, $loner) = @_;
+
+ if ($vote eq 'pass') {
+ $self->next_turn();
+ $self->pass_count($self->pass_count + 1);
+ if ($self->pass_count >= 8) {
+ # Throw em in
+ $self->start_new_round();
+ }
+ } elsif ($vote) {
+ # Validate its an OK vote
+ if ($self->pass_count < 4 && $self->trump_nominee !~ /$vote/) {
+ return VOTE_ON_KITTY;
+ } elsif ($self->pass_count >=4 && $self->trump_nominee =~ /$vote/) {
+ return VOTE_OFF_KITTY;
+ }
+
+ # Accept the vote...
+ $self->trump($vote);
+ $self->caller($self->turn);
+ if ($loner) {
+ my $partner_seat = ($self->turn + 2) % 4;
+ $self->out_player($partner_seat);
+ $self->tricks->[$partner_seat] = 'X';
+ }
+ if ($self->pass_count < 4) {
+ # Setting phase will block all other play actions until the
+ # dealer is done swapping. Do still broadcast so dealer knows!
+ # Piggy back on the handle_msg turn validation by temporarily
+ # setting "turn" to dealer.
+ $self->phase('dealer_swap');
+ $self->turn($self->dealer);
+ } else {
+ # Get right to it!
+ $self->phase('play');
+ $self->reset_turn();
+ }
+ $self->sort_hands();
+ } else {
+ return BAD_VOTE;
+ }
+ return SUCCESS;
+}
+
+sub hand_lengths {
+ my ($self) = @_;
+ return [map { scalar @{$_} } @{$self->hands}];
+}
+
+sub curr_hand {
+ my ($self) = @_;
+ return $self->hands->[$self->turn];
+}
+
+sub add_to_table {
+ my ($self, $card) = @_;
+ $self->table->[$self->turn] = $card;
+}
+
+sub start_game {
+ my ($self, $start_seat) = @_;
+
+ # One less since start_new_round will rotate
+ $self->dealer($start_seat - 1);
+ $self->start_new_round();
+
+ return SUCCESS;
+}
+
1;
diff --git a/lib/Euchre/Host.pm b/lib/Euchre/Host.pm
@@ -0,0 +1,195 @@
+# Euchre::Host -- responsible for all things in the Lobby
+# (join/create/leave table actions, registering players, etc)
+use strict;
+use warnings;
+
+package Euchre::Host;
+
+use Euchre::Errors;
+use Euchre::Dealer;
+use Euchre::Player;
+
+require Exporter;
+our @ISA = qw(Exporter);
+our @EXPORT = qw(
+ handle_msg
+ register_player
+ gloaters_never_win
+ stats
+);
+
+# Global State
+our %PLAYERS;
+our %DEALERS;
+our %PINDEX; # Player id => Dealer id
+
+# Stats
+our $TOTAL_PLAYERS = 0;
+our $TOTAL_TABLES = 0;
+our $START_TIME = localtime(time);
+
+# On ws connection, we add the player to %PLAYERS so that all future
+# handle_msg's know how to send messages back to the player.
+sub register_player {
+ my ($tx) = @_;
+ my $id = ''.$tx;
+ $PLAYERS{$id} = Euchre::Player->new(
+ id => $id,
+ ws => $tx,
+ start_time => time,
+ );
+ $TOTAL_PLAYERS++;
+}
+
+# finish handler to cleanup state
+sub gloaters_never_win {
+ my ($id) = @_;
+ if (!exists $PLAYERS{$id}) {
+ warn "gloaters_never_win called on unknown player\n";
+ return;
+ }
+
+ # TODO: cleanup stale tables
+ my $p = $PLAYERS{$id};
+ leave_table($p);
+
+ printf "Player %s went inactive\n", $p->name;
+ delete $PLAYERS{$id};
+}
+
+# Top level handler to dispatch into the appropriate message.
+# Takes in the client ws id and the JSON msg and runs the
+# appropriate handler, which is responsible for responding via ws
+#
+# If action not part of dispatch table, assume it is a Dealer action.
+# ID the table of the Dealer of the client and dispatch to them
+sub handle_msg {
+ my ($cid, $msg) = @_;
+
+ my %dispatch = (
+ ping => \&pong,
+ join_table => \&join_table,
+ leave_table => \&leave_table,
+ list_tables => \&list_tables,
+ );
+
+ my $p = $PLAYERS{$cid};
+ if (!defined $p) {
+ # Unknown client -- warn and return
+ warn localtime(time) . " Unknown client contacting server\n";
+ return;
+ }
+
+ if (exists $dispatch{$msg->{action}}) {
+ $dispatch{$msg->{action}}->($p, $msg);
+ } else {
+ require_table($p) or return;
+ my $d = $DEALERS{$PINDEX{$p->{id}}};
+ $d->handle_msg($cid, $msg);
+ }
+}
+
+
+# Checks that client at a table, sends error if not
+# Returns 1 if at table, else 0
+sub require_table {
+ my ($p) = @_;
+
+ my $at_table = exists $PINDEX{$p->{id}};
+ if (!$at_table) {
+ $p->error(NOT_AT_TABLE);
+ }
+
+ return $at_table;
+}
+
+sub pong {
+ my ($p) = @_;
+ $p->send({ msg_type => 'pong' });
+}
+
+
+# player_name
+# table
+# password (opt)
+sub join_table {
+ my ($p, $msg) = @_;
+
+ my $tid = $msg->{table};
+
+ $p->name($msg->{player_name});
+
+ # init table if needed
+ if (!exists $DEALERS{$tid}) {
+ $DEALERS{$tid} = Euchre::Dealer->new(
+ id => $tid,
+ start_time => time,
+ (exists $msg->{password} ? (password => $msg->{password}) : ()),
+ );
+ $TOTAL_TABLES++;
+ }
+
+ my $d = $DEALERS{$tid};
+ if (my $errno = $d->add_player($p, $msg->{password})) {
+ $p->error($errno);
+ } else {
+ $PINDEX{$p->{id}} = $tid;
+ }
+}
+
+sub leave_table {
+ my ($p) = @_;
+
+ require_table($p) or return;
+
+ # Let the dealer do its own cleanup, then cleanup our state
+ my $d = $DEALERS{$PINDEX{$p->{id}}};
+ if (my $errno = $d->remove_player($p)) {
+ $p->error($errno);
+ } else {
+ delete $PINDEX{$p->{id}};
+ }
+}
+
+sub list_tables {
+ my ($p) = @_;
+
+ # TODO: send more...
+ $p->send({
+ msg_type => 'list',
+ tables => [map { $_->name } values %DEALERS],
+ });
+}
+
+
+# Global server stats for games in progress
+# Poor man's monitoring :)
+sub stats {
+ my $num_tables = scalar keys %DEALERS;
+ my $num_players = scalar keys %PLAYERS;
+
+ my $msg = "";
+ $msg .= "Tables: Start Time\tTable tname\tPlayer name\n";
+ $msg .= "===========================================================\n";
+ for my $d (values %DEALERS) {
+ $msg .= localtime($d->start_time) . "\t" . $d->id . "\n";
+ for my $p (values %{$d->players}) {
+ $msg .= localtime($p->start_time) . "\t\t" . $p->name . "\n";
+ }
+ }
+ $msg .= "-----------------------------------------------------------\n";
+ $msg .= "$num_tables\tTables\n";
+ $msg .= "$num_players\tPlayers\n";
+
+ $msg .= "\n\nServer Stats\n";
+ $msg .= "===========================================================\n";
+ $msg .= "Server Start: $START_TIME\n";
+ $msg .= "Lifetime Tables: $TOTAL_TABLES\n";
+ $msg .= "Lifetime Players: $TOTAL_PLAYERS\n";
+ $msg .= "-----------------------------------------------------------\n";
+ $msg .= "\n\nUptime: " . `uptime`;
+
+ return $msg;
+}
+
+1;
diff --git a/lib/Euchre/Player.pm b/lib/Euchre/Player.pm
@@ -6,19 +6,9 @@ package Euchre::Player;
use Euchre::Errors;
-# {
-# id => client id (key in %PLAYERS)
-# name => username,
-# seat => undef OR 0-3,
-# ws => websocket obj,
-# active => ...
-# }
-#
-use Class::Tiny qw(id ws seat game), {
- joined => sub { time },
- name => 'Anon',
- hand => sub { [] },
- active => 1,
+use Class::Tiny qw(id ws start_time), {
+ seat => -1, # spectator
+ name => 'Anon',
};
sub error {
@@ -37,4 +27,19 @@ sub send {
$self->ws->send({ json => $json });
}
+sub is_spectator {
+ my ($self) = @_;
+ return $self->seat == -1;
+}
+
+sub stand_up {
+ my ($self) = @_;
+ if ($self->is_spectator) {
+ return ALREADY_STANDING;
+ } else {
+ $self->seat(-1);
+ }
+ return SUCCESS;
+}
+
1;
diff --git a/public/debug.html b/public/debug.html
@@ -38,9 +38,11 @@
}
document.getElementById('hand').innerHTML = 'HAND: <br>'
- for (var i = 0; i < msg.hand.length; i++) {
- var c = msg.hand[i]
- document.getElementById('hand').innerHTML += '<img onclick="play(' + "'" + c + "'" + ')" class="card" src="cards/' + c + '.svg">'
+ if (msg.hand) {
+ for (var i = 0; i < msg.hand.length; i++) {
+ var c = msg.hand[i]
+ document.getElementById('hand').innerHTML += '<img onclick="play(' + "'" + c + "'" + ')" class="card" src="cards/' + c + '.svg">'
+ }
}
if (msg.game.table) {
@@ -70,7 +72,7 @@
gname = document.getElementById('gamename').value;
pass = document.getElementById('password').value;
console.log('U: ' + uname + ' G: ' + gname);
- ws.send(JSON.stringify({action:'join_game', player_name: uname, game_id: gname, force: force, password: pass}))
+ ws.send(JSON.stringify({action:'join_table', player_name: uname, table: gname, force: force, password: pass}))
}
function sit() {
seat = document.getElementById('seat_no').value;
@@ -103,7 +105,7 @@
document.getElementById('chat').value = '';
}
function leaveGame() {
- ws.send(JSON.stringify({action:'leave_game'}))
+ ws.send(JSON.stringify({action:'leave_table'}))
}
window.setInterval(() => { ws.send(JSON.stringify({action:'ping'})) }, 5000);
