116 lines
3.8 KiB
Haskell
116 lines
3.8 KiB
Haskell
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE StandaloneDeriving #-}
|
|
{-# LANGUAGE DeriveGeneric #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
module Game (
|
|
Key
|
|
, View
|
|
, T
|
|
, export
|
|
, new
|
|
, play
|
|
) where
|
|
|
|
import Data.Text (pack)
|
|
import Data.Map (mapWithKey)
|
|
import Data.Aeson (FromJSON(..), ToJSON(..), ToJSON1(..), ToJSONKey(..), 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 (Game(..), Mode(..), Move(..), On(..), Over(..), Score, Step(..), Yaku(..), new, play)
|
|
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 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.Mode
|
|
|
|
instance FromJSON Hanafuda.KoiKoi.Move where
|
|
parseJSON = genericParseJSON JSON.singleLCField
|
|
instance ToJSON Hanafuda.KoiKoi.Move where
|
|
toEncoding = genericToEncoding JSON.singleLCField
|
|
|
|
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 ToJSON Hanafuda.KoiKoi.Step where
|
|
toEncoding = genericToEncoding JSON.defaultOptions
|
|
|
|
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
|
|
|
|
instance ToJSON On
|
|
instance ToJSON Over
|
|
|
|
type T = Hanafuda.KoiKoi.Game Player.Key
|
|
|
|
instance ToJSON T
|
|
|
|
type Key = Data.Key T
|
|
|
|
new :: Player.Key -> Player.Key -> IO T
|
|
new p1 p2 = do
|
|
on <- Hanafuda.KoiKoi.new [p1, p2] Hanafuda.KoiKoi.WholeYear
|
|
return $ Hanafuda.KoiKoi.On on
|
|
|
|
export :: Player.Key -> T -> T
|
|
export key (Hanafuda.KoiKoi.On on) = Hanafuda.KoiKoi.On $ on {
|
|
Hanafuda.KoiKoi.deck = []
|
|
, Hanafuda.KoiKoi.players = Hanafuda.Player.Players $ mapWithKey maskOpponentsHand unfiltered
|
|
}
|
|
where
|
|
Hanafuda.Player.Players unfiltered = Hanafuda.KoiKoi.players on
|
|
maskOpponentsHand k player
|
|
| k == key = player
|
|
| otherwise = player {Hanafuda.Player.hand = Hanafuda.empty}
|
|
export _ game = game
|
|
|
|
play :: Player.Key -> Hanafuda.KoiKoi.Move -> T -> IO T
|
|
play key move (Hanafuda.KoiKoi.On on)
|
|
| Hanafuda.KoiKoi.playing on == key = do
|
|
newState <- Hanafuda.KoiKoi.play move on
|
|
return $ newState
|
|
| otherwise = return $ Hanafuda.KoiKoi.Error "Not your turn"
|
|
play _ _ _ = return $ Hanafuda.KoiKoi.Error "This game is over"
|