diff --git a/src/Automaton.hs b/src/Automaton.hs index 8089975..4283bf4 100644 --- a/src/Automaton.hs +++ b/src/Automaton.hs @@ -50,7 +50,7 @@ receive (Session.Answering to) message@(Message.Answer {Message.accept}) = do then do gameKey <- Server.register <$> (lift $ Game.new for to) >>= App.update game <- Server.get gameKey <$> App.server - Message.notifyPlayers (KoiKoi.On game) [] + Message.notifyPlayers game [] return $ Session.Playing gameKey else do Message.broadcast $ Message.update {Message.alone = [key, to]} @@ -66,17 +66,17 @@ receive (Session.Playing gameKey) played@(Message.Play {}) = do case result of Left message -> sendError message Right newGame -> - case newGame of - KoiKoi.Over _ -> do + if KoiKoi.on newGame + then do + App.update_ $ Server.update gameKey (const newGame) + Message.notifyPlayers newGame logs + else do let newStatus = Session.LoggedIn True - let opponent = Player.next (KoiKoi.players game) key + let opponent = Player.next (KoiKoi.players newGame) key App.update_ $ Server.endGame gameKey App.update_ $ Server.update opponent (Data.set newStatus :: Session.Update) Message.notifyPlayers newGame logs move newStatus - KoiKoi.On on -> do - App.update_ $ Server.update gameKey (const on) - Message.notifyPlayers newGame logs receive state _ = sendError $ "Invalid message in state " ++ show state diff --git a/src/Game.hs b/src/Game.hs index db8f21d..e8ad82d 100644 --- a/src/Game.hs +++ b/src/Game.hs @@ -8,7 +8,6 @@ {-# LANGUAGE OverloadedStrings #-} module Game ( Key - , View , T , export , new @@ -26,7 +25,7 @@ import qualified Data (Key) import qualified Player (Key) import qualified Hanafuda (Flower(..), Card(..), Pack, cardsOfPack, empty) import qualified Hanafuda.Player (Player(..), Players(..)) -import qualified Hanafuda.KoiKoi (Action(..), Game(..), Environment, Mode(..), Move(..), On(..), Over(..), Score, Source(..), Step(..), Yaku(..), new, play) +import qualified Hanafuda.KoiKoi (Action(..), Game(..), Environment, Mode(..), Move(..), Score, Source(..), Step(..), Yaku(..), new, play) import GHC.Generics deriving instance Generic Hanafuda.Card @@ -40,17 +39,11 @@ deriving instance Generic Hanafuda.KoiKoi.Step deriving instance Generic1 (Hanafuda.Player.Player Player.Key) deriving instance Generic1 (Hanafuda.Player.Players Player.Key) -type On = Hanafuda.KoiKoi.On Player.Key -type Over = Hanafuda.KoiKoi.Over Player.Key -type View = Hanafuda.KoiKoi.Game Player.Key +type T = Hanafuda.KoiKoi.Game Player.Key -deriving instance Generic On -deriving instance Generic Over -deriving instance Generic View +deriving instance Generic T -instance ToJSON On where - toEncoding = genericToEncoding JSON.defaultOptions -instance ToJSON Over where +instance ToJSON T where toEncoding = genericToEncoding JSON.defaultOptions instance FromJSON Hanafuda.Card @@ -95,28 +88,25 @@ instance ToJSON (Hanafuda.Player.Players Player.Key Hanafuda.KoiKoi.Score) where toJSON = toJSON1 toEncoding = toEncoding1 -type T = On - type Key = Data.Key T new :: Player.Key -> Player.Key -> IO T new p1 p2 = do - Hanafuda.KoiKoi.new [p1, p2] Hanafuda.KoiKoi.WholeYear + Hanafuda.KoiKoi.new [p1, p2] $ Hanafuda.KoiKoi.FirstAt 1 -export :: Player.Key -> View -> Value -export _ (Hanafuda.KoiKoi.Over over) = toJSON over -export key (Hanafuda.KoiKoi.On on) = Object $ insert "deck" (toJSON $ length $ Hanafuda.KoiKoi.deck on) $ ast +export :: Player.Key -> T -> Value +export key game = Object $ insert "deck" (toJSON $ length $ Hanafuda.KoiKoi.deck game) $ ast where - Hanafuda.Player.Players unfiltered = Hanafuda.KoiKoi.players on + Hanafuda.Player.Players unfiltered = Hanafuda.KoiKoi.players game maskOpponentsHand k player | k == key = player | otherwise = player {Hanafuda.Player.hand = Hanafuda.empty} - Object ast = toJSON $ on { + Object ast = toJSON $ game { Hanafuda.KoiKoi.players = Hanafuda.Player.Players $ mapWithKey maskOpponentsHand unfiltered } play :: Hanafuda.KoiKoi.Environment m => Player.Key -> Hanafuda.KoiKoi.Move -> T -> m (Hanafuda.KoiKoi.Game Player.Key) -play key move on - | Hanafuda.KoiKoi.playing on == key = - Hanafuda.KoiKoi.play move on +play key move game + | Hanafuda.KoiKoi.playing game == key = + Hanafuda.KoiKoi.play move game | otherwise = throwError "Not your turn" diff --git a/src/Message.hs b/src/Message.hs index 3938b73..2c23e7a 100644 --- a/src/Message.hs +++ b/src/Message.hs @@ -23,11 +23,11 @@ import Data.ByteString.Lazy.Char8 (unpack) import Data.Text (Text) import Control.Monad.Reader (asks, lift) import qualified Player (Key) -import qualified Game (View, export) +import qualified Game (T, export) import qualified Session (T(..)) import qualified Server (T(..), get) import qualified App (Context(..), T, connection, debug, server) -import qualified Hanafuda.KoiKoi as KoiKoi (Action, Game(..), On(..), Over(..), Move(..)) +import qualified Hanafuda.KoiKoi as KoiKoi (Action, Game(..), Move(..)) import GHC.Generics (Generic) data FromClient = @@ -98,10 +98,7 @@ get = update :: T update = Update {alone = [], paired = []} -notifyPlayers :: Game.View -> [KoiKoi.Action] -> App.T () -notifyPlayers game@(KoiKoi.Over over) logs = - forM_ (keys $ KoiKoi.finalScores over) $ \k -> - sendTo [k] $ Game {game = Game.export k game, logs} -notifyPlayers game@(KoiKoi.On on) logs = - forM_ (keys $ KoiKoi.scores on) $ \k -> +notifyPlayers :: Game.T -> [KoiKoi.Action] -> App.T () +notifyPlayers game logs = + forM_ (keys $ KoiKoi.scores game) $ \k -> sendTo [k] $ Game {game = Game.export k game, logs}