module Language.Nomyx.Engine.GameEvents where
import Prelude hiding (log)
import Control.Monad.State
import Data.List
import Language.Nomyx.Expression
import Language.Nomyx.Engine.Evaluation
import Language.Nomyx.Engine.Game
import Language.Nomyx.Engine.Utils
import Data.Lens
import Control.Category ((>>>))
import Data.Lens.Template
import Control.Exception as E
import Control.Monad.Trans.State hiding (get)
import Data.Maybe
import Data.Time
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)
data TimedEvent = TimedEvent UTCTime GameEvent deriving (Show, Read, Eq, Ord)
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
$( makeLens ''LoggedGame)
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
execGameEvent :: GameEvent -> StateT LoggedGame IO ()
execGameEvent ge = execGameEvent' Nothing ge
execGameEvent' :: Maybe (RuleCode -> IO RuleFunc) -> GameEvent -> StateT LoggedGame IO ()
execGameEvent' 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
gameSettings :: GameName -> GameDesc -> UTCTime -> State Game ()
gameSettings name desc date = do
gameName ~= name
gameDesc ~= desc
currentTime ~= date
return ()
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)
leaveGame :: PlayerNumber -> State Game ()
leaveGame pn = runEvalError pn $ void $ evDelPlayer pn
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"
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)
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
getEventHandler :: EventNumber -> LoggedGame -> EventHandler
getEventHandler en g = fromJust $ findEvent en (_events $ _game g)
getTimes :: EventHandler -> Maybe UTCTime
getTimes (EH _ _ (Time t) _ SActive) = Just t
getTimes _ = Nothing
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
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}
stateCatch = liftCatch E.catch