{-|
Module : Resources.Advance
Description :
Copyright : (c) Alexander Vieth, 2015
Licence : BSD3
Maintainer : aovieth@gmail.com
Stability : experimental
Portability : non-portable (GHC only)
-}
{-# LANGUAGE AutoDeriveTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE GADTs #-}
module Resources.Advance (
resource
, advance
) where
import GHC.Generics
import Data.Typeable
import Control.Monad.Trans.Class
import Control.Monad.Trans.Reader
import Control.Monad.Trans.Except
import Control.Monad.State.Class as SC
import qualified Data.Map as M
import Data.AtLeast
import Data.TypeNat.Vect
import Data.Aeson
import Data.JSON.Schema
import Rest
import Rest.Resource as R
import Diplomacy.Game
import Diplomacy.SupplyCentreDeficit
import Types.Server
import Types.GameId
import Types.Credentials
import Types.GameState
resource :: Resource (ReaderT GameId Server) (ReaderT GameId Server) () Void Void
resource = mkResourceId
{ R.name = "advance"
, R.schema = singleton () $ unnamedSingle (const ())
, R.update = Just update
}
where
update :: Handler (ReaderT GameId Server)
update = secureHandler $ mkInputHandler (jsonO . jsonE . jsonI) $ doUpdate
doUpdate :: AdvanceInput -> ExceptT (Reason AdvanceError) (ReaderT GameId Server) AdvanceOutput
doUpdate input = withAdminCredentials creds advanceGame
where
AdvanceInput creds = input
advanceGame :: ExceptT (Reason AdvanceError) (ReaderT GameId Server) AdvanceOutput
advanceGame = do
gameId <- lift ask
modifyGameState gameId modifier
return GameAdvanced
modifier :: GameState -> ExceptT (Reason AdvanceError) (ReaderT GameId Server) GameState
modifier gameState = case gameState of
GameNotStarted _ _ _ -> throwE (domainReason AdvanceGameNotStarted)
GameStarted m (AtLeast (VCons someGame VNil) rest) duration duration' elapsed _ -> do
state <- SC.get
let nextGame = advance someGame
return (GameStarted m (AtLeast (VCons nextGame VNil) (someGame : rest)) duration duration' (currentTime state) False)
-- | Advance a game, resolving and then continuing, so that we also go from
-- Unresolved to Unresolved. Retreat and Adjust phases in which there is
-- nothing to do are skipped, but they are not forgotten! They're given
-- in the return value.
advance :: SomeGame -> SomeGame
advance (SomeGame game) = SomeGame (continue (resolve game))
{-
advance (SomeGame game) = case game of
TypicalGame TypicalRoundOne Unresolved _ _ _ ->
let resolved = resolve game
continued = continue resolved
in case M.size (gameDislodged continued) of
-- Automatically skip retreat phases where nobody is
-- dislodged.
0 -> advance (SomeGame continued)
_ -> AtLeast (VCons (SomeGame continued) VNil) []
TypicalGame TypicalRoundTwo Unresolved _ _ _ ->
let resolved = resolve game
continued = continue resolved
in case M.size (gameDislodged continued) of
-- Automatically skip retreat phases where nobody is
-- dislodged.
0 -> advance (SomeGame continued)
_ -> SomeGame continued
RetreatGame RetreatRoundOne Unresolved _ _ _ _ _ ->
let resolved = resolve game
continued = continue resolved
in SomeGame continued
RetreatGame RetreatRoundTwo Unresolved _ _ _ _ _ ->
let resolved = resolve game
continued = continue resolved
occupation = gameOccupation continued
control = gameControl continued
deficits = fmap (\greatPower -> supplyCentreDeficit greatPower occupation control) [minBound..maxBound]
in if all (== 0) deficits
-- Automatically skip adjust phases where nobody has a deficit,
-- positive or negative.
-- TODO must also check that, in case there's a negative
-- deficit, this great power actually has a place to build.
-- Really, we ought to use the order synthesizers to see whether
-- any player actually has a choice. That goes for typical
-- phase as well; it's rare, but it could happen, maybe?
-- No, that would cause infinite loop behaviour in advance.
then advance (SomeGame continued)
else SomeGame continued
AdjustGame _ Unresolved _ _ _ ->
let resolved = resolve game
continued = continue resolved
in SomeGame continued
-}
data AdvanceError = AdvanceGameNotStarted
instance ToResponseCode AdvanceError where
toResponseCode _ = 403
deriving instance Generic AdvanceError
deriving instance Typeable AdvanceError
instance FromJSON AdvanceError
instance ToJSON AdvanceError
instance JSONSchema AdvanceError where
schema = gSchema
newtype AdvanceInput = AdvanceInput Credentials
deriving instance Generic AdvanceInput
deriving instance Typeable AdvanceInput
instance FromJSON AdvanceInput
instance ToJSON AdvanceInput
instance JSONSchema AdvanceInput where
schema = gSchema
data AdvanceOutput = GameAdvanced
deriving instance Generic AdvanceOutput
deriving instance Typeable AdvanceOutput
instance FromJSON AdvanceOutput
instance ToJSON AdvanceOutput
instance JSONSchema AdvanceOutput where
schema = gSchema