server/src/Game.hs

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

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 (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 {
      keys :: Map Hanafuda.Player.Seat Player.Key
    , seats :: Map Player.Key Hanafuda.Player.Seat
    , state :: Hanafuda.KoiKoi.On
  }

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

new :: Player.Key -> Player.Key -> IO T
new p1 p2 = do
  state <- 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
  }

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
    reindex = mapKeys (keys !)
    players = reindex $ Hanafuda.KoiKoi.players state
    maskHand player = player {Hanafuda.Player.hand = Hanafuda.empty}