From 5a1586d0a5745da547254558e8f1de8e2a94c469 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Fri, 31 Jul 2020 19:39:40 +0200 Subject: Shuffling --- server/cafp.cabal | 3 ++ server/lib/Cafp/Game.hs | 89 ++++++++++++++++++++++++----------------- server/lib/Cafp/InfiniteDeck.hs | 36 +++++++++++++++++ server/lib/Cafp/Main/Server.hs | 32 +++++++-------- server/lib/Cafp/Messages.hs | 4 +- server/stack.yaml | 2 + server/stack.yaml.lock | 9 ++++- 7 files changed, 119 insertions(+), 56 deletions(-) create mode 100644 server/lib/Cafp/InfiniteDeck.hs diff --git a/server/cafp.cabal b/server/cafp.cabal index 9bb2250..3d605fd 100644 --- a/server/cafp.cabal +++ b/server/cafp.cabal @@ -17,6 +17,7 @@ Library Exposed-modules: Cafp.Game + Cafp.InfiniteDeck Cafp.Messages Cafp.Main.GenerateElmTypes Cafp.Main.Server @@ -27,11 +28,13 @@ Library bytestring >= 0.10 && < 0.11, elm-bridge >= 0.5 && < 0.6, lens >= 4.18 && < 4.19, + random >= 1.1 && < 1.2, scotty >= 0.11 && < 0.12, stm >= 2.5 && < 2.6, text >= 1.2 && < 1.3, unordered-containers >= 0.2 && < 0.3, vector >= 0.12 && < 0.13, + vector-shuffling >= 1.1 && < 1.2, wai >= 3.2 && < 3.3, wai-websockets >= 3.0 && < 3.1, warp >= 3.3 && < 3.4, diff --git a/server/lib/Cafp/Game.hs b/server/lib/Cafp/Game.hs index bb734a1..e170370 100644 --- a/server/lib/Cafp/Game.hs +++ b/server/lib/Cafp/Game.hs @@ -1,9 +1,11 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE Rank2Types #-} module Cafp.Game ( PlayerId - , Cards (..) + , Table (..) + , Player (..) , Game (..) , gameCards, gamePlayers, gameNextPlayerId @@ -17,16 +19,17 @@ module Cafp.Game ) where import Cafp.Messages -import Debug.Trace -import Control.Lens (at, ix, over, to, (%~), (&), (.~), (^.), - (^?), _1, _2) -import Control.Lens.TH (makeLenses, makePrisms) -import Control.Monad (guard) -import qualified Data.HashMap.Strict as HMS -import Data.Maybe (fromMaybe) -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Vector as V +import Control.Lens (at, ix, over, to, (%~), (&), (.~), + (^.), (^..), (^?), _1, _2, traverseOf, Lens') +import Control.Lens.TH (makeLenses, makePrisms) +import Control.Monad (guard, (>=>)) +import qualified Data.HashMap.Strict as HMS +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Cafp.InfiniteDeck as InfiniteDeck +import Cafp.InfiniteDeck (InfiniteDeck) +import qualified Data.Vector as V type PlayerId = Int @@ -34,30 +37,49 @@ data Table = TableProposing BlackCard (HMS.HashMap PlayerId [WhiteCard]) deriving (Show) +data Player = Player + { _playerName :: Text + , _playerHand :: [WhiteCard] + } deriving (Show) + data Game = Game { _gameCards :: !Cards - , _gamePlayers :: !(HMS.HashMap PlayerId Text) + , _gameBlack :: !(InfiniteDeck BlackCard) + , _gameWhite :: !(InfiniteDeck WhiteCard) + , _gamePlayers :: !(HMS.HashMap PlayerId Player) , _gameTable :: !Table , _gameNextPlayerId :: !Int } deriving (Show) makePrisms ''Table +makeLenses ''Player makeLenses ''Game -newGame :: Cards -> Game -newGame cards = Game - { _gameCards = cards - , _gamePlayers = HMS.empty - , _gameTable = TableProposing (BlackCard 0) HMS.empty - , _gameNextPlayerId = 1 - } +newGame :: Cards -> IO Game +newGame cards = do + black <- newDeck BlackCard $ cardsBlack cards + white <- newDeck WhiteCard $ cardsWhite cards + pure Game + { _gameCards = cards + , _gameBlack = black + , _gameWhite = white + , _gamePlayers = HMS.empty + , _gameTable = TableProposing (BlackCard 0) HMS.empty + , _gameNextPlayerId = 1 + } + where + newDeck f = InfiniteDeck.newIO . V.imap (\i _ -> f i) joinGame :: Game -> (PlayerId, Game) joinGame game = let pid = game ^. gameNextPlayerId - name = "Player " <> T.pack (show pid) in + name = "Player " <> T.pack (show pid) + (hand, white) = InfiniteDeck.popN 6 (game ^. gameWhite) in ( pid - , game & gameNextPlayerId %~ succ & gamePlayers %~ HMS.insert pid name + , game + & gameNextPlayerId %~ succ + & gamePlayers %~ HMS.insert pid (Player name hand) + & gameWhite .~ white ) leaveGame :: PlayerId -> Game -> Game @@ -67,45 +89,40 @@ blackCardBlanks :: Cards -> BlackCard -> Int blackCardBlanks cards (BlackCard c) = maybe 0 (length . T.breakOnAll "\\BLANK") $ cardsBlack cards V.!? c -validWhiteCard :: Cards -> WhiteCard -> Bool -validWhiteCard cards (WhiteCard c) = - let len = V.length $ cardsWhite cards in c >= 0 && c < len - processClientMessage :: PlayerId -> ClientMessage -> Game -> Game processClientMessage pid msg game = case msg of ChangeMyName name -> - game & gamePlayers . ix pid .~ name + game & gamePlayers . ix pid . playerName .~ name ProposeWhiteCards cs -- Bad card(s) proposed. - | any (not . validWhiteCard (game ^. gameCards)) cs -> game + | 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 -> trace - ("bad length " ++ show (length cs) ++ - " expected " ++ show (blackCardBlanks (game ^. gameCards) b)) - game + , blackCardBlanks (game ^. gameCards) b /= length cs -> game -- TODO: Check that the card is in the hand of the player. | otherwise -> game & gameTable . _TableProposing . _2 . at pid .~ Just cs + where + hand = game ^.. gamePlayers . ix pid . playerHand . traverse gameViewForPlayer :: PlayerId -> Game -> GameView gameViewForPlayer self game = let opponents = do - (pid, oname) <- HMS.toList $ game ^. gamePlayers + (pid, p) <- HMS.toList $ game ^. gamePlayers guard $ pid /= self - pure $ Opponent oname $ case game ^. gameTable of + pure $ Opponent (p ^. playerName) $ case game ^. gameTable of TableProposing _ proposals -> HMS.member pid proposals - name = fromMaybe "" $ game ^. gamePlayers . at self + player = game ^. gamePlayers . at self table = case game ^. gameTable of TableProposing black proposals -> Proposing black . fromMaybe [] $ HMS.lookup self proposals in GameView { gameViewOpponents = opponents - , gameViewMyName = name + , gameViewMyName = maybe "" (^. playerName) player , gameViewTable = table - , gameViewHand = [WhiteCard x | x <- [0 .. 9]] + , gameViewHand = maybe [] (^. playerHand) player } diff --git a/server/lib/Cafp/InfiniteDeck.hs b/server/lib/Cafp/InfiniteDeck.hs new file mode 100644 index 0000000..8772011 --- /dev/null +++ b/server/lib/Cafp/InfiniteDeck.hs @@ -0,0 +1,36 @@ +module Cafp.InfiniteDeck + ( InfiniteDeck + , new + , newIO + , pop + , popN + ) where + +import Data.List (intercalate) +import qualified Data.Vector as V +import System.Random (StdGen, newStdGen) +import VectorShuffling.Immutable (shuffle) + +newtype InfiniteDeck a = InfiniteDeck [a] + +instance Show a => Show (InfiniteDeck a) where + show (InfiniteDeck xs) = + "[" ++ intercalate ", " (map show $ take 5 xs) ++ "...]" + +new :: V.Vector a -> StdGen -> InfiniteDeck a +new vec gen0 + | V.null vec = error "Cafp.InfiniteDeck.new: empty vector" + | otherwise = InfiniteDeck (V.toList x ++ xs) + where + (x, gen1) = shuffle vec gen0 + InfiniteDeck xs = new vec gen1 + +newIO :: V.Vector a -> IO (InfiniteDeck a) +newIO vec = new vec <$> newStdGen + +pop :: InfiniteDeck a -> (a, InfiniteDeck a) +pop (InfiniteDeck []) = error "Cafp.InfiniteDeck.pop: empty" +pop (InfiniteDeck (x : xs)) = (x, InfiniteDeck xs) + +popN :: Int -> InfiniteDeck a -> ([a], InfiniteDeck a) +popN n (InfiniteDeck xs) = let (ys, zs) = splitAt n xs in (ys, InfiniteDeck zs) diff --git a/server/lib/Cafp/Main/Server.hs b/server/lib/Cafp/Main/Server.hs index 3a99672..fc31cec 100644 --- a/server/lib/Cafp/Main/Server.hs +++ b/server/lib/Cafp/Main/Server.hs @@ -6,6 +6,8 @@ module Cafp.Main.Server import Cafp.Game import Cafp.Messages import Control.Concurrent (threadDelay) +import Control.Concurrent.MVar (MVar) +import qualified Control.Concurrent.MVar as MVar import Control.Concurrent.STM (STM, TVar, atomically) import qualified Control.Concurrent.STM as STM import Control.Exception (bracket) @@ -44,7 +46,7 @@ data Room = Room data Server = Server { serverCards :: Cards - , serverRooms :: TVar (HMS.HashMap RoomId Room) + , serverRooms :: MVar (HMS.HashMap RoomId Room) } readCards :: IO Cards @@ -56,12 +58,12 @@ readCards = Cards filter (not . T.isPrefixOf "#") . filter (not . T.null) . T.lines newServer :: IO Server -newServer = Server <$> readCards <*> atomically (STM.newTVar HMS.empty) +newServer = Server <$> readCards <*> MVar.newMVar HMS.empty -newRoom :: Server -> STM Room +newRoom :: Server -> IO Room newRoom server = Room - <$> STM.newTVar (newGame $ serverCards server) - <*> STM.newTVar HMS.empty + <$> (STM.newTVarIO =<< newGame (serverCards server)) + <*> STM.newTVarIO HMS.empty scottyApp :: IO Wai.Application scottyApp = Scotty.scottyApp $ do @@ -87,15 +89,13 @@ routePendingConnection pending = [_, "rooms", roomId, "events"] -> Just roomId _ -> Nothing -getOrCreateRoom :: Server -> RoomId -> STM Room -getOrCreateRoom server roomId = do - rooms <- STM.readTVar $ serverRooms server +getOrCreateRoom :: Server -> RoomId -> IO Room +getOrCreateRoom server roomId = MVar.modifyMVar (serverRooms server) $ \rooms -> case HMS.lookup roomId rooms of - Just room -> pure room + Just room -> pure (rooms, room) Nothing -> do room <- newRoom server - STM.writeTVar (serverRooms server) $ HMS.insert roomId room rooms - pure room + pure (HMS.insert roomId room rooms, room) joinRoom :: Room -> Sink -> STM PlayerId joinRoom room sink = do @@ -122,7 +122,7 @@ wsApp :: Server -> WS.ServerApp wsApp server pc = case routePendingConnection pc of Nothing -> WS.rejectRequest pc "Invalid URL" Just roomId -> do - room <- atomically $ getOrCreateRoom server roomId + room <- getOrCreateRoom server roomId conn <- WS.acceptRequest pc let sink = WS.sendTextData conn WS.withPingThread conn 30 (pure ()) $ bracket @@ -142,11 +142,9 @@ wsApp server pc = case routePendingConnection pc of case Aeson.decode msg of Just cm -> do warning $ "Client: " ++ show cm - room <- atomically $ do - room <- getOrCreateRoom server roomId - STM.modifyTVar' (roomGame room) $ - processClientMessage playerId cm - pure room + room <- getOrCreateRoom server roomId -- TODO: only get? + atomically . STM.modifyTVar' (roomGame room) $ + processClientMessage playerId cm syncRoom room Nothing -> do warning $ "Could not decode client message: " ++ show msg diff --git a/server/lib/Cafp/Messages.hs b/server/lib/Cafp/Messages.hs index 1b37380..aae49cc 100644 --- a/server/lib/Cafp/Messages.hs +++ b/server/lib/Cafp/Messages.hs @@ -14,9 +14,9 @@ import Data.Text (Text) import Data.Vector (Vector) import Elm.Derive -data BlackCard = BlackCard Int deriving (Show) +data BlackCard = BlackCard Int deriving (Eq, Show) -data WhiteCard = WhiteCard Int deriving (Show) +data WhiteCard = WhiteCard Int deriving (Eq, Show) data Cards = Cards { cardsBlack :: Vector Text diff --git a/server/stack.yaml b/server/stack.yaml index bb5262d..74734a0 100644 --- a/server/stack.yaml +++ b/server/stack.yaml @@ -1,3 +1,5 @@ resolver: 'lts-15.6' packages: - '.' +extra-deps: +- 'vector-shuffling-1.1' diff --git a/server/stack.yaml.lock b/server/stack.yaml.lock index ebcdead..fb61cd3 100644 --- a/server/stack.yaml.lock +++ b/server/stack.yaml.lock @@ -3,7 +3,14 @@ # For more information, please see the documentation at: # https://docs.haskellstack.org/en/stable/lock_files -packages: [] +packages: +- completed: + hackage: vector-shuffling-1.1@sha256:c296c3a8571d8cee52a04de577284c639496e45b695d323804148840a0bee00c,1479 + pantry-tree: + size: 384 + sha256: b6e528bcc95d161dd1b1ee60e181cfd9320edf434efa9e823b40df3ad5ce1b57 + original: + hackage: vector-shuffling-1.1 snapshots: - completed: size: 491387 -- cgit v1.2.3