#!/usr/bin/perl -w use strict; use warnings; use POSIX; use Net::WebSocket::Server; use JSON; use Data::Dumper; # For debuging only, REMOVE WHEN INITIAL CODE IS FINISH #########################Game Logic starts here########################## my %sessions = (); sub generateSession { my $newSession = shift; unless (defined $newSession) { my $uniquifyer = sprintf("%.0f",rand()*1000); $newSession = time.$uniquifyer; } if ( grep( /$newSession/, keys %sessions ) ) { return 0 #failur to create session } else { print "Adding session ".$newSession." to database\n"; $sessions{$newSession} = { "id" => $newSession, "users" => {}, "decks" => {}, "pools" => {}, }; } return $newSession; } sub generateSingle { my $DDF = shift; my @cards = (""); for (@$DDF) { my @tempcards = (); my %datablock = %$_; for (@cards) { my $current = $_; for (@{$datablock{data}}) { push(@tempcards,$current.$_); } } @cards = @tempcards; } return @cards; } sub generateDeck { my $DDF = from_json(shift); if ("ARRAY" eq ref($DDF->[0])) { my @deck = (); for (@$DDF) { push(@deck,generateSingle($_)); } return @deck; } else { return generateSingle($DDF); } } sub shuffle { my @deck = @_; my $index = 0; for (@deck) { my $swapCardIndex = floor(rand() * @deck); my $swapCard = $deck[$swapCardIndex]; $deck[$swapCardIndex] = $_; $deck[$index] = $swapCard; $index++; } return \@deck; } sub shuffleDeck { my ($sessionID, $deckID) = @_; my @cards = @{$sessions{$sessionID}{"decks"}{$deckID}->{cards}}; $sessions{$sessionID}{"decks"}{$deckID}->{cards} = shuffle(@cards); } sub shufflePool { my ($sessionID, $poolID) = @_; my @cards = @{$sessions{$sessionID}{"pools"}{$poolID}->{cards}}; @{$sessions{$sessionID}{"pools"}{$poolID}->{cards}} = shuffle(@cards);; } sub shuffleHand { my ($sessionID, $userID, $handID) = @_; my @cards = @{$sessions{$sessionID}{"users"}{$userID}->{hands}{$handID}->{cards}}; $sessions{$sessionID}{"users"}{$userID}->{hands}{$handID}->{cards} = shuffle(@cards); } sub addUser { my ($sessionID,$userID) = @_; $sessions{$sessionID}{"users"}{$userID} = { name => "$userID", hands => {} }; addHand($sessionID,$userID,"default"); } sub addCards { my ($sessionID,$deckID, $cards) = @_; push(@{$sessions{$sessionID}{"decks"}{$deckID}->{cards}}, @$cards); } sub addDeck { my ($sessionID,$deckID) = @_; $sessions{$sessionID}{"decks"}{$deckID} = { name => "$deckID", cards => [] }; } sub delDeck { my ($sessionID,$deckID) = @_; delete($sessions{$sessionID}{"decks"}{$deckID}); } sub uploadDDF { my ($sessionID, $deckID, $DDF) = @_; addCards($sessionID,$deckID,\@{generateDeck($DDF)}); } sub addPool { my ($sessionID,$poolID) = @_; $sessions{$sessionID}{"pools"}{$poolID} = { name => "$poolID", cards => [] }; } sub reapCards { my $arrayRef = $_[0]; my @reapedCards = (); print "Reaping cards"; while(@{$arrayRef}) { push(@reapedCards,shift(@{$arrayRef})); print "."; } print "Done\nReaped:"; print join(", ",@reapedCards)."\n"; return @reapedCards; } sub delPool { my ($sessionID,$poolID) = @_; my @reapedCards = reapCards(\@{$sessions{$sessionID}{"pools"}{$poolID}->{cards}}); delete($sessions{$sessionID}{"pools"}{$poolID}); return @reapedCards; } sub getUsers { my $sessionID = $_[0]; return keys %{$sessions{$sessionID}{"users"}}; } sub getDecks { my $sessionID = $_[0]; return keys %{$sessions{$sessionID}{"decks"}}; } sub getPools { my $sessionID = $_[0]; return keys %{$sessions{$sessionID}{"pools"}}; } sub addHand { my ($sessionID, $userID, $handID) = @_; $sessions{$sessionID}{"users"}{$userID}{hands}{$handID} = { cards => [] }; } sub delHand { my ($sessionID, $userID, $handID) = @_; my @leftoverCards = reapCards(\@{$sessions{$sessionID}{"users"}{$userID}->{hands}{$handID}->{cards}}); delete($sessions{$sessionID}{"users"}{$userID}{hands}{$handID}); return @leftoverCards; } sub getHands { my ($sessionID, $userID) = @_; return keys %{$sessions{$sessionID}{"users"}{$userID}{hands}}; } sub moveCard { my ($originStackRef, $originIndex, $destStackRef, $destIndex) = @_; unless(defined($originStackRef)) { return print "ERROR: No Origin Stack\n"; } unless(defined($originIndex)) { return print "ERROR: No Origin Index\n"; } unless(defined($destStackRef)) { return print "ERROR: No Destination Stack\n"; } unless(defined($destIndex)) { return print "ERROR: No Destination Index\n"; } my $card = splice(@$originStackRef,$originIndex,1); unless(defined($card)) { return print "ERROR: No Card available to be pulled\n"; } splice(@$destStackRef,$destIndex,0,$card); } sub drawCard { my ($sessionID, $deckID, $userID, $handID) = @_; moveCard( $sessions{$sessionID}{"decks"}{$deckID}->{cards}, 0, $sessions{$sessionID}{"users"}{$userID}->{hands}{$handID}->{cards}, 0 ); } sub playCard { my ($sessionID, $userID, $handID, $cardIndex, $poolID) = @_; moveCard( \@{$sessions{$sessionID}{"users"}{$userID}->{hands}{$handID}->{cards}}, $cardIndex, \@{$sessions{$sessionID}{"pools"}{$poolID}->{cards}},0 ); } sub delUser { my ($sessionID,$userID) = @_; my @hands = getHands($sessionID,$userID); my @reaped = (); for (@hands) { push(@reaped,delHand($sessionID,$userID,$_)); } delete($sessions{$sessionID}{"users"}{$userID}); return @reaped; } sub getDeckSize { my ($sessionID, $deckID) = @_; return length $sessions{$sessionID}{"decks"}{$deckID}->{cards}; } ########################Game Logic ends here############################# #########################Server Logic below############################## my $origin = 'ws://localhost'; sub joinSession { } my $server = Net::WebSocket::Server->new( listen => 8080, on_connect => sub { my ($serv, $conn) = @_; $conn->on( handshake => sub { my ($conn,$handshake) = @_; $conn->{"initHand"} = $handshake; }, ready => sub { my ($conn) = @_; #strip the / off of the resource request and then assign just the request to $session #Check for game ID, if none generate one and send it then disconnect. #Check for user ID, if none $conn->disconnect("noid",generateUser()); }, utf8 => sub { my ($conn, $msg) = @_; my $sessionID = $conn->{"currentSession"}{"id"}; my $messageData = ""; eval { $messageData = from_json($msg) }; if ($@) { $conn->send_utf8('{"error":1, "message":"ERROR: Invalid json"}'); return 0;} }, disconnect => sub { my ($conn, $code, $reason) = @_; } ); } ); $server->start;