{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} module Game ( Key , 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(..), 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 T = Hanafuda.KoiKoi.Game Player.Key deriving instance Generic T instance ToJSON T where toEncoding = genericToEncoding JSON.defaultOptions 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 Key = Data.Key T new :: Player.Key -> Player.Key -> IO T new p1 p2 = do Hanafuda.KoiKoi.new [p1, p2] $ Hanafuda.KoiKoi.FirstAt 1 export :: Player.Key -> T -> Value export key game = Object $ insert "deck" (toJSON $ length $ Hanafuda.KoiKoi.deck game) $ ast where Hanafuda.Player.Players unfiltered = Hanafuda.KoiKoi.players game maskOpponentsHand k player | k == key = player | otherwise = player {Hanafuda.Player.hand = Hanafuda.empty} Object ast = toJSON $ game { 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 game | Hanafuda.KoiKoi.playing game == key = Hanafuda.KoiKoi.play move game | otherwise = throwError "Not your turn"