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)
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)
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
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"
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
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