{-# LANGUAGE StandaloneDeriving, GADTs, DeriveDataTypeable,
    FlexibleContexts, GeneralizedNewtypeDeriving, ScopedTypeVariables,
    MultiParamTypeClasses, TemplateHaskell, TypeFamilies,
    TypeOperators, FlexibleInstances, NoMonomorphismRestriction,
    TypeSynonymInstances, DoAndIfThenElse, RecordWildCards #-}

-- | This module implements Game management.
-- a game is a set of rules, and results of actions made by players (usually vote results)
-- the module manages the effects of rules over each others.
module Language.Nomyx.Game (GameEvent(..), update, update', LoggedGame(..), game, gameLog, emptyGame,
  execWithGame, execWithGame', getLoggedGame, tracePN, getTimes, activeRules, pendingRules,
  rejectedRules, UInputData(..))  where

import Prelude hiding (log)
import Control.Monad.State
import Data.List
import Language.Nomyx hiding (outputAll)
import Data.Lens
import Control.Category ((>>>))
import Data.Lens.Template
import Control.Exception as E
import Control.Monad.Trans.State hiding (get)

data TimedEvent = TimedEvent UTCTime GameEvent deriving (Show, Read, Eq, Ord)

data GameEvent = GameSettings      GameName GameDesc UTCTime
               | JoinGame          PlayerNumber PlayerName
               | LeaveGame         PlayerNumber
               | ProposeRuleEv     PlayerNumber SubmitRule
               | InputResult       PlayerNumber EventNumber UInputData
               | GLog              (Maybe PlayerNumber) String
               | TimeEvent         UTCTime
               | SystemAddRule     SubmitRule
                 deriving (Show, Read, Eq, Ord)

--A game being non serializable, we have to store events in parralel in order to rebuild the state latter.
data LoggedGame = LoggedGame { _game :: Game,
                               _gameLog :: [TimedEvent]}
                               deriving (Read, Show)

instance Eq LoggedGame where
   (LoggedGame {_game=g1}) == (LoggedGame {_game=g2}) = g1 == g2

instance Ord LoggedGame where
   compare (LoggedGame {_game=g1}) (LoggedGame {_game=g2}) = compare g1 g2


emptyGame name desc date = Game {
    _gameName      = name,
    _gameDesc      = desc,
    _rules         = [],
    _players       = [],
    _variables     = [],
    _events        = [],
    _outputs       = [],
    _victory       = [],
    _logs          = [],
    _currentTime   = date}

$( makeLens ''LoggedGame)

--TODO: get rid of inter param?
enactEvent :: GameEvent -> Maybe (RuleCode -> IO RuleFunc) -> StateT Game IO ()
enactEvent (GameSettings name desc date) _    = mapStateIO $ gameSettings name desc date
enactEvent (JoinGame pn name) _               = mapStateIO $ joinGame name pn
enactEvent (LeaveGame pn) _                   = mapStateIO $ leaveGame pn
enactEvent (ProposeRuleEv pn sr) (Just inter) = void $ proposeRule sr pn inter
enactEvent (InputResult pn en ir) _           = mapStateIO $ inputResult pn en ir
enactEvent (GLog mpn s) _                     = mapStateIO $ logGame s mpn
enactEvent (TimeEvent t) _                    = mapStateIO $ runEvalError 0 $ void $ evTriggerTime t
enactEvent (SystemAddRule r) (Just inter)     = systemAddRule r inter
enactEvent (ProposeRuleEv _ _) Nothing        = error "ProposeRuleEv: interpreter function needed"
enactEvent (SystemAddRule _) Nothing          = error "SystemAddRule: interpreter function needed"

enactTimedEvent :: Maybe (RuleCode -> IO RuleFunc) -> TimedEvent -> StateT Game IO ()
enactTimedEvent inter (TimedEvent t ge) = flip stateCatch updateError $ do
   currentTime ~= t
   enactEvent ge inter
   lg <- get
   lift $ evaluate lg
   return ()

updateError :: SomeException -> StateT Game IO ()
updateError e = do
   liftIO $ putStrLn $ "IO error: " ++ (show e)
   mapStateIO $ logGame ("IO error: " ++ (show e)) Nothing

update :: GameEvent -> StateT LoggedGame IO ()
update ge = update' Nothing ge

update' :: Maybe (RuleCode -> IO RuleFunc) -> GameEvent -> StateT LoggedGame IO ()
update' inter ge = do
   t <- access $ game >>> currentTime
   let te = TimedEvent t ge
   gameLog %= \gl -> gl ++ [te]
   focus game $ enactTimedEvent inter te

getLoggedGame :: Game -> (RuleCode -> IO RuleFunc) -> [TimedEvent] -> IO LoggedGame
getLoggedGame g mInter tes = do
   let a = mapM_ (enactTimedEvent (Just mInter)) tes
   g' <- execStateT a g
   return $ LoggedGame g' tes


-- | initialize the game.
gameSettings :: GameName -> GameDesc -> UTCTime -> State Game ()
gameSettings name desc date = do
   gameName ~= name
   gameDesc ~= desc
   currentTime ~= date
   return ()


-- | join the game.
joinGame :: PlayerName -> PlayerNumber -> State Game ()
joinGame name pn = do
   g <- get
   case find ((== pn) . getL playerNumber) (_players g) of
      Just _ -> return ()
      Nothing -> do
         tracePN pn $ "Joining game: " ++ (_gameName g)
         let player = PlayerInfo { _playerNumber = pn, _playerName = name}
         players %= (player : )
         runEvalError pn $ triggerEvent_ (Player Arrive) (PlayerData player)


-- | leave the game.
leaveGame :: PlayerNumber -> State Game ()
leaveGame pn = runEvalError pn $ void $ evDelPlayer pn

-- | insert a rule in pending rules.
proposeRule :: SubmitRule -> PlayerNumber -> (RuleCode -> IO RuleFunc) -> StateT Game IO ()
proposeRule sr pn inter = do
   rule <- createRule sr pn inter
   mapStateIO $ runEvalError pn $ do
      r <- evProposeRule rule
      if r == True then tracePN pn $ "Your rule has been added to pending rules."
      else tracePN pn $ "Error: Rule could not be proposed"

logGame :: String -> (Maybe PlayerNumber) -> State Game ()
logGame s mpn = do
   time <- access currentTime
   void $ logs %= (Log mpn time s : )

inputResult :: PlayerNumber -> EventNumber -> UInputData -> State Game ()
inputResult pn en ir = do
   tracePN pn $ "input result: Event " ++ (show en) ++ ", choice " ++  (show ir)
   runEvalError pn $ triggerInput en ir

getTimes :: EventHandler -> Maybe UTCTime
getTimes (EH _ _ (Time t) _ SActive) = Just t
getTimes _ = Nothing

-- | A helper function to use the state transformer GameState.
-- It additionally sets the current time.
execWithGame :: UTCTime -> State LoggedGame () -> LoggedGame -> LoggedGame
execWithGame t gs g = execState gs $ ((game >>> currentTime) `setL` t $ g)

execWithGame' :: UTCTime -> StateT LoggedGame IO () -> LoggedGame -> IO LoggedGame
execWithGame' t gs g = execStateT gs ((game >>> currentTime) `setL` t $ g)


activeRules :: Game -> [Rule]
activeRules = sort . filter ((==Active) . getL rStatus) . _rules

pendingRules :: Game -> [Rule]
pendingRules = sort . filter ((==Pending) . getL rStatus) . _rules

rejectedRules :: Game -> [Rule]
rejectedRules = sort . filter ((==Reject) . getL rStatus) . _rules

instance Ord PlayerInfo where
   h <= g = (_playerNumber h) <= (_playerNumber g)


createRule :: SubmitRule -> PlayerNumber -> (RuleCode -> IO RuleFunc) -> StateT Game IO Rule
createRule (SubmitRule name desc code) pn inter = do
   rs <- access rules
   let rn = getFreeNumber $ map _rNumber rs
   rf <- lift $ inter code
   tracePN pn $ "Creating rule n=" ++ (show rn) ++ " code=" ++ code
   return $ Rule {_rNumber = rn,
                  _rName = name,
                  _rDescription = desc,
                  _rProposedBy = pn,
                  _rRuleCode = code,
                  _rRuleFunc = rf,
                  _rStatus = Pending,
                  _rAssessedBy = Nothing}

systemAddRule :: SubmitRule -> (RuleCode -> IO RuleFunc) -> StateT Game IO ()
systemAddRule sr inter = do
   rule <- createRule sr 0 inter
   let sysRule = (rStatus ^= Active) >>> (rAssessedBy ^= Just 0)
   rules %= (sysRule rule : )
   mapStateIO $ runEvalError 0 $ void $ evalExp (_rRuleFunc rule) (_rNumber rule)

stateCatch = liftCatch E.catch