server/src/Game.hs

{-# 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"}