diff options
Diffstat (limited to 'server/lib/Cafp')
-rw-r--r-- | server/lib/Cafp/Game.hs | 79 | ||||
-rw-r--r-- | server/lib/Cafp/InfiniteDeck.hs | 36 | ||||
-rw-r--r-- | server/lib/Cafp/Main/Server.hs | 21 |
3 files changed, 58 insertions, 78 deletions
diff --git a/server/lib/Cafp/Game.hs b/server/lib/Cafp/Game.hs index ead1445..fa1c4aa 100644 --- a/server/lib/Cafp/Game.hs +++ b/server/lib/Cafp/Game.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE Rank2Types #-} module Cafp.Game ( PlayerId , Table (..) @@ -19,17 +19,20 @@ module Cafp.Game ) where import Cafp.Messages -import Control.Lens (at, ix, over, to, (%~), (&), (.~), - (^.), (^..), (^?), _1, _2, traverseOf, Lens') +import Control.Lens (Lens', at, ix, over, to, traverseOf, + (%%=), (%=), (%~), (&), (.~), (^.), + (^..), (^?), _1, _2, (.=)) import Control.Lens.TH (makeLenses, makePrisms) -import Control.Monad (guard, (>=>)) +import Control.Monad (guard, replicateM, (>=>)) +import Control.Monad.State (State, state, execState, runState) import qualified Data.HashMap.Strict as HMS import Data.Maybe (fromMaybe) +import Data.Bifunctor (first) 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 +import System.Random (StdGen) +import VectorShuffling.Immutable (shuffle) type PlayerId = Int @@ -38,14 +41,15 @@ data Table deriving (Show) data Player = Player - { _playerName :: Text - , _playerHand :: [WhiteCard] + { _playerName :: Text + , _playerHand :: [WhiteCard] } deriving (Show) data Game = Game { _gameCards :: !Cards - , _gameBlack :: !(InfiniteDeck BlackCard) - , _gameWhite :: !(InfiniteDeck WhiteCard) + , _gameSeed :: !StdGen + , _gameBlack :: ![BlackCard] + , _gameWhite :: ![WhiteCard] , _gamePlayers :: !(HMS.HashMap PlayerId Player) , _gameTable :: !Table , _gameNextPlayerId :: !Int @@ -55,32 +59,47 @@ makePrisms ''Table makeLenses ''Player makeLenses ''Game -newGame :: Cards -> IO Game -newGame cards = do - black <- fmap InfiniteDeck.pop . newDeck BlackCard $ cardsBlack cards - white <- newDeck WhiteCard $ cardsWhite cards - pure 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 - , _gameBlack = snd black - , _gameWhite = white + , _gameSeed = gen + , _gameBlack = [] + , _gameWhite = [] , _gamePlayers = HMS.empty - , _gameTable = TableProposing (fst black) 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) - (hand, white) = InfiniteDeck.popN 6 (game ^. gameWhite) in - ( pid - , game - & gameNextPlayerId %~ succ - & gamePlayers %~ HMS.insert pid (Player name hand) - & gameWhite .~ white - ) +joinGame = runState $ do + pid <- gameNextPlayerId %%= (\x -> (x, x + 1)) + let name = "Player " <> T.pack (show pid) + hand <- replicateM 6 popWhiteCard + gamePlayers %= HMS.insert pid (Player name hand) + pure pid leaveGame :: PlayerId -> Game -> Game leaveGame pid = over gamePlayers $ HMS.delete pid diff --git a/server/lib/Cafp/InfiniteDeck.hs b/server/lib/Cafp/InfiniteDeck.hs deleted file mode 100644 index 8772011..0000000 --- a/server/lib/Cafp/InfiniteDeck.hs +++ /dev/null @@ -1,36 +0,0 @@ -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 5c8f08b..21cdb6f 100644 --- a/server/lib/Cafp/Main/Server.hs +++ b/server/lib/Cafp/Main/Server.hs @@ -5,7 +5,6 @@ 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) @@ -14,22 +13,19 @@ import Control.Exception (bracket) import Control.Lens ((^.)) import Control.Monad (forever, when) import qualified Data.Aeson as Aeson -import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import Data.Foldable (for_) import qualified Data.HashMap.Strict as HMS -import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.IO as T -import qualified Data.Text.Lazy as TL -import qualified Data.Vector as V import qualified Data.Vector as V import qualified Network.Wai as Wai import qualified Network.Wai.Handler.Warp as Warp import qualified Network.Wai.Handler.WebSockets as WaiWs import qualified Network.WebSockets as WS import qualified System.IO as IO +import System.Random (StdGen, newStdGen) import qualified Web.Scotty as Scotty warning :: String -> IO () @@ -40,8 +36,8 @@ type RoomId = T.Text type Sink = BL.ByteString -> IO () data Room = Room - { roomGame :: TVar Game - , roomSinks :: TVar (HMS.HashMap PlayerId Sink) + { roomGame :: TVar Game + , roomSinks :: TVar (HMS.HashMap PlayerId Sink) } data Server = Server @@ -60,10 +56,10 @@ readCards = Cards newServer :: IO Server newServer = Server <$> readCards <*> MVar.newMVar HMS.empty -newRoom :: Server -> IO Room -newRoom server = Room - <$> (STM.newTVarIO =<< newGame (serverCards server)) - <*> STM.newTVarIO HMS.empty +newRoom :: Server -> StdGen -> STM Room +newRoom server gen = Room + <$> (STM.newTVar $ newGame (serverCards server) gen) + <*> STM.newTVar HMS.empty scottyApp :: IO Wai.Application scottyApp = Scotty.scottyApp $ do @@ -94,7 +90,8 @@ getOrCreateRoom server roomId = MVar.modifyMVar (serverRooms server) $ \rooms -> case HMS.lookup roomId rooms of Just room -> pure (rooms, room) Nothing -> do - room <- newRoom server + gen <- newStdGen + room <- atomically $ newRoom server gen pure (HMS.insert roomId room rooms, room) joinRoom :: Room -> Sink -> STM PlayerId |