Use new parametric Game type in hanafuda library to expose Games more easily
This commit is contained in:
Sasha
parent
83201d5c95
commit
4cd6842c01
|
|
@ -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)
|
||||
|
|
|
|||
94
src/Game.hs
94
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"}
|
||||
|
|
|
|||
|
|
@ -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
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
Loading…
Reference in New Issue