diff --git a/src/Automaton.hs b/src/Automaton.hs index 697ae41..8aa513a 100644 --- a/src/Automaton.hs +++ b/src/Automaton.hs @@ -5,7 +5,8 @@ module Automaton ( import Control.Monad.Reader (asks, lift) import qualified Data (RW(..)) -import qualified Game (Game(..), T(..), new, play) +import qualified Game (new, play) +import qualified Hanafuda.KoiKoi as KoiKoi (Game(..)) import qualified Session (Status(..), T(..), Update) import qualified Server (get, logIn, logOut, update, register) import qualified App (Context(..), T, current, debug, get, server, try, update, update_) @@ -61,10 +62,10 @@ edges status@(Session.Playing gameKey) (Message.Play {Message.move}) = do key <- asks App.key game <- Server.get gameKey <$> App.server newGame <- lift $ Game.play key move game - case Game.state newGame of - Game.Error s -> status `withError` s - Game.Over _ -> undefined - Game.On _ -> do + case newGame of + KoiKoi.Error s -> status `withError` s + KoiKoi.Over _ -> undefined + KoiKoi.On _ -> do App.update_ $ Server.update gameKey (const newGame) Message.notifyPlayers newGame return status diff --git a/src/Game.hs b/src/Game.hs index 6b7f1c7..e4a734b 100644 --- a/src/Game.hs +++ b/src/Game.hs @@ -5,25 +5,23 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} module Game ( - Hanafuda.KoiKoi.Game(..) - , Key + Key , View - , T(..) + , T , export , new , play ) where import Data.Text (pack) -import Data.Map (Map, (!), fromList, mapWithKey) +import Data.Map (mapWithKey) import Data.Aeson (FromJSON(..), ToJSON(..), ToJSON1(..), ToJSONKey(..), genericParseJSON, genericToEncoding, genericLiftToEncoding, toEncoding1, toJSON1) import Data.Aeson.Types (toJSONKeyText) -import qualified JSON (defaultOptions, distinct, singleLCField) -import qualified Data (Key, RW(..)) +import qualified JSON (defaultOptions, singleLCField) +import qualified Data (Key) import qualified Player (Key) import qualified Hanafuda (Flower(..), Card(..), Pack, cardsOfPack, empty) -import qualified Hanafuda.Player (Player(..), Seat(..)) -import qualified Hanafuda.KoiKoi.Game (remap) +import qualified Hanafuda.Player (Player(..), Players(..)) import qualified Hanafuda.KoiKoi (Game(..), Mode(..), Move(..), On(..), Over(..), Score, Step(..), Yaku(..), new, play) import GHC.Generics @@ -33,7 +31,8 @@ deriving instance Generic Hanafuda.KoiKoi.Mode deriving instance Generic Hanafuda.KoiKoi.Move deriving instance Generic Hanafuda.KoiKoi.Yaku deriving instance Generic Hanafuda.KoiKoi.Step -deriving instance Generic1 Hanafuda.Player.Player +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 @@ -59,10 +58,10 @@ instance FromJSON Hanafuda.KoiKoi.Move where instance ToJSON Hanafuda.KoiKoi.Move where toEncoding = genericToEncoding JSON.singleLCField -instance ToJSON1 Hanafuda.Player.Player where +instance ToJSON1 (Hanafuda.Player.Player Player.Key) where liftToEncoding = genericLiftToEncoding JSON.defaultOptions -instance ToJSON (Hanafuda.Player.Player Hanafuda.KoiKoi.Score) where +instance ToJSON (Hanafuda.Player.Player Player.Key Hanafuda.KoiKoi.Score) where toJSON = toJSON1 toEncoding = toEncoding1 @@ -74,49 +73,43 @@ instance ToJSONKey Hanafuda.KoiKoi.Yaku where instance ToJSON Hanafuda.KoiKoi.Step where toEncoding = genericToEncoding JSON.defaultOptions +instance ToJSON1 (Hanafuda.Player.Players Player.Key) where + liftToEncoding = genericLiftToEncoding JSON.defaultOptions + +instance ToJSON (Hanafuda.Player.Players Player.Key Hanafuda.KoiKoi.Score) where + toJSON = toJSON1 + toEncoding = toEncoding1 + instance ToJSON On instance ToJSON Over -instance ToJSON View where - toEncoding = genericToEncoding JSON.distinct +type T = Hanafuda.KoiKoi.Game Player.Key -data T = T { - keys :: Map Hanafuda.Player.Seat Player.Key - , state :: Hanafuda.KoiKoi.Game Hanafuda.Player.Seat - } +instance ToJSON T type Key = Data.Key T -instance Data.RW (Hanafuda.KoiKoi.Game Hanafuda.Player.Seat) T where - get = state - set state game = game {state} - new :: Player.Key -> Player.Key -> IO T new p1 p2 = do - on <- Hanafuda.KoiKoi.new Hanafuda.KoiKoi.WholeYear - return $ T { - keys = fromList [(Hanafuda.Player.Player1, p1), (Hanafuda.Player.Player2, p2)] - , state = Hanafuda.KoiKoi.On on - } + on <- Hanafuda.KoiKoi.new [p1, p2] Hanafuda.KoiKoi.WholeYear + return $ Hanafuda.KoiKoi.On on -export :: Player.Key -> T -> View -export key (T {keys, state}) = - case Hanafuda.KoiKoi.Game.remap (keys !) state of - view@(Hanafuda.KoiKoi.Error _) -> view - view@(Hanafuda.KoiKoi.Over _) -> view - (Hanafuda.KoiKoi.On on) -> Hanafuda.KoiKoi.On $ on { - Hanafuda.KoiKoi.stock = [] - , Hanafuda.KoiKoi.players = mapWithKey maskOpponentsHand $ Hanafuda.KoiKoi.players on - } +export :: Player.Key -> T -> T +export key (Hanafuda.KoiKoi.On on) = Hanafuda.KoiKoi.On $ on { + Hanafuda.KoiKoi.deck = [] + , Hanafuda.KoiKoi.players = Hanafuda.Player.Players $ mapWithKey maskOpponentsHand unfiltered + } where + Hanafuda.Player.Players unfiltered = Hanafuda.KoiKoi.players on maskOpponentsHand k player | k == key = player | otherwise = player {Hanafuda.Player.hand = Hanafuda.empty} +export _ game = game play :: Player.Key -> Hanafuda.KoiKoi.Move -> T -> IO T -play key move game@(T {keys, state = Hanafuda.KoiKoi.On on}) - | keys ! Hanafuda.KoiKoi.playing on == key = do +play key move (Hanafuda.KoiKoi.On on) + | Hanafuda.KoiKoi.playing on == key = do newState <- Hanafuda.KoiKoi.play move on - return $ game {state = newState} - | otherwise = return $ game {state = Hanafuda.KoiKoi.Error "Not your turn"} -play _ _ game = return $ game {state = Hanafuda.KoiKoi.Error "This game is over"} + return $ newState + | otherwise = return $ Hanafuda.KoiKoi.Error "Not your turn" +play _ _ _ = return $ Hanafuda.KoiKoi.Error "This game is over" diff --git a/src/Message.hs b/src/Message.hs index 6fb27e6..dd9b3cf 100644 --- a/src/Message.hs +++ b/src/Message.hs @@ -16,18 +16,18 @@ module Message ( import Data.List (intercalate) import Data.Foldable (forM_) -import Data.Map (elems, keys) +import Data.Map (keys) import Data.Aeson (FromJSON(..), ToJSON(..), eitherDecode', encode, genericParseJSON, genericToEncoding, defaultOptions) import Network.WebSockets (receiveData, sendTextData) import Data.ByteString.Lazy.Char8 (unpack) import Data.Text (Text) import Control.Monad.Reader (asks, lift) import qualified Player (Key) -import qualified Game (T(..), 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 (Move(..)) +import qualified Hanafuda.KoiKoi as KoiKoi (Game(..), On(..), Over(..), Move(..)) import GHC.Generics (Generic) data FromClient = @@ -48,7 +48,7 @@ data T = Relay {from :: Player.Key, message :: FromClient} | Welcome {room :: Server.T, key :: Player.Key} | Update {alone :: [Player.Key], paired :: [Player.Key]} - | Game {game :: Game.View} + | Game {game :: Game.T} | Pong | Error {error :: String} deriving (Generic) @@ -100,7 +100,9 @@ update = Update {alone = [], paired = []} notifyPlayers :: Game.T -> App.T () notifyPlayers game = - forM_ playerKeys $ \k -> + forM_ (keys $ scores game) $ \k -> sendTo [k] $ Game {game = Game.export k game} where - playerKeys = elems $ Game.keys game + scores (KoiKoi.On on) = KoiKoi.scores on + scores (KoiKoi.Over over) = KoiKoi.finalScores over + scores _ = mempty diff --git a/src/Server.hs b/src/Server.hs index 8aa56db..ed55943 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -24,7 +24,7 @@ import Data.Set (Set, member) import qualified Data.Set as Set (delete, empty, insert) import Data.Text (Text) import qualified Data (RW(..)) -import qualified Game (Key, T(..)) +import qualified Game (Key, T) import qualified Player (Key, T(..)) import qualified Session (Status(..), T(..), Update)