Shuffling

7 files changed, 119 insertions, 56 deletions

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