From 4cd6842c010575bb3f8a7df3b0e7d747afa15d50 Mon Sep 17 00:00:00 2001 From: Sasha Date: Tue, 15 May 2018 18:21:07 +0200 Subject: [PATCH] Use new parametric Game type in hanafuda library to expose Games more easily --- src/Automaton.hs | 28 +++++++++------ src/Game.hs | 94 +++++++++++++++++++++++++----------------------- src/JSON.hs | 6 ++++ src/Message.hs | 36 +++++++++++-------- src/Server.hs | 7 ---- 5 files changed, 94 insertions(+), 77 deletions(-) diff --git a/src/Automaton.hs b/src/Automaton.hs index 88df18b..697ae41 100644 --- a/src/Automaton.hs +++ b/src/Automaton.hs @@ -3,14 +3,13 @@ module Automaton ( start ) where -import Data.Foldable (forM_) import Control.Monad.Reader (asks, lift) import qualified Data (RW(..)) -import qualified Game (export, new) +import qualified Game (Game(..), T(..), new, play) 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_) -import qualified Message (FromClient(..), T(..), broadcast, get, relay, send, sendTo, update) +import qualified Message (FromClient(..), T(..), broadcast, get, notifyPlayers, relay, send, sendTo, update) type Vertex = Session.Status @@ -34,7 +33,7 @@ edges (Session.LoggedIn True) invitation@(Message.Invitation {Message.to}) = do key <- asks App.key App.update_ (Server.update to (Data.set $ Session.Answering key :: Session.Update)) Message.broadcast $ Message.update {Message.paired = [key, to]} - (Message.relay invitation $ Message.sendTo [(to, session)]) + (Message.relay invitation $ Message.sendTo [to]) return (Session.Waiting to) _ -> Session.LoggedIn True `withError` "They just left" @@ -43,25 +42,32 @@ edges (Session.Answering to) message@(Message.Answer {Message.accept}) = do key <- asks App.key case Session.status session of Session.Waiting for | for == key -> do - Message.relay message $ Message.sendTo [(to, session)] + Message.relay message $ Message.sendTo [to] newStatus <- if accept then do gameKey <- Server.register <$> (lift $ Game.new for to) >>= App.update game <- Server.get gameKey <$> App.server - current <- App.current - forM_ [(to, session), (key, current)] $ \(k, s) -> - Message.sendTo [(k, s)] $ Message.NewGame {Message.game = Game.export k game} + Message.notifyPlayers game return $ Session.Playing gameKey else do Message.broadcast $ Message.update {Message.alone = [key, to]} return $ Session.LoggedIn True - App.update_ $ Server.update for (Data.set newStatus :: Session.Update) + App.update_ $ Server.update to (Data.set newStatus :: Session.Update) return newStatus _ -> (Session.LoggedIn True) `withError` "They're not waiting for your answer" ---edges (Session.Playing game) message@(Message.Play {Message.move}) = do - +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 + App.update_ $ Server.update gameKey (const newGame) + Message.notifyPlayers newGame + return status edges state _ = state `withError` ("Invalid message in state " ++ show state) diff --git a/src/Game.hs b/src/Game.hs index 53b84f9..6b7f1c7 100644 --- a/src/Game.hs +++ b/src/Game.hs @@ -3,24 +3,28 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} module Game ( - Key - , View(..) + Hanafuda.KoiKoi.Game(..) + , Key + , View , T(..) , export , new + , play ) where import Data.Text (pack) -import Data.Map (Map, (!), fromList, mapKeys, mapWithKey) +import Data.Map (Map, (!), fromList, mapWithKey) import Data.Aeson (FromJSON(..), ToJSON(..), ToJSON1(..), ToJSONKey(..), genericParseJSON, genericToEncoding, genericLiftToEncoding, toEncoding1, toJSON1) import Data.Aeson.Types (toJSONKeyText) -import qualified JSON (defaultOptions, singleLCField) -import qualified Data (Key) +import qualified JSON (defaultOptions, distinct, singleLCField) +import qualified Data (Key, RW(..)) import qualified Player (Key) 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 qualified Hanafuda.Player (Player(..), Seat(..)) +import qualified Hanafuda.KoiKoi.Game (remap) +import qualified Hanafuda.KoiKoi (Game(..), Mode(..), Move(..), On(..), Over(..), Score, Step(..), Yaku(..), new, play) import GHC.Generics deriving instance Generic Hanafuda.Card @@ -31,6 +35,14 @@ deriving instance Generic Hanafuda.KoiKoi.Yaku deriving instance Generic Hanafuda.KoiKoi.Step deriving instance Generic1 Hanafuda.Player.Player +type On = Hanafuda.KoiKoi.On Player.Key +type Over = Hanafuda.KoiKoi.Over Player.Key +type View = Hanafuda.KoiKoi.Game Player.Key + +deriving instance Generic On +deriving instance Generic Over +deriving instance Generic View + instance FromJSON Hanafuda.Card instance ToJSON Hanafuda.Card @@ -62,57 +74,49 @@ instance ToJSONKey Hanafuda.KoiKoi.Yaku where instance ToJSON Hanafuda.KoiKoi.Step where toEncoding = genericToEncoding JSON.defaultOptions +instance ToJSON On +instance ToJSON Over + +instance ToJSON View where + toEncoding = genericToEncoding JSON.distinct + data T = T { keys :: Map Hanafuda.Player.Seat Player.Key - , seats :: Map Player.Key Hanafuda.Player.Seat - , state :: Hanafuda.KoiKoi.On + , state :: Hanafuda.KoiKoi.Game Hanafuda.Player.Seat } 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 View where - toEncoding = genericToEncoding JSON.singleLCField +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 - state <- Hanafuda.KoiKoi.new Hanafuda.KoiKoi.WholeYear + on <- Hanafuda.KoiKoi.new Hanafuda.KoiKoi.WholeYear return $ T { keys = fromList [(Hanafuda.Player.Player1, p1), (Hanafuda.Player.Player2, p2)] - , seats = fromList [(p1, Hanafuda.Player.Player1), (p2, Hanafuda.Player.Player2)] - , state + , state = Hanafuda.KoiKoi.On on } 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 - } +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 + } where - reindex = mapKeys (keys !) - players = reindex $ Hanafuda.KoiKoi.players state - maskHand player = player {Hanafuda.Player.hand = Hanafuda.empty} + maskOpponentsHand k player + | k == key = player + | otherwise = player {Hanafuda.Player.hand = Hanafuda.empty} -play :: Player.Key -> Hanafuda.KoiKoi.Move -> T -> T -play = undefined +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 + 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"} diff --git a/src/JSON.hs b/src/JSON.hs index d4668ac..10100c6 100644 --- a/src/JSON.hs +++ b/src/JSON.hs @@ -1,5 +1,6 @@ module JSON ( defaultOptions + , distinct , singleLCField ) where @@ -19,3 +20,8 @@ singleLCField = defaultOptions { constructorTagModifier = (toLower `first`) , sumEncoding = ObjectWithSingleField } + +distinct :: Options +distinct = defaultOptions { + sumEncoding = UntaggedValue + } diff --git a/src/Message.hs b/src/Message.hs index 714e26e..6fb27e6 100644 --- a/src/Message.hs +++ b/src/Message.hs @@ -1,10 +1,12 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} module Message ( FromClient(..) , T(..) , broadcast , get + , notifyPlayers , receive , relay , send @@ -14,17 +16,17 @@ module Message ( import Data.List (intercalate) import Data.Foldable (forM_) -import Data.Map (toList) +import Data.Map (elems, 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 (View) +import qualified Game (T(..), View, export) import qualified Session (T(..)) -import qualified Server (T(..)) -import qualified App (Context(..), T, connection, current, debug, server) +import qualified Server (T(..), get) +import qualified App (Context(..), T, connection, debug, server) import qualified Hanafuda.KoiKoi as KoiKoi (Move(..)) import GHC.Generics (Generic) @@ -46,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]} - | NewGame {game :: Game.View} + | Game {game :: Game.View} | Pong | Error {error :: String} deriving (Generic) @@ -54,25 +56,24 @@ data T = instance ToJSON T where toEncoding = genericToEncoding defaultOptions -sendTo :: [(Player.Key, Session.T)] -> T -> App.T () -sendTo sessions obj = do +sendTo :: [Player.Key] -> T -> App.T () +sendTo playerKeys obj = do + sessions <- getSessions <$> App.server App.debug $ '(' : intercalate ", " recipients ++ ") <" ++ (unpack encoded) - lift $ forM_ connections $ flip sendTextData encoded + lift $ forM_ (Session.connection <$> sessions) $ flip sendTextData encoded where encoded = encode $ obj - (recipients, connections) = unzip [ - (show key, Session.connection session) | (key, session) <- sessions - ] + getSessions server = (\key -> Server.get key server) <$> playerKeys + recipients = show <$> playerKeys send :: T -> App.T () send obj = do key <- asks App.key - session <- App.current - sendTo [(key, session)] obj + sendTo [key] obj broadcast :: T -> App.T () broadcast obj = - App.server >>= flip sendTo obj . toList . Server.sessions + App.server >>= flip sendTo obj . keys . Server.sessions relay :: FromClient -> (T -> App.T ()) -> App.T () relay message f = do @@ -96,3 +97,10 @@ get = update :: T update = Update {alone = [], paired = []} + +notifyPlayers :: Game.T -> App.T () +notifyPlayers game = + forM_ playerKeys $ \k -> + sendTo [k] $ Game {game = Game.export k game} + where + playerKeys = elems $ Game.keys game diff --git a/src/Server.hs b/src/Server.hs index d389789..8aa56db 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -88,9 +88,6 @@ register x server = get :: forall a b. (Ord a, Data.RW (Map a b) T) => a -> T -> b get key server = (Data.get server :: Map a b) ! key -set :: forall a b c. (Ord a, Data.RW (Map a b) T, Data.RW c b) => a -> c -> T -> T -set key value = update key (Data.set value :: b -> b) - update :: forall a b. (Ord a, Data.RW (Map a b) T) => a -> (b -> b) -> T -> T update key updator = Data.update (adjust updator key :: Map a b -> Map a b) @@ -117,7 +114,3 @@ logOut key server = update key (Data.set $ Session.LoggedIn False :: Session.Update) $ Data.update (Set.delete $ Player.name player :: Names -> Names) server) (players server !? key) - -setStatus :: Session.Status -> Player.Key -> T -> T -setStatus status key = - Data.update (adjust (Data.set status) key :: Sessions -> Sessions)