119 lines
3.9 KiB
Haskell
119 lines
3.9 KiB
Haskell
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE StandaloneDeriving #-}
|
|
{-# LANGUAGE DeriveGeneric #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
module Game (
|
|
Key
|
|
, View(..)
|
|
, T(..)
|
|
, export
|
|
, new
|
|
) where
|
|
|
|
import Data.Text (pack)
|
|
import Data.Map (Map, (!), fromList, mapKeys, 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(..), Seat(..), Points)
|
|
import qualified Hanafuda.KoiKoi (Mode(..), Move(..), On(..), Score, Step(..), Yaku(..), new)
|
|
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
|
|
|
|
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
|
|
|
|
data T = T {
|
|
keys :: Map Hanafuda.Player.Seat Player.Key
|
|
, seats :: Map Player.Key Hanafuda.Player.Seat
|
|
, state :: Hanafuda.KoiKoi.On
|
|
}
|
|
|
|
type Key = Data.Key T
|
|
type Players a = Map Player.Key a
|
|
|
|
data View = View {
|
|
mode :: Hanafuda.KoiKoi.Mode
|
|
, scores :: Players Hanafuda.Player.Points
|
|
, month :: Hanafuda.Flower
|
|
, players :: Players (Hanafuda.Player.Player Hanafuda.KoiKoi.Score)
|
|
, playing :: Player.Key
|
|
, winning :: Player.Key
|
|
, oyake :: Player.Key
|
|
, river :: [Hanafuda.Card]
|
|
, step :: Hanafuda.KoiKoi.Step
|
|
, trick :: [Hanafuda.Card]
|
|
} deriving (Generic)
|
|
|
|
instance ToJSON View where
|
|
toEncoding = genericToEncoding JSON.singleLCField
|
|
|
|
new :: Player.Key -> Player.Key -> IO T
|
|
new p1 p2 = do
|
|
state <- Hanafuda.KoiKoi.new Hanafuda.KoiKoi.WholeYear
|
|
return $ T {
|
|
keys = fromList [(Hanafuda.Player.Player1, p1), (Hanafuda.Player.Player2, p2)]
|
|
, seats = fromList [(p1, Hanafuda.Player.Player1), (p2, Hanafuda.Player.Player2)]
|
|
, state
|
|
}
|
|
|
|
export :: Player.Key -> T -> View
|
|
export key (T {keys, state}) = View {
|
|
mode = Hanafuda.KoiKoi.mode state
|
|
, scores = reindex $ Hanafuda.KoiKoi.scores state
|
|
, month = Hanafuda.KoiKoi.month state
|
|
, players = mapWithKey (\k -> if k == key then id else maskHand) players
|
|
, playing = keys ! Hanafuda.KoiKoi.playing state
|
|
, winning = keys ! Hanafuda.KoiKoi.winning state
|
|
, oyake = keys ! Hanafuda.KoiKoi.oyake state
|
|
, river = Hanafuda.cardsOfPack $ Hanafuda.KoiKoi.river state
|
|
, step = Hanafuda.KoiKoi.step state
|
|
, trick = Hanafuda.KoiKoi.trick state
|
|
}
|
|
where
|
|
reindex = mapKeys (keys !)
|
|
players = reindex $ Hanafuda.KoiKoi.players state
|
|
maskHand player = player {Hanafuda.Player.hand = Hanafuda.empty}
|
|
|
|
play :: Player.Key -> Hanafuda.KoiKoi.Move -> T -> T
|
|
play = undefined
|