Use new parametric Game type in hanafuda library to expose Games more easily

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
+            Message.notifyPlayers game
-            forM_ [(to, session), (key, current)] $ \(k, s) ->
-              Message.sendTo [(k, s)] $ Message.NewGame {Message.game = Game.export k 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)

src/Game.hs

@@ -3,24 +3,28 @@
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 module Game (
-      Key
+      Hanafuda.KoiKoi.Game(..)
-    , View(..)
+    , 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 JSON (defaultOptions, distinct, singleLCField)
-import qualified Data (Key)
+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.Player (Player(..), Seat(..))
-import qualified Hanafuda.KoiKoi (Mode(..), Move(..), On(..), Score, Step(..), Yaku(..), new)
+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.Game Hanafuda.Player.Seat
-    , state :: Hanafuda.KoiKoi.On
   }
 
 type Key = Data.Key T
-type Players a = Map Player.Key a
 
-data View = View {
+instance Data.RW (Hanafuda.KoiKoi.Game Hanafuda.Player.Seat) T where
-      mode :: Hanafuda.KoiKoi.Mode
+  get = state
-    , scores :: Players Hanafuda.Player.Points
+  set state game = game {state}
-    , 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
 
 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 = Hanafuda.KoiKoi.On on
-    , state
   }
 
 export :: Player.Key -> T -> View
-export key (T {keys, state}) = View {
+export key (T {keys, state}) =
-      mode = Hanafuda.KoiKoi.mode state
+  case Hanafuda.KoiKoi.Game.remap (keys !) state of
-    , scores = reindex $ Hanafuda.KoiKoi.scores state
+    view@(Hanafuda.KoiKoi.Error _) -> view
-    , month = Hanafuda.KoiKoi.month state
+    view@(Hanafuda.KoiKoi.Over _) -> view
-    , players = mapWithKey (\k -> if k == key then id else maskHand) players
+    (Hanafuda.KoiKoi.On on) -> Hanafuda.KoiKoi.On $ on {
-    , playing = keys ! Hanafuda.KoiKoi.playing state
+        Hanafuda.KoiKoi.stock = []
-    , winning = keys ! Hanafuda.KoiKoi.winning state
+      , Hanafuda.KoiKoi.players = mapWithKey maskOpponentsHand $ Hanafuda.KoiKoi.players on
-    , oyake = keys ! Hanafuda.KoiKoi.oyake state
-    , river = Hanafuda.cardsOfPack $ Hanafuda.KoiKoi.river state
-    , step = Hanafuda.KoiKoi.step state
-    , trick = Hanafuda.KoiKoi.trick state
     }
   where
-    reindex = mapKeys (keys !)
+    maskOpponentsHand k player
-    players = reindex $ Hanafuda.KoiKoi.players state
+      | k == key = player
-    maskHand player = player {Hanafuda.Player.hand = Hanafuda.empty}
+      | otherwise = player {Hanafuda.Player.hand = Hanafuda.empty}
 
-play :: Player.Key -> Hanafuda.KoiKoi.Move -> T -> T
+play :: Player.Key -> Hanafuda.KoiKoi.Move -> T -> IO T
-play = undefined
+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"}

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
+  }

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 Server (T(..), get)
-import qualified App (Context(..), T, connection, current, debug, server)
+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 :: [Player.Key] -> T -> App.T ()
-sendTo sessions obj = do
+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 [
+    getSessions server = (\key -> Server.get key server) <$> playerKeys
-        (show key, Session.connection session) | (key, session) <- sessions
+    recipients = show <$> playerKeys
-      ]
 
 send :: T -> App.T ()
 send obj = do
   key <- asks App.key
-  session <- App.current
+  sendTo [key] obj
-  sendTo [(key, session)] 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

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)