module Language.Nomyx.Game (GameEvent(..), update, update', LoggedGame(..), game, gameLog, emptyGame,
execWithGame, execWithGame', outputAll, getLoggedGame, tracePN, getTimes, activeRules, pendingRules, rejectedRules) where
import Prelude
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
data TimedEvent = TimedEvent UTCTime GameEvent deriving (Show, Read, Eq, Ord)
data GameEvent = GameSettings GameName GameDesc UTCTime
| JoinGame PlayerNumber PlayerName
| LeaveGame PlayerNumber
| ProposeRuleEv PlayerNumber SubmitRule
| InputChoiceResult PlayerNumber EventNumber Int
| InputStringResult PlayerNumber String String
| OutputPlayer 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 = [],
_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 (InputChoiceResult pn en ci) _ = mapStateIO $ inputChoiceResult en ci pn
enactEvent (InputStringResult pn ti res) _ = mapStateIO $ inputStringResult (InputString pn ti) res pn
enactEvent (OutputPlayer pn s) _ = mapStateIO $ outputPlayer s pn
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) = do
currentTime ~= t
enactEvent ge inter
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]
evalTimedEvent te inter
evalTimedEvent :: TimedEvent -> Maybe (RuleCode -> IO RuleFunc) -> StateT LoggedGame IO ()
evalTimedEvent (TimedEvent _ e) inter = focus game $ do
enactEvent e inter
lg <- get
lift $ evaluate lg
return ()
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"
outputPlayer :: String -> PlayerNumber -> State Game ()
outputPlayer s pn = void $ outputs %= ((pn, s) : )
outputAll :: String -> StateT LoggedGame IO ()
outputAll s = do
pls <- access (game >>> players)
mapM_ (update . ((flip OutputPlayer) s)) (map _playerNumber pls)
inputChoiceResult :: EventNumber -> Int -> PlayerNumber -> State Game ()
inputChoiceResult eventNumber choiceIndex pn = do
tracePN pn $ "input choice result: Event " ++ (show eventNumber) ++ ", choice " ++ (show choiceIndex)
runEvalError pn $ triggerChoice eventNumber choiceIndex
inputStringResult :: Event InputString -> String -> PlayerNumber -> State Game ()
inputStringResult event input pn = do
tracePN pn $ "input String result: input " ++ input
runEvalError pn $ triggerEvent_ event (InputStringData input)
getTimes :: EventHandler -> Maybe UTCTime
getTimes (EH _ _ (Time t) _ EvActive) = 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)