119 lines
4.0 KiB
Haskell
119 lines
4.0 KiB
Haskell
{-# 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"
|