aboutsummaryrefslogtreecommitdiff
path: root/server/lib
diff options
context:
space:
mode:
Diffstat (limited to 'server/lib')
-rw-r--r--server/lib/Cafp/Game.hs89
-rw-r--r--server/lib/Cafp/InfiniteDeck.hs36
-rw-r--r--server/lib/Cafp/Main/Server.hs32
-rw-r--r--server/lib/Cafp/Messages.hs4
4 files changed, 106 insertions, 55 deletions
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
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-23 14:50:28 +0000