server/src/Game.hs

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

import Control.Monad.Except (throwError)
import Data.Text (pack)
import Data.Map (mapWithKey)
import Data.HashMap.Strict (insert)
import Data.Aeson (FromJSON(..), ToJSON(..), ToJSON1(..), ToJSONKey(..), Value(..), genericParseJSON, 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(..), Players(..))
import qualified Hanafuda.KoiKoi (Action(..), Game(..), Environment, Mode(..), Move(..), On(..), Over(..), Score, Source(..), Step(..), Yaku(..), new, play)
import GHC.Generics

deriving instance Generic Hanafuda.Card
deriving instance Generic Hanafuda.Flower
deriving instance Generic Hanafuda.KoiKoi.Action
deriving instance Generic Hanafuda.KoiKoi.Mode
deriving instance Generic Hanafuda.KoiKoi.Move
deriving instance Generic Hanafuda.KoiKoi.Yaku
deriving instance Generic Hanafuda.KoiKoi.Source
deriving instance Generic Hanafuda.KoiKoi.Step
deriving instance Generic1 (Hanafuda.Player.Player Player.Key)
deriving instance Generic1 (Hanafuda.Player.Players Player.Key)

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

instance ToJSON Hanafuda.Flower

instance ToJSON Hanafuda.Pack where
  toJSON = toJSON . Hanafuda.cardsOfPack
  toEncoding = toEncoding . Hanafuda.cardsOfPack

instance ToJSON Hanafuda.KoiKoi.Action

instance ToJSON Hanafuda.KoiKoi.Mode

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

instance ToJSON Hanafuda.KoiKoi.Source

instance ToJSON Hanafuda.KoiKoi.Step where
  toEncoding = genericToEncoding JSON.defaultOptions

instance ToJSON1 (Hanafuda.Player.Player Player.Key) where
  liftToEncoding = genericLiftToEncoding JSON.defaultOptions

instance ToJSON (Hanafuda.Player.Player Player.Key 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 ToJSON1 (Hanafuda.Player.Players Player.Key) where
  liftToEncoding = genericLiftToEncoding JSON.defaultOptions

instance ToJSON (Hanafuda.Player.Players Player.Key Hanafuda.KoiKoi.Score) where
  toJSON = toJSON1
  toEncoding = toEncoding1

type T = Hanafuda.KoiKoi.On Player.Key

instance ToJSON T

type Key = Data.Key T

new :: Player.Key -> Player.Key -> IO T
new p1 p2 = do
  Hanafuda.KoiKoi.new [p1, p2] Hanafuda.KoiKoi.WholeYear

export :: Player.Key -> T -> Value
export key on = Object $ insert "deck" (toJSON $ length $ Hanafuda.KoiKoi.deck on) $ ast
  where
    Hanafuda.Player.Players unfiltered = Hanafuda.KoiKoi.players on
    maskOpponentsHand k player
      | k == key = player
      | otherwise = player {Hanafuda.Player.hand = Hanafuda.empty}
    Object ast = toJSON $ on {
        Hanafuda.KoiKoi.players = Hanafuda.Player.Players $ mapWithKey maskOpponentsHand unfiltered
      }

play :: Hanafuda.KoiKoi.Environment m => Player.Key -> Hanafuda.KoiKoi.Move -> T -> m (Hanafuda.KoiKoi.Game Player.Key)
play key move on
  | Hanafuda.KoiKoi.playing on == key =
    Hanafuda.KoiKoi.play move on
  | otherwise = throwError "Not your turn"