Nomyx-Core 0.6.2 → 0.7.0
raw patch · 14 files changed
+418/−297 lines, 14 filesdep ~Nomyx-Languagedep ~basedep ~exceptions
Dependency ranges changed: Nomyx-Language, base, exceptions, hint-server, template-haskell, unix
Files
- Nomyx-Core.cabal +8/−8
- src/Data/Todo.hs +15/−8
- src/Nomyx/Core/Context.hs +0/−1
- src/Nomyx/Core/Engine.hs +2/−2
- src/Nomyx/Core/Engine/EvalUtils.hs +54/−76
- src/Nomyx/Core/Engine/Evaluation.hs +222/−130
- src/Nomyx/Core/Engine/GameEvents.hs +17/−15
- src/Nomyx/Core/Engine/Test.hs +75/−41
- src/Nomyx/Core/Engine/Types.hs +13/−6
- src/Nomyx/Core/Multi.hs +4/−3
- src/Nomyx/Core/Profile.hs +0/−1
- src/Nomyx/Core/Serialize.hs +1/−0
- src/Nomyx/Core/Session.hs +3/−3
- src/Nomyx/Core/Test.hs +4/−3
Nomyx-Core.cabal view
@@ -1,5 +1,5 @@ name: Nomyx-Core-version: 0.6.2+version: 0.7.0 cabal-version: >=1.6 build-type: Simple license: BSD3@@ -15,12 +15,12 @@ data-dir: data library - build-depends: Nomyx-Language == 0.6.2,+ build-depends: Nomyx-Language == 0.7.0, DebugTraceHelpers == 0.12.*, MissingH == 1.2.*, acid-state == 0.12.*, aeson == 0.7.*,- base == 4.6.*,+ base >= 4.6 && <5, blaze-html == 0.7.*, blaze-markup == 0.6.*, bytestring == 0.10.*,@@ -29,11 +29,11 @@ data-lens-fd == 2.0.*, directory == 1.2.*, either-unwrap == 1.1.*,- exceptions == 0.3.*,+ exceptions == 0.6.*, filepath == 1.3.*, happstack-authenticate == 0.10.*, hint == 0.4.*,- hint-server == 1.3.*,+ hint-server == 1.4.*, hscolour == 1.20.*, ixset == 1.0.*, mime-mail == 0.4.*,@@ -46,13 +46,13 @@ stm == 2.4.*, tar == 0.4.*, temporary == 1.1.*,- template-haskell == 2.8.*,+ template-haskell >= 2.8 && < 2.10, text == 1.1.*, time == 1.4.* if os(windows) Cpp-options: -DWINDOWS else- build-depends: unix == 2.6.*+ build-depends: unix >= 2.6 && < 3 extensions: CPP exposed: True@@ -82,4 +82,4 @@ source-repository head type: git- location: https://github.com/cdupont/Nomyx-Core.git+ location: https://github.com/cdupont/Nomyx.git
src/Data/Todo.hs view
@@ -10,20 +10,25 @@ instance Alternative (Todo a) where empty = Todo []- Todo a <|> Todo b = Todo $ a ++ b- Todo _ <|> n = n- m <|> _ = m+ Todo as <|> Todo bs = Todo $ as ++ bs+ Todo _ <|> n = n+ m <|> _ = m instance Applicative (Todo a) where- pure = Done- Todo a <*> Todo b = Todo $ a ++ b- Todo a <*> _ = Todo a- Done f <*> r = fmap f r+ pure = Done+ Todo as <*> Todo bs = Todo $ as ++ bs+ Todo as <*> _ = Todo as+ Done f <*> r = fmap f r instance Functor (Todo a) where fmap _ (Todo x) = Todo x fmap f (Done y) = Done $ f y +instance Monad (Todo a) where+ return = Done+ Todo as >>= _ = Todo as+ Done a >>= f = f a+ toEither :: Todo a b -> Either [a] b toEither (Todo as) = Left as toEither (Done a) = Right a@@ -32,4 +37,6 @@ fromEither (Left as) = Todo as fromEither (Right a) = Done a -+toMaybe :: Todo a b -> Maybe b+toMaybe (Todo _) = Nothing+toMaybe (Done a) = Just a
src/Nomyx/Core/Context.hs view
@@ -20,7 +20,6 @@ "Control.Monad.Error", "Control.Monad.Fix", "Control.Monad.Identity",- "Control.Monad.Instances", "Control.Monad.RWS", "Control.Monad.Reader", "Control.Monad.State",
src/Nomyx/Core/Engine.hs view
@@ -29,8 +29,8 @@ -- * Events management events, getEventFields,- getInput, getEventInfo,+ getInput, -- * Inputs management InputData(..),@@ -43,6 +43,7 @@ -- * Time getTimes,+ getGameTimes, currentTime, -- * Misc@@ -53,7 +54,6 @@ ) where import Nomyx.Core.Engine.Evaluation-import Nomyx.Core.Engine.EvalUtils import Nomyx.Core.Engine.Types import Nomyx.Core.Engine.GameEvents import Nomyx.Core.Engine.Utils
src/Nomyx/Core/Engine/EvalUtils.hs view
@@ -12,65 +12,30 @@ import Control.Monad import Control.Monad.State import Control.Monad.Reader-import Data.List+import Control.Category import Data.Typeable import Data.Lens import Data.Maybe-import Data.Either import Control.Applicative-import Control.Monad.Error (ErrorT(..))+import Control.Monad.Error import Language.Nomyx.Expression import Nomyx.Core.Engine.Types import Nomyx.Core.Engine.Utils-import Data.Todo --- update the EventInfo with the field data-updateEventInfo :: (Typeable a, Show a) => Field a -> a -> EventInfo -> (EventInfo, Maybe SomeData)-updateEventInfo field dat ei@(EventInfo _ _ ev _ _ envi) =- if (SomeField field) `elem` (getEventFields ev envi) -- if the field if found among the remaining fields of the event- then case getEventResult ev (eventRes : envi) of -- then check the event with that field result included- Todo _ -> (env ^= (eventRes : envi) $ ei, Nothing) -- some fields are left to complete: add ours in the environment- Done a -> (env ^= [] $ ei, Just $ SomeData a) -- the event is now complete: empty the environment and set the handler to be triggered- else (ei, Nothing) -- field not found: do nothing- where eventRes = EventEnv field dat----- compute the result of an event given an environment.--- in the case the event cannot be computed because some fields results are pending, return that list instead.-getEventResult :: Event a -> [EventEnv] -> Todo SomeField a-getEventResult (PureEvent a) _ = Done a-getEventResult EmptyEvent _ = Todo []-getEventResult (SumEvent a b) ers = (getEventResult a ers) <|> (getEventResult b ers)-getEventResult (AppEvent f b) ers = (getEventResult f ers) <*> (getEventResult b ers)-getEventResult (BaseEvent a) ers = case lookupField a ers of- Just r -> Done r- Nothing -> Todo [SomeField a]-getEventResult (ShortcutEvents es f) ers =- let res = partitionEithers $ toEither <$> map (flip getEventResult ers) es- in case f (snd res) of- Just a -> Done a- Nothing -> Todo $ join $ fst res- -- find a field result in an environment-lookupField :: Typeable a => Field a -> [EventEnv] -> Maybe a-lookupField _ [] = Nothing-lookupField be (EventEnv a r : ers) = case (cast (a,r)) of- Just (a',r') -> if (a' == be) then Just r' else lookupField be ers- Nothing -> lookupField be ers----get the fields left to be completed in an event-getEventFields :: Event a -> [EventEnv] -> [SomeField]-getEventFields e er = case (getEventResult e er) of- Done _ -> []- Todo a -> a--errorHandler :: RuleNumber -> EventNumber -> String -> Evaluate ()-errorHandler rn en s = logAll $ "Error in rule " ++ show rn ++ " (triggered by event " ++ show en ++ "): " ++ s+-- TODO simplify?+lookupField :: Typeable a => Field a -> FieldAddress -> [FieldResult] -> Maybe a+lookupField _ _ [] = Nothing+lookupField fi fa ((FieldResult a r fa1) : ers) = case (cast (a,r)) of+ Just (a',r') -> if (a' == fi && maybe True (== fa) fa1)+ then Just r'+ else lookupField fi fa ers+ Nothing -> lookupField fi fa ers -getInput :: EventInfo -> InputNumber -> Maybe SomeField-getInput (EventInfo _ _ ev _ _ env) inn = find isInput (getEventFields ev env) where- isInput (SomeField (Input (Just n) _ _ _)) | n == inn = True- isInput _ = False+errorHandler :: EventNumber -> String -> Evaluate ()+errorHandler en s = do+ rn <- access eRuleNumber+ logAll $ "Error in rule " ++ show rn ++ " (triggered by event " ++ show en ++ "): " ++ s logPlayer :: PlayerNumber -> String -> Evaluate () logPlayer pn = log (Just pn)@@ -79,50 +44,63 @@ logAll = log Nothing log :: Maybe PlayerNumber -> String -> Evaluate ()-log mpn s = do+log mpn s = focusGame $ do time <- access currentTime void $ logs %= (Log mpn time s : ) -liftEval :: Reader Game a -> Evaluate a+liftEval :: EvaluateNE a -> Evaluate a liftEval r = runReader r <$> get ---remove the ErrorT layer from the Evaluate monad stack.-runEvalError :: Maybe PlayerNumber -> Evaluate a -> State Game ()-runEvalError pn egs = do+--extract the game state from an Evaluate+--knowing the rule number performing the evaluation (0 if by the system)+--and the player number to whom display errors (set to Nothing for all players)+--TODO: clean+runEvalError :: RuleNumber -> (Maybe PlayerNumber) -> Evaluate a -> State Game ()+runEvalError rn mpn egs = modify (\g -> _eGame $ execState (runEvalError' mpn egs) (EvalEnv rn g))++runEvalError' :: (Maybe PlayerNumber) -> Evaluate a -> State EvalEnv ()+runEvalError' mpn egs = do e <- runErrorT egs case e of Right _ -> return ()- Left e -> do- tracePN (fromMaybe 0 pn) $ "Error: " ++ e- void $ runErrorT $ log pn "Error: "+ Left e' -> do+ tracePN (fromMaybe 0 mpn) $ "Error: " ++ e'+ void $ runErrorT $ log mpn "Error: " --- Put an index on every input fields-indexInputs :: Event a -> Event a-indexInputs e = snd $ indexInputs' 0 e -indexInputs' :: Int -> Event a -> (Int, Event a)-indexInputs' n (BaseEvent (Input _ pn s ifo)) = (n+1, BaseEvent (Input (Just n) pn s ifo))-indexInputs' n (BaseEvent a) = (n, BaseEvent a)-indexInputs' n (PureEvent a) = (n, PureEvent a)-indexInputs' n EmptyEvent = (n, EmptyEvent)-indexInputs' n (SumEvent a b) = (n2, SumEvent e1 e2) where- (n1, e1) = indexInputs' n a- (n2, e2) = indexInputs' n1 b-indexInputs' n (AppEvent a b) = (n2, AppEvent e1 e2) where- (n1, e1) = indexInputs' n a- (n2, e2) = indexInputs' n1 b-indexInputs' n (ShortcutEvents as f) = (n1, ShortcutEvents bs f) where- (n1, bs) = mapAccumL indexInputs' n as+runEvaluateNE :: Game -> RuleNumber -> EvaluateNE a -> a+runEvaluateNE g rn ev = runReader ev (EvalEnv rn g) +runSystemEval :: PlayerNumber -> Evaluate a -> State Game ()+runSystemEval pn e = runEvalError 0 (Just pn) e +runSystemEval' :: Evaluate a -> State Game ()+runSystemEval' e = runEvalError 0 Nothing e++focusGame :: State Game a -> Evaluate a+focusGame = lift . (focus eGame)++accessGame :: Lens Game a -> Evaluate (a, PlayerNumber)+accessGame l = do+ a <- access (eGame >>> l)+ pn <- access eRuleNumber+ return (a, pn)++--replace temporarily the rule number used for evaluation+withRN :: RuleNumber -> Evaluate a -> Evaluate a+withRN rn eval = do+ oldRn <- gets _eRuleNumber+ eRuleNumber ~= rn+ a <- eval+ eRuleNumber ~= oldRn+ return a+ instance Eq SomeField where (SomeField e1) == (SomeField e2) = e1 === e2 - instance Show EventInfo where- show (EventInfo en rn e _ s env) =+ show (EventInfo en rn _ _ s env) = "event num: " ++ (show en) ++ ", rule num: " ++ (show rn) ++- ", event fields: " ++ (show $ getEventFields e env) ++ ", envs: " ++ (show env) ++ ", status: " ++ (show s)
src/Nomyx/Core/Engine/Evaluation.hs view
@@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE DoAndIfThenElse #-} -- | Evaluation of a Nomyx expression module Nomyx.Core.Engine.Evaluation where@@ -17,6 +18,8 @@ import Data.Time import Data.Lens import Data.Maybe+import Data.Todo+import Data.Either import Control.Category hiding (id) import Control.Applicative import Control.Monad.Error.Class (MonadError(..))@@ -29,82 +32,85 @@ -- | evaluate an effecful expression. -- The rule number passed is the number of the rule containing the expression.-evalNomex :: Nomex a -> RuleNumber -> Evaluate a-evalNomex (NewVar v a) rn = evNewVar v a rn-evalNomex (DelVar v) _ = evDelVar v-evalNomex (WriteVar v val) _ = evWriteVar v val-evalNomex (OnEvent ev h) rn = evOnEvent ev h rn-evalNomex (DelEvent en) _ = evDelEvent en-evalNomex (SendMessage m d) _ = evSendMessage m d-evalNomex (NewOutput pn s) rn = evNewOutput pn rn s-evalNomex (UpdateOutput on s) _ = evUpdateOutput on s-evalNomex (DelOutput on) _ = evDelOutput on-evalNomex (ProposeRule rule) _ = evProposeRule rule-evalNomex (ActivateRule rule) rn = evActivateRule rule rn-evalNomex (RejectRule rule) rn = evRejectRule rule rn-evalNomex (AddRule rule) _ = evAddRule rule-evalNomex (ModifyRule mod rule) _ = evModifyRule mod rule-evalNomex (SetPlayerName pn n) _ = evChangeName pn n-evalNomex (DelPlayer pn) _ = evDelPlayer pn-evalNomex (SetVictory ps) rn = evSetVictory ps rn-evalNomex (LiftEffect e) pn = liftEval $ evalNomexNE e pn-evalNomex (ThrowError s) _ = throwError s-evalNomex (CatchError n h) rn = catchError (evalNomex n rn) (\a -> evalNomex (h a) rn)-evalNomex (Return a) _ = return a-evalNomex (Bind exp f) rn = evalNomex exp rn >>= \e -> evalNomex (f e) rn+evalNomex :: Nomex a -> Evaluate a+evalNomex (NewVar v a) = evNewVar v a+evalNomex (DelVar v) = evDelVar v+evalNomex (WriteVar v val) = evWriteVar v val+evalNomex (OnEvent ev h) = evOnEvent ev h+evalNomex (DelEvent en) = evDelEvent en+evalNomex (SendMessage m d) = evSendMessage m d+evalNomex (NewOutput pn s) = evNewOutput pn s+evalNomex (UpdateOutput on s) = evUpdateOutput on s+evalNomex (DelOutput on) = evDelOutput on+evalNomex (ProposeRule rule) = evProposeRule rule+evalNomex (ActivateRule rule) = evActivateRule rule+evalNomex (RejectRule rule) = evRejectRule rule+evalNomex (AddRule rule) = evAddRule rule+evalNomex (ModifyRule mod rule) = evModifyRule mod rule+evalNomex (SetPlayerName pn n) = evChangeName pn n+evalNomex (DelPlayer pn) = evDelPlayer pn+evalNomex (SetVictory ps) = evSetVictory ps+evalNomex (LiftEffect e) = liftEval $ evalNomexNE e+evalNomex (ThrowError s) = throwError s+evalNomex (CatchError n h) = catchError (evalNomex n) (\a -> evalNomex (h a))+evalNomex (Return a) = return a+evalNomex (Bind exp f) = evalNomex exp >>= \e -> evalNomex (f e) -- | evaluate an effectless expression.-evalNomexNE :: NomexNE a -> RuleNumber -> Reader Game a-evalNomexNE (ReadVar v) _ = evReadVar v-evalNomexNE (GetOutput on) _ = evGetOutput on-evalNomexNE GetRules _ = asks _rules-evalNomexNE GetPlayers _ = asks _players-evalNomexNE GetEvents _ = asks _events-evalNomexNE SelfRuleNumber rn = return rn-evalNomexNE (CurrentTime) _ = asks _currentTime-evalNomexNE (Return a) _ = return a-evalNomexNE (Bind exp f) rn = evalNomexNE exp rn >>= \e -> evalNomexNE (f e) rn-evalNomexNE (Simu sim ev) rn = evSimu sim ev rn+evalNomexNE :: NomexNE a -> EvaluateNE a+evalNomexNE (ReadVar v) = evReadVar v+evalNomexNE (GetOutput on) = evGetOutput on+evalNomexNE GetRules = _rules <$> asks _eGame+evalNomexNE GetPlayers = _players <$> asks _eGame+evalNomexNE GetEvents = _events <$> asks _eGame+evalNomexNE SelfRuleNumber = asks _eRuleNumber+evalNomexNE (CurrentTime) = _currentTime <$> asks _eGame+evalNomexNE (Return a) = return a+evalNomexNE (Bind exp f) = evalNomexNE exp >>= \e -> evalNomexNE (f e)+evalNomexNE (Simu sim ev) = evSimu sim ev -evSimu :: Nomex a -> NomexNE Bool -> RuleNumber -> Reader Game Bool-evSimu sim ev rn = do- let s = runEvalError Nothing (evalNomex sim rn)- g <- ask+--TODO should we also give a rule number to simulate the Nomex with?+-- currently we use the simulating rule number+evSimu :: Nomex a -> NomexNE Bool -> EvaluateNE Bool+evSimu sim ev = do+ rn <- asks _eRuleNumber+ let s = runEvalError rn Nothing (evalNomex sim)+ g <- asks _eGame let g' = execState s g- return $ runReader (evalNomexNE ev rn) g'+ return $ runEvaluateNE g' rn (evalNomexNE ev) -evNewVar :: (Typeable a, Show a) => VarName -> a -> RuleNumber -> Evaluate (Maybe (V a))-evNewVar name def rn = do- vars <- access variables+evNewVar :: (Typeable a, Show a) => VarName -> a -> Evaluate (Maybe (V a))+evNewVar name def = do+ (vars, rn) <- accessGame variables case find ((== name) . getL vName) vars of Nothing -> do- variables %= (Var rn name def : )+ (eGame >>> variables) %= (Var rn name def : ) return $ Just (V name) Just _ -> return Nothing evDelVar :: (V a) -> Evaluate Bool evDelVar (V name) = do- vars <- access variables+ (vars, _) <- accessGame variables case find ((== name) . getL vName) vars of Nothing -> return False Just _ -> do- variables %= filter ((/= name) . getL vName)+ (eGame >>> variables) %= filter ((/= name) . getL vName) return True evWriteVar :: (Typeable a, Show a) => V a -> a -> Evaluate Bool-evWriteVar (V name) val = do- vars <- access variables+evWriteVar (V name) val = do+ (vars, _) <- accessGame variables case find (\(Var _ myName _) -> myName == name) vars of Nothing -> return False Just (Var rn myName _) -> do- variables %= replaceWith ((== name) . getL vName) (Var rn myName val)+ (eGame >>> variables) %= replaceWith ((== name) . getL vName) (Var rn myName val) return True -evOnEvent :: (Typeable e, Show e) => Event e -> ((EventNumber, e) -> Nomex ()) -> RuleNumber -> Evaluate EventNumber-evOnEvent event handler rn = do- evs <- access events+evOnEvent :: (Typeable e, Show e) => Event e -> ((EventNumber, e) -> Nomex ()) -> Evaluate EventNumber+evOnEvent event handler = do+ (evs, rn) <- accessGame events let en = getFreeNumber (map _eventNumber evs)- events %= (EventInfo en rn (indexInputs event) handler SActive [] : )+ (eGame >>> events) %= (EventInfo en rn event handler SActive [] : ) return en evSendMessage :: (Typeable a, Show a) => Msg a -> a -> Evaluate ()@@ -112,36 +118,36 @@ evProposeRule :: RuleInfo -> Evaluate Bool evProposeRule rule = do- rs <- access rules+ (rs, _) <- accessGame rules case find ((== (rNumber ^$ rule)) . getL rNumber) rs of Nothing -> do- rules %= (rule:)+ (eGame >>> rules) %= (rule:) triggerEvent (RuleEv Proposed) rule return True Just _ -> return False --Sets the rule status to Active and execute it if possible-evActivateRule :: RuleNumber -> RuleNumber -> Evaluate Bool-evActivateRule rn by = do- rs <- access rules+evActivateRule :: RuleNumber -> Evaluate Bool+evActivateRule rn = do+ (rs, by) <- accessGame rules case find (\r -> _rNumber r == rn && _rStatus r /= Active) rs of Nothing -> return False Just r -> do let newrules = replaceWith ((== rn) . getL rNumber) r{_rStatus = Active, _rAssessedBy = Just by} rs- rules ~= newrules+ (eGame >>> rules) ~= newrules --execute the rule- evalNomex (_rRule r) rn+ withRN (_rNumber r) $ evalNomex (_rRule r) triggerEvent (RuleEv Activated) r return True -evRejectRule :: RuleNumber -> RuleNumber -> Evaluate Bool-evRejectRule rn by = do- rs <- access rules+evRejectRule :: RuleNumber -> Evaluate Bool+evRejectRule rn = do+ (rs, by) <- accessGame rules case find (\r -> _rNumber r == rn && _rStatus r /= Reject) rs of Nothing -> return False Just r -> do let newrules = replaceWith ((== rn) . getL rNumber) r{_rStatus = Reject, _rAssessedBy = Just by} rs- rules ~= newrules+ (eGame >>> rules) ~= newrules triggerEvent (RuleEv Rejected) r delVarsRule rn delEventsRule rn@@ -150,109 +156,109 @@ evAddRule :: RuleInfo -> Evaluate Bool evAddRule rule = do- rs <- access rules+ (rs, _) <- accessGame rules case find ((== (rNumber ^$ rule)) . getL rNumber) rs of Nothing -> do- rules %= (rule:)+ (eGame >>> rules) %= (rule:) triggerEvent (RuleEv Added) rule return True Just _ -> return False - --TODO: clean and execute new rule evModifyRule :: RuleNumber -> RuleInfo -> Evaluate Bool-evModifyRule mod rule = do- rs <- access rules- let newRules = replaceWith ((== mod) . getL rNumber) rule rs- case find ((== mod) . getL rNumber) rs of+evModifyRule rn rule = do+ (rs, _) <- accessGame rules+ let newRules = replaceWith ((== rn) . getL rNumber) rule rs+ case find ((== rn) . getL rNumber) rs of Nothing -> return False Just r -> do- rules ~= newRules+ (eGame >>> rules) ~= newRules triggerEvent (RuleEv Modified) r return True evDelPlayer :: PlayerNumber -> Evaluate Bool evDelPlayer pn = do- g <- get+ g <- access eGame case find ((== pn) . getL playerNumber) (_players g) of Nothing -> do tracePN pn "not in game!" return False Just pi -> do- players %= filter ((/= pn) . getL playerNumber)+ (eGame >>> players) %= filter ((/= pn) . getL playerNumber) triggerEvent (Player Leave) pi tracePN pn $ "leaving the game: " ++ _gameName g return True evChangeName :: PlayerNumber -> PlayerName -> Evaluate Bool evChangeName pn name = do- pls <- access players+ pls <- access (eGame >>> players) case find ((== pn) . getL playerNumber) pls of Nothing -> return False Just pi -> do- players ~= replaceWith ((== pn) . getL playerNumber) (pi {_playerName = name}) pls+ (eGame >>> players) ~= replaceWith ((== pn) . getL playerNumber) (pi {_playerName = name}) pls return True evDelEvent :: EventNumber -> Evaluate Bool evDelEvent en = do- evs <- access events+ evs <- access (eGame >>> events) case find ((== en) . getL eventNumber) evs of Nothing -> return False Just eh -> case _evStatus eh of SActive -> do let newEvents = replaceWith ((== en) . getL eventNumber) eh{_evStatus = SDeleted} evs- events ~= newEvents+ (eGame >>> events) ~= newEvents return True SDeleted -> return False evTriggerTime :: UTCTime -> Evaluate () evTriggerTime t = triggerEvent (Time t) t -evNewOutput :: Maybe PlayerNumber -> RuleNumber -> NomexNE String -> Evaluate OutputNumber-evNewOutput pn rn s = do- ops <- access outputs+evNewOutput :: Maybe PlayerNumber -> NomexNE String -> Evaluate OutputNumber+evNewOutput pn s = do+ (ops, rn) <- accessGame outputs let on = getFreeNumber (map _outputNumber ops)- outputs %= (Output on rn pn s SActive : )+ (eGame >>> outputs) %= (Output on rn pn s SActive : ) return on -evGetOutput :: OutputNumber -> Reader Game (Maybe String)+evGetOutput :: OutputNumber -> EvaluateNE (Maybe String) evGetOutput on = do- ops <- asks _outputs+ ops <- _outputs <$> asks _eGame case find (\(Output myOn _ _ _ s) -> myOn == on && s == SActive) ops of Nothing -> return Nothing- Just (Output _ rn _ o _) -> do- out <- evalNomexNE o rn+ Just (Output _ _ _ o _) -> do+ out <- evalNomexNE o return $ Just out evUpdateOutput :: OutputNumber -> NomexNE String -> Evaluate Bool evUpdateOutput on s = do- ops <- access outputs+ (ops, _) <- accessGame outputs case find (\(Output myOn _ _ _ s) -> myOn == on && s == SActive) ops of Nothing -> return False Just (Output _ rn pn _ _) -> do- outputs %= replaceWith ((== on) . getL outputNumber) (Output on rn pn s SActive)+ (eGame >>> outputs) %= replaceWith ((== on) . getL outputNumber) (Output on rn pn s SActive) return True evDelOutput :: OutputNumber -> Evaluate Bool evDelOutput on = do- ops <- access outputs+ ops <- access (eGame >>> outputs) case find ((== on) . getL outputNumber) ops of Nothing -> return False Just o -> case _oStatus o of SActive -> do let newOutputs = replaceWith ((== on) . getL outputNumber) o{_oStatus = SDeleted} ops- outputs ~= newOutputs+ (eGame >>> outputs) ~= newOutputs return True SDeleted -> return False -evSetVictory :: NomexNE [PlayerNumber] -> RuleNumber -> Evaluate ()-evSetVictory ps rn = do- void $ victory ~= (Just $ VictoryCond rn ps)- triggerEvent Victory (VictoryCond rn ps)+evSetVictory :: NomexNE [PlayerNumber] -> Evaluate ()+evSetVictory ps = do+ rn <- access eRuleNumber+ void $ (eGame >>> victory) ~= (Just $ VictoryInfo rn ps)+ triggerEvent Victory (VictoryInfo rn ps) -evReadVar :: (Typeable a, Show a) => V a -> Reader Game (Maybe a)+evReadVar :: (Typeable a, Show a) => V a -> EvaluateNE (Maybe a) evReadVar (V name) = do- vars <- asks _variables+ vars <- _variables <$> asks _eGame let var = find ((== name) . getL vName) vars case var of Nothing -> return Nothing@@ -260,19 +266,81 @@ Just v -> return $ Just v Nothing -> return Nothing --- * Event triggers+-- * Events +--get the fields left to be completed in an event+getEventFields :: EventInfo -> Game -> [(FieldAddress, SomeField)]+getEventFields (EventInfo _ rn e _ _ env) g = case runEvaluateNE g rn $ getEventResult e env of+ Done _ -> []+ Todo a -> a++-- | Get the field at a certain address+getInput :: EventInfo -> FieldAddress -> Game -> Maybe SomeField+getInput ei fa g = runEvaluateNE g (_ruleNumber ei) (findField ei fa)++-- | Get the field at a certain address+--TODO: should we check that the field is not already completed?+findField :: EventInfo -> FieldAddress -> EvaluateNE (Maybe SomeField)+findField (EventInfo _ _ e _ _ er) addr = findField' addr e er++findField' :: FieldAddress -> Event e -> [FieldResult] -> EvaluateNE (Maybe SomeField)+findField' [] (BaseEvent f) _ = return $ Just $ SomeField f+findField' (SumL:as) (SumEvent e1 _) frs = findField' as e1 (filterPath SumL frs)+findField' (SumR:as) (SumEvent _ e2) frs = findField' as e2 (filterPath SumR frs)+findField' (AppL:as) (AppEvent e1 _) frs = findField' as e1 (filterPath AppL frs)+findField' (AppR:as) (AppEvent _ e2) frs = findField' as e2 (filterPath AppR frs)+findField' (BindL:as) (BindEvent e1 _) frs = findField' as e1 (filterPath BindL frs)+findField' ((Index i):as) (ShortcutEvents es _) frs = findField' as (es!!i) frs+findField' (BindR:as) (BindEvent e1 f) frs = do+ er <- getEventResult e1 (filterPath BindL frs)+ case er of+ Done e2 -> findField' as (f e2) (filterPath BindR frs)+ Todo _ -> return Nothing+findField' _ _ _ = error "findField: wrong field address"++filterPath :: FieldAddressElem -> [FieldResult] -> [FieldResult]+filterPath fa frs = mapMaybe f frs where+ f (FieldResult fe fr (Just (fa':fas))) | fa == fa' = Just $ FieldResult fe fr (Just fas)+ f _ = Nothing++-- compute the result of an event given an environment.+-- in the case the event cannot be computed because some fields results are pending, return that list instead.+getEventResult :: Event a -> [FieldResult] -> EvaluateNE (Todo (FieldAddress, SomeField) a)+getEventResult e frs = getEventResult' e frs []++getEventResult' :: Event a -> [FieldResult] -> FieldAddress -> EvaluateNE (Todo (FieldAddress, SomeField) a)+getEventResult' (PureEvent a) _ _ = return $ Done a+getEventResult' EmptyEvent _ _ = return $ Todo []+getEventResult' (SumEvent a b) ers fa = liftM2 (<|>) (getEventResult' a ers (fa ++ [SumL])) (getEventResult' b ers (fa ++ [SumR]))+getEventResult' (AppEvent f b) ers fa = liftM2 (<*>) (getEventResult' f ers (fa ++ [AppL])) (getEventResult' b ers (fa ++ [AppR]))+getEventResult' (LiftNomexNE a) _ _ = evalNomexNE a >>= return . Done+getEventResult' (BindEvent a f) ers fa = do+ er <- getEventResult' a ers (fa ++ [BindL])+ case er of+ Done a' -> getEventResult' (f a') ers (fa ++ [BindR])+ Todo bs -> return $ Todo bs++getEventResult' (BaseEvent a) ers fa = return $ case lookupField a fa ers of+ Just r -> Done r+ Nothing -> Todo [(fa, SomeField a)]++getEventResult' (ShortcutEvents es f) ers fa = do+ ers <- mapM (\i -> getEventResult' (es!!i) ers (fa ++ [Index i]) ) [0.. (length es -1)]+ case f (toMaybe <$> ers) of+ True -> return $ Done $ toMaybe <$> ers+ False -> return $ Todo $ join $ lefts $ toEither <$> ers+ -- trigger an event triggerEvent :: (Typeable e, Show e) => Field e -> e -> Evaluate () triggerEvent e dat = do- evs <- access events- triggerEvent' e dat evs+ evs <- access (eGame >>> events)+ triggerEvent' (FieldResult e dat Nothing) evs -- trigger some specific events-triggerEvent' :: (Typeable e, Show e) => Field e -> e -> [EventInfo] -> Evaluate ()-triggerEvent' e dat evs = do- let evs' = map (updateEventInfo e dat) evs- events %= union (map fst evs')+triggerEvent' :: FieldResult -> [EventInfo] -> Evaluate ()+triggerEvent' res evs = do+ evs' <- mapM (liftEval . (updateEventInfo res)) evs+ (eGame >>> events) %= union (map fst evs') mapM triggerIfComplete evs' return () @@ -282,65 +350,80 @@ case (cast val) of Just a -> do let exp = h (en, a)- (evalNomex exp rn) `catchError` (errorHandler rn en)+ withRN rn $ (evalNomex exp) `catchError` (errorHandler en)+ return () Nothing -> error "Bad trigger data type" triggerIfComplete _ = return () +-- update the EventInfo with the field result+updateEventInfo :: FieldResult -> EventInfo -> EvaluateNE (EventInfo, Maybe SomeData)+updateEventInfo (FieldResult field dat addr) ei@(EventInfo _ _ ev _ _ envi) = do+ g <- asks _eGame+ let eventRes = FieldResult field dat addr+ er <- getEventResult ev (eventRes : envi)+ if (SomeField field) `elem` (map snd $ getEventFields ei g) then do -- if the field if found among the remaining fields of the event+ case er of -- then check the event with that field result included+ Todo _ -> return $ (env ^= (eventRes : envi) $ ei, Nothing) -- some fields are left to complete: add ours in the environment+ Done a -> return $ (env ^= [] $ ei, Just $ SomeData a) -- the event is now complete: empty the environment and output the result+ else return $ (ei, Nothing) -- field not found: do nothin++ -- * input triggers -- trigger the input event with the input data-triggerInput :: EventNumber -> InputNumber -> InputData -> Evaluate ()-triggerInput en inn ir = do- evs <- access events+triggerInput :: EventNumber -> FieldAddress -> InputData -> Evaluate ()+triggerInput en fa ir = do+ evs <- access (eGame >>> events) let mei = find ((== en) . getL eventNumber) evs- when (isJust mei) $ execInputHandler ir inn (fromJust mei)+ when (isJust mei) $ execInputHandler ir fa (fromJust mei) -- execute the corresponding handler-execInputHandler :: InputData -> InputNumber -> EventInfo -> Evaluate ()-execInputHandler ir inn ei@(EventInfo _ _ _ _ SActive _) = do- case (getInput ei inn) of- Just sf -> execInputHandler' ir sf ei+execInputHandler :: InputData -> FieldAddress -> EventInfo -> Evaluate ()+execInputHandler ir fa ei@(EventInfo _ _ _ _ SActive _) = do+ i <- liftEval $ findField ei fa+ case i of+ Just sf -> execInputHandler' ir sf fa ei Nothing -> logAll "Input not found" execInputHandler _ _ _ = return () -- execute the event handler using the data received from user-execInputHandler' :: InputData -> SomeField -> EventInfo -> Evaluate ()-execInputHandler' (TextData s) (SomeField e@(Input _ _ _ (Text))) ei = triggerEvent' e s [ei]-execInputHandler' (TextAreaData s) (SomeField e@(Input _ _ _ (TextArea))) ei = triggerEvent' e s [ei]-execInputHandler' (ButtonData) (SomeField e@(Input _ _ _ (Button))) ei = triggerEvent' e () [ei]-execInputHandler' (RadioData i) (SomeField e@(Input _ _ _ (Radio cs))) ei = triggerEvent' e (fst $ cs!!i) [ei]-execInputHandler' (CheckboxData is) (SomeField e@(Input _ _ _ (Checkbox cs))) ei = triggerEvent' e (fst <$> cs `sel` is) [ei]-execInputHandler' _ _ _ = return ()+execInputHandler' :: InputData -> SomeField -> FieldAddress -> EventInfo -> Evaluate ()+execInputHandler' (TextData s) (SomeField e@(Input _ _ (Text))) fa ei = triggerEvent' (FieldResult e s (Just fa)) [ei]+execInputHandler' (TextAreaData s) (SomeField e@(Input _ _ (TextArea))) fa ei = triggerEvent' (FieldResult e s (Just fa)) [ei]+execInputHandler' (ButtonData) (SomeField e@(Input _ _ (Button))) fa ei = triggerEvent' (FieldResult e () (Just fa)) [ei]+execInputHandler' (RadioData i) (SomeField e@(Input _ _ (Radio cs))) fa ei = triggerEvent' (FieldResult e (fst $ cs!!i) (Just fa)) [ei]+execInputHandler' (CheckboxData is) (SomeField e@(Input _ _ (Checkbox cs))) fa ei = triggerEvent' (FieldResult e (fst <$> cs `sel` is) (Just fa)) [ei]+execInputHandler' _ _ _ _ = return () -- * misc getVictorious :: Game -> [PlayerNumber] getVictorious g = case _victory g of Nothing -> []- Just (VictoryCond rn v) -> runReader (evalNomexNE v rn) g+ Just (VictoryInfo rn v) -> runEvaluateNE g rn (evalNomexNE v) evalOutput :: Game -> Output -> String-evalOutput g (Output _ rn _ o _) = runReader (evalNomexNE o rn) g+evalOutput g (Output _ rn _ o _) = runEvaluateNE g rn (evalNomexNE o) allOutputs :: Game -> [String] allOutputs g = map (evalOutput g) (_outputs g) --delete all variables of a rule delVarsRule :: RuleNumber -> Evaluate ()-delVarsRule rn = void $ variables %= filter ((/= rn) . getL vRuleNumber)+delVarsRule rn = void $ (eGame >>> variables) %= filter ((/= rn) . getL vRuleNumber) --delete all events of a rule delEventsRule :: RuleNumber -> Evaluate () delEventsRule rn = do- evs <- access events+ evs <- access (eGame >>> events) let toDelete = filter ((== rn) . getL ruleNumber) evs mapM_ (evDelEvent . _eventNumber) toDelete --delete all outputs of a rule delOutputsRule :: RuleNumber -> Evaluate () delOutputsRule rn = do- os <- access outputs+ os <- access (eGame >>> outputs) let toDelete = filter ((== rn) . getL oRuleNumber) os mapM_ (evDelOutput . _outputNumber) toDelete @@ -348,14 +431,23 @@ -- | Show instance for Game -- showing a game involves evaluating some parts (such as victory and outputs) instance Show Game where- show g@(Game { _gameName, _rules, _players, _variables, _events, _victory, _currentTime}) =- "Game Name = " ++ show _gameName ++- "\n Rules = " ++ (intercalate "\n " $ map show _rules) ++- "\n Players = " ++ show _players ++- "\n Variables = " ++ show _variables ++- "\n Events = " ++ (intercalate "\n " $ map show _events) +++ show g@(Game gn _ rs ps vs es _ _ _ t) =+ "Game Name = " ++ show gn +++ "\n Rules = " ++ (intercalate "\n " $ map show rs) +++ "\n Players = " ++ show ps +++ "\n Variables = " ++ show vs +++ "\n Events = " ++ (intercalate "\n " $ map (displayEvent g) es) ++ "\n Outputs = " ++ show (allOutputs g) ++ "\n Victory = " ++ show (getVictorious g) ++- "\n currentTime = " ++ show _currentTime ++ "\n"+ "\n currentTime = " ++ show t ++ "\n"+++displayEvent :: Game -> EventInfo -> String+displayEvent g ei@(EventInfo en rn _ _ s env) =+ "event num: " ++ (show en) +++ ", rule num: " ++ (show rn) +++ ", event fields: " ++ (show $ getEventFields ei g) +++ ", envs: " ++ (show env) +++ ", status: " ++ (show s)
src/Nomyx/Core/Engine/GameEvents.hs view
@@ -24,7 +24,7 @@ | JoinGame PlayerNumber PlayerName | LeaveGame PlayerNumber | ProposeRuleEv PlayerNumber SubmitRule- | InputResult PlayerNumber EventNumber InputNumber InputData+ | InputResult PlayerNumber EventNumber FieldAddress InputData | GLog (Maybe PlayerNumber) String | TimeEvent UTCTime | SystemAddRule SubmitRule@@ -51,9 +51,9 @@ 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 inn ir) _ = mapStateIO $ inputResult pn en inn ir+enactEvent (InputResult pn en fa ir) _ = mapStateIO $ inputResult pn en fa ir enactEvent (GLog mpn s) _ = mapStateIO $ logGame s mpn-enactEvent (TimeEvent t) _ = mapStateIO $ runEvalError Nothing $ evTriggerTime t+enactEvent (TimeEvent t) _ = mapStateIO $ runSystemEval' $ 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"@@ -105,18 +105,18 @@ tracePN pn $ "Joining game: " ++ _gameName g let player = PlayerInfo { _playerNumber = pn, _playerName = name, _playAs = Nothing} players %= (player : )- runEvalError (Just pn) $ triggerEvent (Player Arrive) player+ runSystemEval pn $ triggerEvent (Player Arrive) player -- | leave the game. leaveGame :: PlayerNumber -> State Game ()-leaveGame pn = runEvalError (Just pn) $ void $ evDelPlayer pn+leaveGame pn = runSystemEval pn $ void $ evDelPlayer pn -- | insert a rule in pending rules. proposeRule :: SubmitRule -> PlayerNumber -> (RuleCode -> IO Rule) -> StateT Game IO () proposeRule sr pn inter = do rule <- createRule sr pn inter- mapStateIO $ runEvalError (Just pn) $ do+ mapStateIO $ runEvalError (_rNumber rule) (Just pn) $ do r <- evProposeRule rule tracePN pn $ if r then "Your rule has been added to pending rules." else "Error: Rule could not be proposed"@@ -127,7 +127,7 @@ rule <- createRule sr 0 inter let sysRule = (rStatus ^= Active) >>> (rAssessedBy ^= Just 0) rules %= (sysRule rule : )- mapStateIO $ runEvalError (Just 0) $ void $ evalNomex (_rRule rule) (_rNumber rule)+ mapStateIO $ runEvalError (_rNumber rule) Nothing $ evalNomex (_rRule rule) -- | insert a log message. logGame :: String -> Maybe PlayerNumber -> State Game ()@@ -136,15 +136,17 @@ void $ logs %= (Log mpn time s : ) -- | the user has provided an input result--- TODO: this is relying on the EventNumber, which may change at all time-inputResult :: PlayerNumber -> EventNumber -> InputNumber -> InputData -> State Game ()-inputResult pn en inn ir = do- tracePN pn $ "input result: EventNumber " ++ show en ++ ", InputNumber " ++ show inn ++ ", choice " ++ show ir- runEvalError (Just pn) $ triggerInput en inn ir+inputResult :: PlayerNumber -> EventNumber -> FieldAddress -> InputData -> State Game ()+inputResult pn en fa ir = do+ tracePN pn $ "input result: EventNumber " ++ show en ++ ", FieldAddress " ++ show fa ++ ", choice " ++ show ir+ runSystemEval pn $ triggerInput en fa ir -getTimes :: EventInfo -> [UTCTime]-getTimes (EventInfo _ _ es _ SActive esr) = mapMaybe getTime (getEventFields es esr)-getTimes _ = []+getGameTimes :: Game -> [UTCTime]+getGameTimes g = concatMap (\ei -> getTimes ei g) (_events g)++getTimes :: EventInfo -> Game -> [UTCTime]+getTimes ei g = mapMaybe getTime (map snd $ getEventFields ei g)+ getTime :: SomeField -> Maybe UTCTime getTime (SomeField (Time t)) = Just t
src/Nomyx/Core/Engine/Test.hs view
@@ -22,6 +22,8 @@ import Data.Function hiding ((.)) import Data.Maybe import Control.Applicative+import Control.Category hiding ((.))+import Control.Shortcut date1 = parse822Time "Tue, 02 Sep 1997 09:00:00 -0400" date2 = parse822Time "Tue, 02 Sep 1997 10:00:00 -0400"@@ -48,19 +50,22 @@ _rAssessedBy = Nothing} execRuleEvent :: (Show e, Typeable e) => Nomex a -> Field e -> e -> Game-execRuleEvent r f d = execState (runEvalError Nothing $ evalNomex r 0 >> triggerEvent f d) testGame+execRuleEvent r f d = execState (runSystemEval' $ evalNomex r >> triggerEvent f d) testGame execRuleEvents :: (Show e, Typeable e) => Nomex a -> [(Field e, e)] -> Game-execRuleEvents f eds = execState (runEvalError Nothing $ evalNomex f 0 >> mapM (\(a,b) -> triggerEvent a b) eds) testGame+execRuleEvents f eds = execState (runSystemEval' $ evalNomex f >> mapM (\(a,b) -> triggerEvent a b) eds) testGame -execRuleInput :: Nomex a -> EventNumber -> InputNumber -> InputData -> Game-execRuleInput r en inn d = execState (runEvalError Nothing $ evalNomex r 0 >> triggerInput en inn d) testGame+execRuleInput :: Nomex a -> EventNumber -> FieldAddress -> InputData -> Game+execRuleInput r en fa d = execState (runSystemEval' $ evalNomex r >> triggerInput en fa d) testGame +execRuleInputs :: Nomex a -> EventNumber -> [(FieldAddress, InputData)] -> Game+execRuleInputs r en fads = execState (runSystemEval' $ evalNomex r >> mapM (\(fa, d) -> triggerInput en fa d) fads) testGame+ execRuleGame :: Nomex a -> Game -> Game-execRuleGame r g = execState (runEvalError Nothing $ void $ evalNomex r 0) g+execRuleGame r g = execState (runSystemEval' $ void $ evalNomex r) g execRuleEventGame :: (Show e, Typeable e) => Nomex a -> Field e -> e -> Game -> Game-execRuleEventGame r f d g = execState (runEvalError Nothing $ evalNomex r 0 >> (triggerEvent f d)) g+execRuleEventGame r f d g = execState (runSystemEval' $ evalNomex r >> (triggerEvent f d)) g execRule :: Nomex a -> Game execRule r = execRuleGame r testGame@@ -69,7 +74,7 @@ addActivateRule rf rn = do let rule = testRule {_rName = "testRule", _rRule = rf, _rNumber = rn, _rStatus = Pending} evAddRule rule- evActivateRule (_rNumber rule) 0+ evActivateRule (_rNumber rule) return () tests = [("test var 1", testVarEx1),@@ -107,7 +112,9 @@ ("test composed event sum", testSumComposeEx), ("test composed event prod 1", testProdComposeEx1), ("test composed event prod 2", testProdComposeEx2),- ("test two separate events", testTwoEventsEx)+ ("test two separate events", testTwoEventsEx),+ ("test monadic event", testMonadicEventEx),+ ("test shortcut event", testShorcutEventEx) ] allTests = all snd tests@@ -172,21 +179,21 @@ h a = void $ newOutput (Just 1) (return $ "voted for " ++ show a) testSingleInputEx = isOutput "voted for Holland" g where- g = execRuleEvent testSingleInput (Input (Just 0) 1 "Vote for Holland or Sarkozy" (Radio [(Holland, "Holland"), (Sarkozy, "Sarkozy")])) Holland+ g = execRuleEvent testSingleInput (Input 1 "Vote for Holland or Sarkozy" (Radio [(Holland, "Holland"), (Sarkozy, "Sarkozy")])) Holland testMultipleInputs :: Rule testMultipleInputs = void $ onInputCheckbox_ "Vote for Holland and Sarkozy" [(Holland, "Holland"), (Sarkozy, "Sarkozy")] h 1 where h a = void $ newOutput (Just 1) (return $ "voted for " ++ show a) testMultipleInputsEx = isOutput "voted for [Holland,Sarkozy]" g where- g = execRuleEvent testMultipleInputs (Input (Just 0) 1 "Vote for Holland and Sarkozy" (Checkbox [(Holland, "Holland"), (Sarkozy, "Sarkozy")])) [Holland, Sarkozy]+ g = execRuleEvent testMultipleInputs (Input 1 "Vote for Holland and Sarkozy" (Checkbox [(Holland, "Holland"), (Sarkozy, "Sarkozy")])) [Holland, Sarkozy] testInputString :: Rule testInputString = void $ onInputText_ "Enter a number:" h 1 where h a = void $ newOutput (Just 1) (return $ "You entered: " ++ a) testInputStringEx = isOutput "You entered: 1" g where- g = execRuleEvent testInputString (Input (Just 0) 1 "Enter a number:" Text) "1"+ g = execRuleEvent testInputString (Input 1 "Enter a number:" Text) "1" -- Test message testSendMessage :: Rule@@ -213,7 +220,7 @@ testUserInputWrite = do newVar_ "vote" (Nothing::Maybe Choice2) onEvent_ (messageEvent (Msg "voted" :: Msg ())) h2- void $ onEvent_ (BaseEvent $ Input Nothing 1 "Vote for" (Radio [(Me, "Me"), (You, "You")])) h1 where+ void $ onEvent_ (BaseEvent $ Input 1 "Vote for" (Radio [(Me, "Me"), (You, "You")])) h1 where h1 a = do writeVar (V "vote") (Just a) SendMessage (Msg "voted") ()@@ -225,7 +232,7 @@ testUserInputWriteEx = isOutput "voted Me" g where- g = execRuleEvent testUserInputWrite (Input (Just 0) 1 "Vote for" (Radio [(Me, "Me"), (You, "You")])) Me+ g = execRuleEvent testUserInputWrite (Input 1 "Vote for" (Radio [(Me, "Me"), (You, "You")])) Me -- Test rule activation testActivateRule :: Rule@@ -251,7 +258,7 @@ testTimeEvent2 = schedule' [date1, date2] (outputAll_ . show) testTimeEventEx2 = isOutput (show date1) g && isOutput (show date2) g where- g = execState (runEvalError Nothing $ evalNomex testTimeEvent2 0 >> void gameEvs) testGame+ g = execState (runSystemEval' $ evalNomex testTimeEvent2 >> void gameEvs) testGame gameEvs = do evTriggerTime date1 evTriggerTime date2@@ -264,7 +271,7 @@ void $ newOutput (Just 1) (return "toto") testDeleteGame :: Game-testDeleteGame = flip execState testGame {_players = []} $ runEvalError Nothing $ do+testDeleteGame = flip execState testGame {_players = []} $ runSystemEval 1 $ do addActivateRule testDeleteRule 1 addActivateRule (void $ suppressRule 1) 2 @@ -275,7 +282,7 @@ -- Test victory testVictoryGame :: Game-testVictoryGame = flip execState testGame $ runEvalError Nothing $ do+testVictoryGame = flip execState testGame $ runSystemEval' $ do addActivateRule (victoryXRules 1) 1 addActivateRule (nothing) 2 @@ -284,15 +291,15 @@ -- Test votes voteGameActions :: Int -> Int -> Int -> Bool -> Evaluate () -> Game-voteGameActions positives negatives total timeEvent actions = flip execState testGame {_players = []} $ runEvalError Nothing $ do+voteGameActions positives negatives total timeEvent actions = flip execState testGame {_players = []} $ runSystemEval' $ do mapM_ (\x -> addPlayer (PlayerInfo x ("coco " ++ show x) Nothing)) [1..total] actions evProposeRule testRule evs <- lift getChoiceEvents let pos = take positives evs let neg = take negatives $ drop positives evs- mapM_ (\(en, inum) -> triggerInput en inum (RadioData 0)) pos --issuing positive votes- mapM_ (\(en, inum) -> triggerInput en inum (RadioData 1)) neg --issuing negative votes+ mapM_ (\(en, fa) -> triggerInput en fa (RadioData 0)) pos --issuing positive votes+ mapM_ (\(en, fa) -> triggerInput en fa (RadioData 1)) neg --issuing negative votes when timeEvent $ evTriggerTime date2 voteGame' :: Int -> Int -> Int -> Bool -> Rule -> Game@@ -317,29 +324,30 @@ testVoteAssessOnTimeLimit1 = testVoteRule Active $ voteGameTimed 10 0 10 $ onRuleProposed $ (callVoteRule' unanimity date2) testVoteAssessOnTimeLimit2 = testVoteRule Active $ voteGameTimed 1 0 10 $ onRuleProposed $ (callVoteRule' unanimity date2) testVoteAssessOnTimeLimit3 = testVoteRule Reject $ voteGameTimed 1 0 10 $ onRuleProposed $ (callVoteRule' (unanimity `withQuorum` 5) date2)-testVoteAssessOnTimeLimit4 = testVoteRule Reject $ voteGameTimed 0 0 10 $ onRuleProposed $ (callVoteRule' (unanimity `withQuorum` 1) date2)-testVoteAssessOnTimeLimit5 = testVoteRule Active $ voteGameTimed 1 0 10 $ onRuleProposed $ (callVoteRule' (unanimity `withQuorum` 1) date2)+testVoteAssessOnTimeLimit4 = testVoteRule Reject $ voteGameTimed 0 0 10 $ onRuleProposed $ (callVoteRule' (unanimity `withQuorum` 1) date2)+testVoteAssessOnTimeLimit5 = testVoteRule Active $ voteGameTimed 1 0 10 $ onRuleProposed $ (callVoteRule' (unanimity `withQuorum` 1) date2) testVoteRule s g = (_rStatus $ head $ _rules g) == s -- Event composition testSumCompose :: Rule-testSumCompose = void $ onEvent_ (True <$ inputButton 1 "" <|> False <$ inputButton 1 "") f where+testSumCompose = void $ onEvent_ (True <$ inputButton 1 "click here:" <|> False <$ inputButton 2 "") f where f a = outputAll_ $ show a testSumComposeEx = isOutput "True" g where- g = execRuleEvent testSumCompose (Input (Just 0) 1 "" Button) ()+ g = execRuleInput testSumCompose 1 [SumL, AppR] ButtonData + testProdCompose :: Rule testProdCompose = void $ onEvent_ ((,) <$> inputText 1 "" <*> inputText 1 "") f where f a = outputAll_ $ show a testProdComposeEx1 = null $ allOutputs g where- g = execRuleEvent testProdCompose (Input (Just 0) 1 "" Text) "toto"+ g = execRuleInput testProdCompose 1 [AppR] (TextData "toto") testProdComposeEx2 = isOutput "(\"toto\",\"tata\")" g where- g = execRuleEvents testProdCompose [((Input (Just 0) 1 "" Text), "toto"), ((Input (Just 1) 1 "" Text), "tata")]+ g = execRuleInputs testProdCompose 1 [([AppL, AppR], TextData "toto"), ([AppR], TextData "tata")] testTwoEvents :: Rule testTwoEvents = do@@ -348,37 +356,63 @@ f a = outputAll_ $ show a testTwoEventsEx = (length $ allOutputs g) == 1 where- g = execRuleInput testTwoEvents 1 0 (TextData "toto")+ g = execRuleInput testTwoEvents 1 [] (TextData "toto") +testMonadicEvent :: Rule+testMonadicEvent = do+ let displayMsg a = void $ newOutput_ Nothing a+ let e = do+ a <- inputText 1 ""+ guard (a == "coco1") >> inputText 1 ""+ void $ onEvent_ e displayMsg +testMonadicEventEx = isOutput "coco2" g where+ g = execRuleInputs testMonadicEvent 1 [([BindL], TextData "coco1"), ([BindR, BindR], TextData "coco2")]++testShorcutEvent :: Rule+testShorcutEvent = do+ let displayMsg a = void $ newOutput_ Nothing (concat $ catMaybes a)+ let e = do+ let a = inputText 1 ""+ shortcut [a,a] (\as -> length (filter isJust as) == 1)+ void $ onEvent_ e displayMsg++testShorcutEventEx = isOutput "coco1" g where+ g = execRuleInputs testShorcutEvent 1 [([Index 0], TextData "coco1")]++ --Get all event numbers of type choice (radio button)-getChoiceEvents :: State Game [(EventNumber, InputNumber)]+getChoiceEvents :: State EvalEnv [(EventNumber, FieldAddress)] getChoiceEvents = do- evs <- access events- return $ [(_eventNumber ev, inum) | ev <- evs, inum <- getInputChoices ev ]+ evs <- access (eGame >>> events)+ g <- access eGame+ return $ [(_eventNumber ev, inum) | ev <- evs, inum <- getInputChoices ev g] -getInputChoices :: EventInfo -> [InputNumber]-getInputChoices (EventInfo _ _ ev _ _ env) = mapMaybe isInput (getEventFields ev env) where- isInput (SomeField (Input (Just inum) _ _ (Radio _))) = Just inum- isInput _ = Nothing+getInputChoices :: EventInfo -> Game -> [FieldAddress]+getInputChoices ei g = mapMaybe isInput (getEventFields ei g) where+ isInput :: (t, SomeField) -> Maybe t+ isInput (fa, (SomeField (Input _ _ (Radio _)))) = Just fa+ isInput _ = Nothing --Get all event numbers of type text (text field)-getTextEvents :: State Game [(EventNumber, InputNumber)]+getTextEvents :: State Game [(EventNumber, FieldAddress)] getTextEvents = do evs <- access events- return $ [(_eventNumber ev, inum) | ev <- evs, inum <- getInputTexts ev ]+ g <- get+ return $ [(_eventNumber ev, fa) | ev <- evs, fa <- getInputTexts ev g] -getInputTexts :: EventInfo -> [InputNumber]-getInputTexts (EventInfo _ _ ev _ _ env) = mapMaybe isInput (getEventFields ev env) where- isInput (SomeField (Input (Just inum) _ _ Text)) = Just inum- isInput _ = Nothing+getInputTexts :: EventInfo -> Game -> [FieldAddress]+getInputTexts ei g = mapMaybe isInput (getEventFields ei g) where+ isInput :: (t, SomeField) -> Maybe t+ isInput (fa, (SomeField (Input _ _ Text))) = Just fa+ isInput _ = Nothing addPlayer :: PlayerInfo -> Evaluate Bool addPlayer pi = do- pls <- access players+ pls <- access (eGame >>> players) let exists = any (((==) `on` _playerNumber) pi) pls unless exists $ do- players %= (pi:)+ (eGame >>> players) %= (pi:) triggerEvent (Player Arrive) pi return $ not exists
src/Nomyx/Core/Engine/Types.hs view
@@ -16,7 +16,18 @@ import Data.Data import Control.Monad.Error (ErrorT(..)) import Control.Monad.State+import Control.Monad.Reader +-- * Evaluation++--TODO: should the first field be a "Maybe RuleNumber"?+--Indeed an evaluation is not always performed by a rule but also by the system (in which case we currently use rule number 0)+data EvalEnv = EvalEnv { _eRuleNumber :: RuleNumber, -- number of the rule requesting the evaluation+ _eGame :: Game} -- game to be read/modified++type Evaluate a = ErrorT String (State EvalEnv) a+type EvaluateNE a = Reader EvalEnv a+ -- * Game type GameName = String@@ -29,7 +40,7 @@ _variables :: [Var], _events :: [EventInfo], _outputs :: [Output],- _victory :: Maybe VictoryCond,+ _victory :: Maybe VictoryInfo, _logs :: [Log], _currentTime :: UTCTime} deriving (Typeable)@@ -68,8 +79,6 @@ -- * Events -type Evaluate a = ErrorT String (State Game) a- -- data sent back by the forms data InputData = RadioData Int | CheckboxData [Int]@@ -78,8 +87,6 @@ | ButtonData deriving (Show, Read, Eq, Ord) -data SomeData = forall e. (Typeable e, Show e) => SomeData e-deriving instance Show SomeData -- * Outputs @@ -102,7 +109,7 @@ data SubmitRule = SubmitRule RuleName RuleDesc RuleCode deriving (Show, Read, Eq, Ord, Data, Typeable) -$( makeLenses [''Game, ''GameDesc, ''Var, ''Output] )+$( makeLenses [''Game, ''GameDesc, ''Var, ''Output, ''EvalEnv] )
src/Nomyx/Core/Multi.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-} -- | This module manages multi-player games. module Nomyx.Core.Multi where@@ -37,9 +38,9 @@ -- | get all events that has not been triggered yet getTimeEvents :: UTCTime -> Multi -> IO [UTCTime] getTimeEvents now m = do- let eventInfos = concatMap (getL $ loggedGame >>> game >>> events) $ _gameInfos m- let times = concatMap getTimes eventInfos- return $ filter (\t -> t <= now && t > (-2) `addUTCTime` now) times+ let games = map (_game . _loggedGame) (_gameInfos m)+ let times = concatMap getGameTimes games+ return $ filter (\t -> t <= now && t > (-2) `addUTCTime` now) times -- | the initial rule set for a game. rVoteUnanimity = SubmitRule "Unanimity Vote"
src/Nomyx/Core/Profile.hs view
@@ -80,7 +80,6 @@ askProfileDataNumber :: Query ProfileDataState Int askProfileDataNumber = do pds <- ask- tracePN 1 (show $ profilesData pds) return $ IxSet.size $ profilesData pds -- | get all profiles
src/Nomyx/Core/Serialize.hs view
@@ -78,6 +78,7 @@ $(deriveJSON defaultOptions ''LoggedGame) $(deriveJSON defaultOptions ''GameInfo) $(deriveJSON defaultOptions ''TimedEvent)+$(deriveJSON defaultOptions ''FieldAddressElem) $(deriveJSON defaultOptions ''GameEvent) $(deriveJSON defaultOptions ''InputData) $(deriveJSON defaultOptions ''SubmitRule)
src/Nomyx/Core/Session.hs view
@@ -119,8 +119,8 @@ tracePN pn ("Error in submitted rule: " ++ errorMsg) modifyProfile pn (pLastRule ^= Just (sr, errorMsg)) -inputResult :: PlayerNumber -> EventNumber -> InputNumber -> InputData -> GameName -> StateT Session IO ()-inputResult pn en inn ir gn = inGameDo gn $ execGameEvent $ InputResult pn en inn ir+inputResult :: PlayerNumber -> EventNumber -> FieldAddress -> InputData -> GameName -> StateT Session IO ()+inputResult pn en fa ir gn = inGameDo gn $ execGameEvent $ InputResult pn en fa ir -- | upload a rule file, given a player number, the full path of the file, the file name and the server handle inputUpload :: PlayerNumber -> FilePath -> FilePath -> ServerHandle -> StateT Session IO Bool@@ -223,7 +223,7 @@ Just s -> do atomically $ writeTVar ts s save $ _multi s- Nothing -> putStrLn "thread timed out, updateSession discarded"+ Nothing -> putStrLn "thread timed out, session discarded" evalSession :: StateT Session IO () -> Session -> IO Session
src/Nomyx/Core/Test.hs view
@@ -45,6 +45,7 @@ import Nomyx.Core.Profile import Nomyx.Core.Quotes import Nomyx.Core.Engine+import Nomyx.Core.Engine.Types import qualified Nomyx.Core.Engine as G playTests :: FilePath -> ServerHandle -> Maybe String -> IO [(String, Bool)]@@ -96,7 +97,7 @@ case ms of Just s' -> return $ _multi s' Nothing -> do- putStrLn "thread timed out, updateSession discarded"+ putStrLn "thread timed out, session discarded" return $ _multi s testException :: Multi -> SomeException -> IO Multi@@ -315,7 +316,7 @@ inputAllRadios :: Int -> PlayerNumber -> StateT Session IO () inputAllRadios choice pn = do s <- get- let evs = evalState getChoiceEvents (firstGame $ _multi s)+ let evs = evalState getChoiceEvents (EvalEnv 0 (firstGame $ _multi s)) mapM_ (\(en, inum) -> inputResult pn en inum (RadioData choice) "test") evs -- input text for all text fields@@ -323,7 +324,7 @@ inputAllTexts a pn = do s <- get let evs = evalState getTextEvents (firstGame $ _multi s)- mapM_ (\(en, inum) -> inputResult pn en inum (TextData a) "test") evs+ mapM_ (\(en, fa) -> inputResult pn en fa (TextData a) "test") evs firstGame :: Multi -> Game firstGame = G._game . _loggedGame . head . _gameInfos