aboutsummaryrefslogtreecommitdiff
path: root/server
diff options
context:
space:
mode:
Diffstat (limited to 'server')
-rw-r--r--server/cafp.cabal2
-rw-r--r--server/lib/Cafp/Game.hs151
-rw-r--r--server/lib/Cafp/Main/GenerateElmTypes.hs3
-rw-r--r--server/lib/Cafp/Messages.hs57
4 files changed, 149 insertions, 64 deletions
diff --git a/server/cafp.cabal b/server/cafp.cabal
index 14ef7ad..f80184c 100644
--- a/server/cafp.cabal
+++ b/server/cafp.cabal
@@ -35,6 +35,8 @@ Library
text >= 1.2 && < 1.3,
unordered-containers >= 0.2 && < 0.3,
vector >= 0.12 && < 0.13,
+ vector-algorithms >= 0.8 && < 0.9,
+ vector-instances >= 3.4 && < 3.5,
vector-shuffling >= 1.1 && < 1.2,
wai >= 3.2 && < 3.3,
wai-websockets >= 3.0 && < 3.1,
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
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-22 15:41:33 +0000