From f2683ace66da18c374166ad35a920ed0b27b5663 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Mon, 3 Aug 2020 15:37:00 +0200 Subject: Full game flow --- server/lib/Cafp/Game.hs | 151 +++++++++++++++++++++++-------- server/lib/Cafp/Main/GenerateElmTypes.hs | 3 +- server/lib/Cafp/Messages.hs | 57 +++++++----- 3 files changed, 147 insertions(+), 64 deletions(-) (limited to 'server/lib/Cafp') diff --git a/server/lib/Cafp/Game.hs b/server/lib/Cafp/Game.hs index 14228fd..379b3a5 100644 --- a/server/lib/Cafp/Game.hs +++ b/server/lib/Cafp/Game.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE RecordWildCards #-} @@ -19,26 +20,31 @@ module Cafp.Game ) where import Cafp.Messages -import Control.Lens (Lens', at, ix, orOf, over, to, - (%%=), (%=), (&), (.=), (.~), (^.), - (^..), (^?), _1, _2, _3) -import Control.Lens.TH (makeLenses, makePrisms) -import Control.Monad (guard) -import Control.Monad.State (State, execState, modify, runState, - state) -import Data.Bifunctor (first) -import qualified Data.HashMap.Strict as HMS -import Data.List (sort) -import Data.Maybe (fromMaybe) -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Vector as V -import System.Random (StdGen) -import VectorShuffling.Immutable (shuffle) +import Control.Lens (Lens', at, imap, ix, orOf, over, + to, (%%=), (%=), (&), (+=), (.=), + (.~), (^.), (^..), (^?), _1, _2, + _3) +import Control.Lens.TH (makeLenses, makePrisms) +import Control.Monad (guard) +import Data.Ord (comparing, Down (..)) +import Control.Monad.State (State, execState, modify, + runState, state) +import Data.Bifunctor (first) +import Data.Foldable (for_) +import qualified Data.HashMap.Strict as HMS +import Data.List (sort) +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Vector as V +import qualified Data.Vector.Algorithms.Merge as V +import Data.Vector.Instances () +import System.Random (StdGen) +import VectorShuffling.Immutable (shuffle) type PlayerId = Int -type Proposal = [WhiteCard] +type Proposal = V.Vector WhiteCard data Table = TableProposing @@ -48,12 +54,16 @@ data Table !BlackCard !(V.Vector (Proposal, [PlayerId])) !(HMS.HashMap PlayerId Int) + | TableTally + !BlackCard + !(V.Vector VotedView) deriving (Show) data Player = Player - { _playerName :: !Text - , _playerHand :: !(V.Vector WhiteCard) - , _playerAdmin :: !Bool + { _playerName :: !Text + , _playerHand :: !(V.Vector WhiteCard) + , _playerAdmin :: !Bool + , _playerPoints :: !Int } deriving (Show) data Game = Game @@ -119,7 +129,7 @@ joinGame = runState $ do pid <- gameNextPlayerId %%= (\x -> (x, x + 1)) let name = "Player " <> T.pack (show pid) hand <- V.replicateM 6 popWhiteCard - gamePlayers %= HMS.insert pid (Player name hand False) + gamePlayers %= HMS.insert pid (Player name hand False 0) modify assignAdmin pure pid @@ -130,9 +140,44 @@ blackCardBlanks :: Cards -> BlackCard -> Int blackCardBlanks cards (BlackCard c) = maybe 0 (length . T.breakOnAll "\\BLANK") $ cardsBlack cards V.!? c +maximaOn :: Ord o => (a -> o) -> [a] -> [a] +maximaOn f = \case [] -> []; x : xs -> go [x] (f x) xs + where + go best _ [] = reverse best + go best bestScore (x : xs) = + let score = f x in + case compare score bestScore of + LT -> go best bestScore xs + EQ -> go (x : best) bestScore xs + GT -> go [x] score xs + +tallyVotes + :: Game + -> (V.Vector (Proposal, [PlayerId])) + -> (HMS.HashMap PlayerId Int) + -> (V.Vector VotedView, [PlayerId]) +tallyVotes game shuffled votes = + let counts :: HMS.HashMap Int Int -- Index, votes received. + counts = HMS.fromListWith (+) [(idx, 1) | (_, idx) <- HMS.toList votes] + best = map fst . maximaOn snd $ HMS.toList counts in + ( byScore $ V.imap (\i (proposal, players) -> VotedView + { votedProposal = proposal + , votedScore = fromMaybe 0 $ HMS.lookup i counts + , votedWinners = V.fromList $ do + guard $ i `elem` best + p <- players + game ^.. gamePlayers . ix p . playerName + }) + shuffled + , [player | idx <- best, player <- snd $ shuffled V.! idx] + ) + where + byScore = V.modify $ V.sortBy . comparing $ Down . votedScore + stepGame :: Game -> Game stepGame game = case game ^. gameTable of TableProposing black proposals + -- Everyone has proposed. | HMS.null ((game ^. gamePlayers) `HMS.difference` proposals) -> let proposalsMap = HMS.fromListWith (++) $ do (pid, proposal) <- HMS.toList proposals @@ -142,12 +187,22 @@ stepGame game = case game ^. gameTable of game & gameSeed .~ seed & gameTable .~ TableVoting black shuffled HMS.empty | otherwise -> game - TableVoting _ _ _ -> game + TableVoting black shuffled votes + -- Everyone has voted. + | HMS.null ((game ^. gamePlayers) `HMS.difference` votes) -> + let (voted, wins) = tallyVotes game shuffled votes in + flip execState game $ do + for_ wins $ \win -> gamePlayers . ix win . playerPoints += 1 + gameTable .= TableTally black voted + | otherwise -> game + TableTally _ _ -> game processClientMessage :: PlayerId -> ClientMessage -> Game -> Game processClientMessage pid msg game = case msg of - ChangeMyName name -> - game & gamePlayers . ix pid . playerName .~ name + ChangeMyName name + | T.length name > 32 -> game + | otherwise -> game & gamePlayers . ix pid . playerName .~ name + ProposeWhiteCards cs -- Bad card(s) proposed, i.e. not in hand of player. | any (not . (`elem` hand)) cs -> game @@ -162,6 +217,7 @@ processClientMessage pid msg game = case msg of SubmitVote i -> case game ^. gameTable of TableProposing _ _ -> game + TableTally _ _ -> game TableVoting _ shuffled votes -- Vote out of bounds. | i < 0 || i >= V.length shuffled -> game @@ -172,32 +228,47 @@ processClientMessage pid msg game = case msg of -- Ok vote. | otherwise -> stepGame $ game & gameTable . _TableVoting . _3 . at pid .~ Just i + + ConfirmTally + | TableTally _ _ <- game ^. gameTable + , Just True <- game ^? gamePlayers . ix pid . playerAdmin -> + flip execState game $ do + black <- popBlackCard + gameTable .= TableProposing black HMS.empty + | otherwise -> game where hand = game ^.. gamePlayers . ix pid . playerHand . traverse gameViewForPlayer :: PlayerId -> Game -> GameView gameViewForPlayer self game = - let opponents = do - (pid, p) <- HMS.toList $ game ^. gamePlayers - guard $ pid /= self - let ready = case game ^. gameTable of - TableProposing _ proposals -> HMS.member pid proposals - TableVoting _ _ votes -> HMS.member pid votes - pure $ Opponent (p ^. playerName) (p ^. playerAdmin) ready - - player = game ^. gamePlayers . at self + let playerView pid player = PlayerView + { playerViewName = player ^. playerName + , playerViewAdmin = player ^. playerAdmin + , playerViewReady = case game ^. gameTable of + TableProposing _ proposals -> HMS.member pid proposals + TableVoting _ _ votes -> HMS.member pid votes + TableTally _ _ -> False + , playerViewPoints = player ^. playerPoints + } table = case game ^. gameTable of TableProposing black proposals -> - Proposing black . fromMaybe [] $ HMS.lookup self proposals + Proposing black . fromMaybe V.empty $ HMS.lookup self proposals TableVoting black shuffled votes -> Voting black - (fst <$> V.toList shuffled) + (fst <$> shuffled) (fromMaybe 0 $ V.findIndex ((self `elem`) . snd) shuffled) - (HMS.lookup self votes) in + (HMS.lookup self votes) + TableTally black voted -> Tally black voted in GameView - { gameViewOpponents = opponents - , gameViewMyName = maybe "" (^. playerName) player - , gameViewTable = table - , gameViewHand = player ^.. traverse . playerHand . traverse + { gameViewPlayers = V.fromList . map snd . HMS.toList + . HMS.delete self . imap playerView $ game ^. gamePlayers + , gameViewMe = maybe dummy (playerView self) $ + game ^? gamePlayers . ix self + , gameViewTable = table + , gameViewHand = fromMaybe V.empty $ + game ^? gamePlayers . ix self . playerHand } + + where + dummy = PlayerView "" False False 0 diff --git a/server/lib/Cafp/Main/GenerateElmTypes.hs b/server/lib/Cafp/Main/GenerateElmTypes.hs index b1e6efe..ccf19e8 100644 --- a/server/lib/Cafp/Main/GenerateElmTypes.hs +++ b/server/lib/Cafp/Main/GenerateElmTypes.hs @@ -13,7 +13,8 @@ main = putStrLn $ makeElmModule "Messages" [ DefineElm (Proxy :: Proxy BlackCard) , DefineElm (Proxy :: Proxy WhiteCard) , DefineElm (Proxy :: Proxy Cards) - , DefineElm (Proxy :: Proxy Opponent) + , DefineElm (Proxy :: Proxy PlayerView) + , DefineElm (Proxy :: Proxy VotedView) , DefineElm (Proxy :: Proxy TableView) , DefineElm (Proxy :: Proxy GameView) , DefineElm (Proxy :: Proxy ServerMessage) diff --git a/server/lib/Cafp/Messages.hs b/server/lib/Cafp/Messages.hs index cfc8597..4e5123d 100644 --- a/server/lib/Cafp/Messages.hs +++ b/server/lib/Cafp/Messages.hs @@ -4,7 +4,8 @@ module Cafp.Messages ( BlackCard (..) , WhiteCard (..) , Cards (..) - , Opponent (..) + , PlayerView (..) + , VotedView (..) , TableView (..) , GameView (..) , ServerMessage (..) @@ -26,49 +27,59 @@ data WhiteCard = WhiteCard Int deriving (Eq, Generic, Show) instance Hashable WhiteCard data Cards = Cards - { cardsBlack :: Vector Text - , cardsWhite :: Vector Text + { cardsBlack :: !(Vector Text) + , cardsWhite :: !(Vector Text) } deriving (Show) -data Opponent = Opponent - { opponentName :: Text - , opponentAdmin :: Bool - , opponentReady :: Bool +data PlayerView = PlayerView + { playerViewName :: !Text + , playerViewAdmin :: !Bool + , playerViewReady :: !Bool + , playerViewPoints :: !Int + } deriving (Show) + +data VotedView = VotedView + { votedProposal :: !(Vector WhiteCard) + , votedScore :: !Int + , votedWinners :: !(Vector Text) } deriving (Show) data TableView - = Proposing BlackCard [WhiteCard] + = Proposing !BlackCard !(Vector WhiteCard) | Voting - BlackCard - [[WhiteCard]] -- ^ Proposals to vote for - Int -- ^ My proposal - (Maybe Int) -- ^ My vote + !BlackCard + !(Vector (Vector WhiteCard)) -- ^ Proposals to vote for + !Int -- ^ My proposal + !(Maybe Int) -- ^ My vote + | Tally !BlackCard !(Vector VotedView) deriving (Show) data GameView = GameView - { gameViewOpponents :: [Opponent] - , gameViewMyName :: Text - , gameViewTable :: TableView - , gameViewHand :: [WhiteCard] + { gameViewPlayers :: !(Vector PlayerView) + , gameViewMe :: !PlayerView + , gameViewTable :: !TableView + , gameViewHand :: !(Vector WhiteCard) } deriving (Show) data ServerMessage - = Welcome Int - | SyncCards Cards - | SyncGameView GameView + = Welcome !Int + | SyncCards !Cards + | SyncGameView !GameView | Bye deriving (Show) data ClientMessage - = ChangeMyName Text - | ProposeWhiteCards [WhiteCard] - | SubmitVote Int + = ChangeMyName !Text + | ProposeWhiteCards !(Vector WhiteCard) + | SubmitVote !Int + | ConfirmTally deriving (Show) deriveBoth defaultOptions ''BlackCard deriveBoth defaultOptions ''WhiteCard deriveBoth (defaultOptionsDropLower 5) ''Cards -deriveBoth (defaultOptionsDropLower 8) ''Opponent +deriveBoth (defaultOptionsDropLower 10) ''PlayerView +deriveBoth (defaultOptionsDropLower 5) ''VotedView deriveBoth defaultOptions ''TableView deriveBoth (defaultOptionsDropLower 8) ''GameView deriveBoth defaultOptions ''ServerMessage -- cgit v1.2.3