diff options
Diffstat (limited to 'server/lib/Cafp/Game.hs')
| -rw-r--r-- | server/lib/Cafp/Game.hs | 332 |
1 files changed, 0 insertions, 332 deletions
diff --git a/server/lib/Cafp/Game.hs b/server/lib/Cafp/Game.hs deleted file mode 100644 index 9ed3cc1..0000000 --- a/server/lib/Cafp/Game.hs +++ /dev/null @@ -1,332 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -module Cafp.Game - ( PlayerId - , Table (..) - , Player (..) - , Game (..) - , gameLog, gameCards, gamePlayers, gameNextPlayerId - - , newGame - , joinGame - , leaveGame - - , processClientMessage - - , gameViewForPlayer - ) where - -import Cafp.Messages -import Control.Lens (Lens', at, iall, ifor_, imap, ix, - orOf, 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 Data.Foldable (for_) -import qualified Data.HashMap.Strict as HMS -import Data.List (sort) -import Data.Maybe (fromMaybe) -import Data.Ord (Down (..), comparing) -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 = V.Vector WhiteCard - -data Table - = TableProposing - !BlackCard - !(HMS.HashMap PlayerId Proposal) - | TableVoting - !BlackCard - !(V.Vector (Proposal, [PlayerId])) - !(HMS.HashMap PlayerId Int) - | TableTally - !BlackCard - !(V.Vector VotedView) - deriving (Show) - -data Player = Player - { _playerId :: !PlayerId - , _playerName :: !Text - , _playerHand :: !(V.Vector WhiteCard) - , _playerAdmin :: !Bool - , _playerPoints :: !Int - } deriving (Show) - -data Game = Game - { _gameCards :: !Cards - , _gameSeed :: !StdGen - , _gameLog :: ![Text] - , _gameBlack :: ![BlackCard] - , _gameWhite :: ![WhiteCard] - , _gamePlayers :: !(HMS.HashMap PlayerId Player) - , _gameTable :: !Table - , _gameNextPlayerId :: !Int - } deriving (Show) - -makePrisms ''Table -makeLenses ''Player -makeLenses ''Game - -popCard - :: (Cards -> V.Vector t) -> (Int -> c) -> Lens' Game [c] - -> State Game c -popCard getDeck mk queue = state $ \game -> case game ^. queue of - (x : xs) -> (x, game & queue .~ xs) - [] -> - let deck = game ^. gameCards . to getDeck - idxs = V.imap (\i _ -> mk i) deck - (cs, seed) = first V.toList $ shuffle idxs (game ^. gameSeed) in - case cs of - [] -> error "popCard: Cards are empty" - x : xs -> (x, game & queue .~ xs & gameSeed .~ seed) - -popBlackCard :: State Game BlackCard -popBlackCard = popCard cardsBlack BlackCard gameBlack - -popWhiteCard :: State Game WhiteCard -popWhiteCard = popCard cardsWhite WhiteCard gameWhite - -newGame :: Cards -> StdGen -> Game -newGame cards gen = flip execState state0 $ do - black <- popBlackCard - gameTable .= TableProposing black HMS.empty - where - state0 = Game - { _gameCards = cards - , _gameSeed = gen - , _gameLog = [] - , _gameBlack = [] - , _gameWhite = [] - , _gamePlayers = HMS.empty - , _gameTable = TableProposing (BlackCard 0) HMS.empty - , _gameNextPlayerId = 1 - } - -defaultHandSize :: Int -defaultHandSize = 8 - -drawNewWhiteCards :: Game -> Game -drawNewWhiteCards game = flip execState game $ do - ifor_ (game ^. gamePlayers) $ \pid player -> do - let num = defaultHandSize - V.length (player ^. playerHand) - new <- V.replicateM num popWhiteCard - gamePlayers . ix pid . playerHand %= (<> new) - -assignAdmin :: Game -> Game -assignAdmin game - -- Admin already assigned. - | orOf (gamePlayers . traverse . playerAdmin) game = game - -- Assign to first player - | (p1 : _) <- sort (game ^. gamePlayers . to HMS.keys) = - game & gamePlayers . ix p1 . playerAdmin .~ True - -- No players - | otherwise = game - -joinGame :: Maybe Player -> Game -> (PlayerId, Game) -joinGame mbPlayer = runState $ do - player <- case mbPlayer of - Nothing -> do - pid <- gameNextPlayerId %%= (\x -> (x, x + 1)) - let name = "Player " <> T.pack (show pid) - hand <- V.replicateM defaultHandSize popWhiteCard - pure $ Player pid name hand False 0 - Just p -> pure $ p & playerAdmin .~ False - gamePlayers %= HMS.insert (player ^. playerId) player - modify assignAdmin - pure $ player ^. playerId - -leaveGame :: PlayerId -> Game -> (Maybe Player, Game) -leaveGame pid game = case game ^? gamePlayers . ix pid of - Nothing -> (Nothing, game) - Just p -> (Just p, assignAdmin $ game & gamePlayers %~ HMS.delete pid) - -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 - --- | Create nice messages about the winners in the logs. -votedMessages :: Cards -> BlackCard -> V.Vector VotedView -> [T.Text] -votedMessages cards (BlackCard black) voteds = do - voted <- V.toList voteds - guard $ V.length (votedWinners voted) > 0 - pure $ - T.intercalate ", " (V.toList $ votedWinners voted) <> " won with " <> - cardsBlack cards V.! black <> " | " <> - T.intercalate " / " - [ cardsWhite cards V.! i - | WhiteCard i <- V.toList $ votedProposal voted - ] - -stepGame :: Bool -> Game -> Game -stepGame skip game = case game ^. gameTable of - TableProposing black proposals - -- Everyone has proposed. - | skip || iall (const . (`HMS.member` proposals)) (game ^. gamePlayers) -> - let proposalsMap = HMS.fromListWith (++) $ do - (pid, proposal) <- HMS.toList proposals - pure (proposal, [pid]) - (shuffled, seed) = shuffle - (V.fromList $ HMS.toList proposalsMap) (game ^. gameSeed) in - -- There's a recursive call because in some one-player cases we - -- skip the voting process entirely. - stepGame False $ game - & gameSeed .~ seed - & gameTable .~ TableVoting black shuffled HMS.empty - & gamePlayers %~ imap (\pid player -> - let used = fromMaybe V.empty $ HMS.lookup pid proposals in - player & playerHand %~ V.filter (not . (`V.elem` used))) - | otherwise -> game - - TableVoting black shuffled votes - -- Everyone has voted. - | skip || iall hasVoted (game ^. gamePlayers) -> - let (voted, wins) = tallyVotes game shuffled votes in - flip execState game $ do - for_ wins $ \win -> gamePlayers . ix win . playerPoints += 1 - gameTable .= TableTally black voted - gameLog %= (votedMessages (game ^. gameCards) black voted ++) - | otherwise -> game - where - hasVoted pid _ = HMS.member pid votes || - -- The person cannot vote for anything since all the proposals - -- are theirs. This can happen when the game starts out with a - -- single person. - V.all (\(_, pids) -> pid `elem` pids) shuffled - - TableTally _ _ -> game - -processClientMessage :: PlayerId -> ClientMessage -> Game -> Game -processClientMessage pid msg game = case msg of - 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 - -- Proposal already made. - | Just _ <- game ^? gameTable . _TableProposing . _2 . ix pid -> game - -- Not enough cards submitted. - | Just b <- game ^? gameTable . _TableProposing . _1 - , blackCardBlanks (game ^. gameCards) b /= length cs -> game - -- All good. - | otherwise -> stepGame False $ - game & gameTable . _TableProposing . _2 . at pid .~ Just cs - - SubmitVote i -> case game ^. gameTable of - TableProposing _ _ -> game - TableTally _ _ -> game - TableVoting _ shuffled votes - -- Vote out of bounds. - | i < 0 || i >= V.length shuffled -> game - -- Already voted. - | pid `HMS.member` votes -> game - -- Can't vote for self. - | pid `elem` snd (shuffled V.! i) -> game - -- Ok vote. - | otherwise -> stepGame False $ game - & gameTable . _TableVoting . _3 . at pid .~ Just i - - AdminConfirmTally - | TableTally _ _ <- game ^. gameTable, admin -> - flip execState game $ do - black <- popBlackCard - gameTable .= TableProposing black HMS.empty - modify drawNewWhiteCards - | otherwise -> game - - AdminSkipProposals - | TableProposing _ _ <- game ^. gameTable, admin -> stepGame True $ - game & gameLog %~ ("Admin skipped proposals" :) - | otherwise -> game - - AdminSkipVotes - | TableVoting _ _ _ <- game ^. gameTable, admin -> stepGame True $ - game & gameLog %~ ("Admin skipped votes" :) - | otherwise -> game - where - hand = game ^.. gamePlayers . ix pid . playerHand . traverse - admin = fromMaybe False $ game ^? gamePlayers . ix pid . playerAdmin - -gameViewForPlayer :: PlayerId -> Game -> GameView -gameViewForPlayer self game = - 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 V.empty $ HMS.lookup self proposals - TableVoting black shuffled votes -> Voting - black - (fst <$> shuffled) - (V.findIndex ((self `elem`) . snd) shuffled) - (HMS.lookup self votes) - TableTally black voted -> Tally black voted in - GameView - { 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 |