Refactor to use State

4 files changed, 59 insertions, 79 deletions

diff --git a/server/cafp.cabal b/server/cafp.cabal
index 3d605fd..e4d4194 100644
--- a/server/cafp.cabal
+++ b/server/cafp.cabal
@@ -17,7 +17,6 @@ Library
 
   Exposed-modules:
     Cafp.Game
-    Cafp.InfiniteDeck
     Cafp.Messages
     Cafp.Main.GenerateElmTypes
     Cafp.Main.Server
@@ -28,6 +27,7 @@ Library
     bytestring           >= 0.10 && < 0.11,
     elm-bridge           >= 0.5  && < 0.6,
     lens                 >= 4.18 && < 4.19,
+    mtl                  >= 2.2  && < 2.3,
     random               >= 1.1  && < 1.2,
     scotty               >= 0.11 && < 0.12,
     stm                  >= 2.5  && < 2.6,
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