aboutsummaryrefslogtreecommitdiff
path: root/server/lib
diff options
context:
space:
mode:
Diffstat (limited to 'server/lib')
-rw-r--r--server/lib/Cafp/Game.hs79
-rw-r--r--server/lib/Cafp/InfiniteDeck.hs36
-rw-r--r--server/lib/Cafp/Main/Server.hs21
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
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-22 20:03:57 +0000