diff --git a/src/Automaton.hs b/src/Automaton.hs index 7f4f8ed..3a38516 100644 --- a/src/Automaton.hs +++ b/src/Automaton.hs @@ -3,6 +3,7 @@ module Automaton ( start ) where +import Data.Foldable (forM_) import Control.Monad.Reader (asks, lift) import qualified Game (export, new) import qualified Session (Status(..), T(..)) @@ -48,7 +49,8 @@ edges (Session.Answering to) message@(Message.Answer {Message.accept}) = do gameKey <- Server.register <$> (lift $ Game.new for to) >>= App.update game <- Server.get gameKey <$> App.server current <- App.current - Message.sendTo [(to, session), (key, current)] $ Message.NewGame $ Game.export game + forM_ [(to, session), (key, current)] $ \(k, s) -> + Message.sendTo [(k, s)] $ Message.NewGame $ Game.export k game return $ Session.Playing gameKey else do Message.broadcast $ Message.update {Message.alone = [key, to]} diff --git a/src/Game.hs b/src/Game.hs index 694e402..228b8c3 100644 --- a/src/Game.hs +++ b/src/Game.hs @@ -1,62 +1,114 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Game ( Key - , State(..) + , View(..) , T(..) , export , new ) where -import Data.Map (Map, (!), fromList, mapKeys) -import Data.Aeson (FromJSON(..), ToJSON(..), genericToEncoding) -import qualified JSON (singleLCField) +import Data.Text (pack) +import Data.Map (Map, (!), fromList, mapKeys, mapWithKey) +import Data.Aeson (FromJSON(..), ToJSON(..), ToJSON1(..), ToJSONKey(..), genericToEncoding, genericLiftToEncoding, toEncoding1, toJSON1) +import Data.Aeson.Types (toJSONKeyText) +import qualified JSON (defaultOptions, singleLCField) import qualified Data (Key) import qualified Player (Key) -import qualified Hanafuda (Card(..), cardsOfPack) -import qualified Hanafuda.Player (Player(..), Seat(..)) -import qualified Hanafuda.KoiKoi (Mode(..), Move(..), On(..), new) +import qualified Hanafuda (Flower(..), Card(..), Pack, cardsOfPack, empty) +import qualified Hanafuda.Player (Player(..), Seat(..), Points) +import qualified Hanafuda.KoiKoi (Mode(..), Move(..), On(..), Score, Step(..), Yaku(..), new) import GHC.Generics deriving instance Generic Hanafuda.Card +deriving instance Generic Hanafuda.Flower +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 instance FromJSON Hanafuda.Card instance ToJSON Hanafuda.Card +instance ToJSON Hanafuda.Flower + +instance ToJSON Hanafuda.Pack where + toJSON = toJSON . Hanafuda.cardsOfPack + toEncoding = toEncoding . Hanafuda.cardsOfPack + +instance ToJSON Hanafuda.KoiKoi.Mode + instance FromJSON Hanafuda.KoiKoi.Move instance ToJSON Hanafuda.KoiKoi.Move where toEncoding = genericToEncoding JSON.singleLCField +instance ToJSON1 Hanafuda.Player.Player where + liftToEncoding = genericLiftToEncoding JSON.defaultOptions + +instance ToJSON (Hanafuda.Player.Player Hanafuda.KoiKoi.Score) where + toJSON = toJSON1 + toEncoding = toEncoding1 + +instance ToJSON Hanafuda.KoiKoi.Yaku where + toEncoding = genericToEncoding JSON.defaultOptions +instance ToJSONKey Hanafuda.KoiKoi.Yaku where + toJSONKey = toJSONKeyText (pack . show) + +instance ToJSON Hanafuda.KoiKoi.Step where + toEncoding = genericToEncoding JSON.defaultOptions + data T = T { - seats :: Map Hanafuda.Player.Seat Player.Key + keys :: Map Hanafuda.Player.Seat Player.Key + , seats :: Map Player.Key Hanafuda.Player.Seat , state :: Hanafuda.KoiKoi.On } -type Key = Data.Key T -data State = State { - river :: [Hanafuda.Card] - , yakus :: Map Player.Key [Hanafuda.Card] +type Key = Data.Key T +type Players a = Map Player.Key a + +data View = View { + mode :: Hanafuda.KoiKoi.Mode + , scores :: Players Hanafuda.Player.Points + , month :: Hanafuda.Flower + , players :: Players (Hanafuda.Player.Player Hanafuda.KoiKoi.Score) + , playing :: Player.Key + , winning :: Player.Key + , oyake :: Player.Key + , river :: [Hanafuda.Card] + , step :: Hanafuda.KoiKoi.Step + , trick :: [Hanafuda.Card] } deriving (Generic) -instance ToJSON State where +instance ToJSON View where toEncoding = genericToEncoding JSON.singleLCField new :: Player.Key -> Player.Key -> IO T new p1 p2 = do state <- Hanafuda.KoiKoi.new Hanafuda.KoiKoi.WholeYear return $ T { - seats = fromList [(Hanafuda.Player.Player1, p1), (Hanafuda.Player.Player2, p2)] + keys = fromList [(Hanafuda.Player.Player1, p1), (Hanafuda.Player.Player2, p2)] + , seats = fromList [(p1, Hanafuda.Player.Player1), (p2, Hanafuda.Player.Player2)] , state } -export :: T -> State -export (T {seats, state}) = State { - river = Hanafuda.cardsOfPack $ Hanafuda.KoiKoi.river state - , yakus = fmap extractYakus players +export :: Player.Key -> T -> View +export key (T {keys, state}) = View { + mode = Hanafuda.KoiKoi.mode state + , scores = reindex $ Hanafuda.KoiKoi.scores state + , month = Hanafuda.KoiKoi.month state + , players = mapWithKey (\k -> if k == key then id else maskHand) players + , playing = keys ! Hanafuda.KoiKoi.playing state + , winning = keys ! Hanafuda.KoiKoi.winning state + , oyake = keys ! Hanafuda.KoiKoi.oyake state + , river = Hanafuda.cardsOfPack $ Hanafuda.KoiKoi.river state + , step = Hanafuda.KoiKoi.step state + , trick = Hanafuda.KoiKoi.trick state } where - extractYakus = Hanafuda.cardsOfPack . Hanafuda.Player.meld - players = mapKeys (seats !) $ Hanafuda.KoiKoi.players state + reindex = mapKeys (keys !) + players = reindex $ Hanafuda.KoiKoi.players state + maskHand player = player {Hanafuda.Player.hand = Hanafuda.empty} diff --git a/src/Message.hs b/src/Message.hs index c84c6fd..b99f69e 100644 --- a/src/Message.hs +++ b/src/Message.hs @@ -21,7 +21,7 @@ import Data.ByteString.Lazy.Char8 (unpack) import Data.Text (Text) import Control.Monad.Reader (asks, lift) import qualified Player (Key) -import qualified Game (State) +import qualified Game (View) import qualified Session (T(..)) import qualified Server (T(..)) import qualified App (Context(..), T, connection, current, debug, server) @@ -46,7 +46,7 @@ data T = Relay {from :: Player.Key, message :: FromClient} | Welcome {room :: Server.T, key :: Player.Key} | Update {alone :: [Player.Key], paired :: [Player.Key]} - | NewGame Game.State + | NewGame Game.View | Pong | Error {error :: String} deriving (Generic)