{-|
Module      : Resources.Start
Description : 
Copyright   : (c) Alexander Vieth, 2015
Licence     : BSD3
Maintainer  : aovieth@gmail.com
Stability   : experimental
Portability : non-portable (GHC only)
-}

{-# LANGUAGE AutoDeriveTypeable #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DeriveGeneric #-}

module Resources.Start (

      resource

    ) where

import GHC.Generics
import Control.Monad.Trans.Class
import Control.Monad.State.Class as SC
import Control.Monad.Trans.Reader
import Control.Monad.Trans.Except
import Data.Typeable
import qualified Data.Map as M
import qualified Data.Set as S
import Data.Stream as Stream
import Data.AtLeast
import Data.TypeNat.Vect
import Data.Aeson
import Data.JSON.Schema
import Data.Functor.Identity
import Data.Functor.Constant
import Data.List (sortBy, (\\))
import Data.Hourglass
import Rest
import Rest.Resource as R
import Diplomacy.GreatPower
import Diplomacy.Game
import Types.Server
import Types.GameId
import Types.GameState
import Types.UserData as UD
import Types.Credentials as Credentials

-- | Use this resource to start a game.
--
--     PUT : ask to start the game, passing the administrator credentials
--           in the request body.
--
resource :: Resource (ReaderT GameId Server) (ReaderT GameId Server) () Void Void
resource = mkResourceId
    { R.name = "start"
    , R.schema = singleton () $ unnamedSingle (const ())
    , R.update = Just update
    }
  where

    update :: Handler (ReaderT GameId Server)
    update = secureHandler $ mkInputHandler (jsonO . jsonE . jsonI) $ doUpdate

    doUpdate :: StartGameInput -> ExceptT (Reason StartGameError) (ReaderT GameId Server) StartGameOutput
    doUpdate input = withAdminCredentials creds startGame
      where

        StartGameInput creds = input

        startGame :: ExceptT (Reason StartGameError) (ReaderT GameId Server) StartGameOutput
        startGame = do
            state <- SC.get
            gameId <- lift ask
            let ds = randomDoubles state
            let t = currentTime state
            case M.lookup gameId (games state) of
                Nothing -> throwE NotFound
                Just (password, gameState) -> do
                    case startGameState t ds gameState of
                        Left e -> throwE (domainReason e)
                        Right gs -> do
                            SC.put (state { games = M.alter (const (Just (password, gs))) gameId (games state) })
                            return Started

-- | We assume the GameState has at most 7 registered users.
--   This is always true if the GameState is modified by registerUser only.
--   TODO should enforce this at the type level, but it's not so fragile so
--   whatever.
startGameState :: Elapsed -> Stream.Stream Double -> GameState -> Either StartGameError GameState
startGameState t randomDoubles game = case game of
    GameNotStarted map duration duration' ->
        if notEnoughPlayers
        then Left NotEnoughPlayers
        else if tooManyPlayers
        then Left TooManyPlayers
        else Right (GameStarted map' (AtLeast (VCons (SomeGame newGame) VNil) []) duration duration' t False)
      where
        registered :: [(Username, Password)]
        registered = fmap (\(x, y) -> (x, UD.password y)) (M.toList map)
        registeredRandomOrder :: [(Username, Password)]
        registeredRandomOrder = fmap fst (sortBy (\(_, x) (_, y) -> x `compare` y) (Prelude.zip registered (Stream.toList randomDoubles)))
        controlUnits :: [S.Set GreatPower]
        controlUnits = case length registered of
            7 -> fmap S.singleton [minBound..maxBound]
            6 -> fmap S.singleton ([minBound..maxBound] \\ [Italy])
            5 -> fmap S.singleton ([minBound..maxBound] \\ [Germany, Italy])
            4 -> [S.singleton England, S.fromList [Austria, France], S.fromList [Germany, Turkey], S.fromList [Italy, Russia]]
            3 -> [S.fromList [England, Germany, Austria], S.fromList [Russia, Italy], S.fromList [France, Turkey]]
            _ -> []
        notEnoughPlayers = length registered < 3
        tooManyPlayers = length registered > 7
        -- We randomly assign each player to a control unit.
        assignments :: [((Username, Password), S.Set GreatPower)]
        assignments = Prelude.zip registeredRandomOrder controlUnits
        makeUserData :: ((Username, Password), S.Set GreatPower) -> (Username, UserData S.Set)
        makeUserData ((u, p), s) = (u, UserData p s)
        map' = M.fromList (fmap makeUserData assignments)
    GameStarted _ _ _ _ _ _ -> Left GameAlreadyStarted

newtype StartGameInput = StartGameInput Credentials

deriving instance Generic StartGameInput
deriving instance Typeable StartGameInput
instance FromJSON StartGameInput
instance ToJSON StartGameInput
instance JSONSchema StartGameInput where
    schema = gSchema

data StartGameOutput = Started

deriving instance Generic StartGameOutput
deriving instance Typeable StartGameOutput
instance FromJSON StartGameOutput
instance ToJSON StartGameOutput
instance JSONSchema StartGameOutput where
    schema = gSchema

data StartGameError = GameAlreadyStarted | NotEnoughPlayers | TooManyPlayers

deriving instance Generic StartGameError
deriving instance Typeable StartGameError
instance ToJSON StartGameError
instance JSONSchema StartGameError where
    schema = gSchema

instance ToResponseCode StartGameError where
    toResponseCode _ = 403