server/src/Game.hs

{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Game (
      Key
    , State(..)
    , T(..)
    , export
    , new
  ) where

import Data.Map (Map, (!), fromList, mapKeys)
import Data.Aeson (FromJSON(..), ToJSON(..), genericToEncoding)
import qualified JSON (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 GHC.Generics

deriving instance Generic Hanafuda.Card
deriving instance Generic Hanafuda.KoiKoi.Move

instance FromJSON Hanafuda.Card
instance ToJSON Hanafuda.Card

instance FromJSON Hanafuda.KoiKoi.Move
instance ToJSON Hanafuda.KoiKoi.Move where
  toEncoding = genericToEncoding JSON.singleLCField

data T = T {
      seats :: Map Hanafuda.Player.Seat Player.Key
    , state :: Hanafuda.KoiKoi.On
  }
type Key = Data.Key T

data State = State {
      river :: [Hanafuda.Card]
    , yakus :: Map Player.Key [Hanafuda.Card]
  } deriving (Generic)

instance ToJSON State 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)]
    , state
  }

export :: T -> State
export (T {seats, state}) = State {
      river = Hanafuda.cardsOfPack $ Hanafuda.KoiKoi.river state
    , yakus = fmap extractYakus players
  }
  where
    extractYakus = Hanafuda.cardsOfPack . Hanafuda.Player.meld
    players = mapKeys (seats !) $ Hanafuda.KoiKoi.players state