123 lines
4.0 KiB
Haskell
123 lines
4.0 KiB
Haskell
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE StandaloneDeriving #-}
|
|
{-# LANGUAGE DeriveGeneric #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
module Game (
|
|
Hanafuda.KoiKoi.Game(..)
|
|
, Key
|
|
, View
|
|
, T(..)
|
|
, export
|
|
, new
|
|
, play
|
|
) where
|
|
|
|
import Data.Text (pack)
|
|
import Data.Map (Map, (!), fromList, mapWithKey)
|
|
import Data.Aeson (FromJSON(..), ToJSON(..), ToJSON1(..), ToJSONKey(..), genericParseJSON, genericToEncoding, genericLiftToEncoding, toEncoding1, toJSON1)
|
|
import Data.Aeson.Types (toJSONKeyText)
|
|
import qualified JSON (defaultOptions, distinct, singleLCField)
|
|
import qualified Data (Key, RW(..))
|
|
import qualified Player (Key)
|
|
import qualified Hanafuda (Flower(..), Card(..), Pack, cardsOfPack, empty)
|
|
import qualified Hanafuda.Player (Player(..), Seat(..))
|
|
import qualified Hanafuda.KoiKoi.Game (remap)
|
|
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
|
|
|
|
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 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
|
|
|
|
instance ToJSON On
|
|
instance ToJSON Over
|
|
|
|
instance ToJSON View where
|
|
toEncoding = genericToEncoding JSON.distinct
|
|
|
|
data T = T {
|
|
keys :: Map Hanafuda.Player.Seat Player.Key
|
|
, state :: Hanafuda.KoiKoi.Game Hanafuda.Player.Seat
|
|
}
|
|
|
|
type Key = Data.Key T
|
|
|
|
instance Data.RW (Hanafuda.KoiKoi.Game Hanafuda.Player.Seat) T where
|
|
get = state
|
|
set state game = game {state}
|
|
|
|
new :: Player.Key -> Player.Key -> IO T
|
|
new p1 p2 = do
|
|
on <- Hanafuda.KoiKoi.new Hanafuda.KoiKoi.WholeYear
|
|
return $ T {
|
|
keys = fromList [(Hanafuda.Player.Player1, p1), (Hanafuda.Player.Player2, p2)]
|
|
, state = Hanafuda.KoiKoi.On on
|
|
}
|
|
|
|
export :: Player.Key -> T -> View
|
|
export key (T {keys, state}) =
|
|
case Hanafuda.KoiKoi.Game.remap (keys !) state of
|
|
view@(Hanafuda.KoiKoi.Error _) -> view
|
|
view@(Hanafuda.KoiKoi.Over _) -> view
|
|
(Hanafuda.KoiKoi.On on) -> Hanafuda.KoiKoi.On $ on {
|
|
Hanafuda.KoiKoi.stock = []
|
|
, Hanafuda.KoiKoi.players = mapWithKey maskOpponentsHand $ Hanafuda.KoiKoi.players on
|
|
}
|
|
where
|
|
maskOpponentsHand k player
|
|
| k == key = player
|
|
| otherwise = player {Hanafuda.Player.hand = Hanafuda.empty}
|
|
|
|
play :: Player.Key -> Hanafuda.KoiKoi.Move -> T -> IO T
|
|
play key move game@(T {keys, state = Hanafuda.KoiKoi.On on})
|
|
| keys ! Hanafuda.KoiKoi.playing on == key = do
|
|
newState <- Hanafuda.KoiKoi.play move on
|
|
return $ game {state = newState}
|
|
| otherwise = return $ game {state = Hanafuda.KoiKoi.Error "Not your turn"}
|
|
play _ _ game = return $ game {state = Hanafuda.KoiKoi.Error "This game is over"}
|