diff --git a/Nomyx-Core.cabal b/Nomyx-Core.cabal --- a/Nomyx-Core.cabal +++ b/Nomyx-Core.cabal @@ -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 diff --git a/src/Data/Todo.hs b/src/Data/Todo.hs --- a/src/Data/Todo.hs +++ b/src/Data/Todo.hs @@ -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 diff --git a/src/Nomyx/Core/Context.hs b/src/Nomyx/Core/Context.hs --- a/src/Nomyx/Core/Context.hs +++ b/src/Nomyx/Core/Context.hs @@ -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", diff --git a/src/Nomyx/Core/Engine.hs b/src/Nomyx/Core/Engine.hs --- a/src/Nomyx/Core/Engine.hs +++ b/src/Nomyx/Core/Engine.hs @@ -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 diff --git a/src/Nomyx/Core/Engine/EvalUtils.hs b/src/Nomyx/Core/Engine/EvalUtils.hs --- a/src/Nomyx/Core/Engine/EvalUtils.hs +++ b/src/Nomyx/Core/Engine/EvalUtils.hs @@ -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) diff --git a/src/Nomyx/Core/Engine/Evaluation.hs b/src/Nomyx/Core/Engine/Evaluation.hs --- a/src/Nomyx/Core/Engine/Evaluation.hs +++ b/src/Nomyx/Core/Engine/Evaluation.hs @@ -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) diff --git a/src/Nomyx/Core/Engine/GameEvents.hs b/src/Nomyx/Core/Engine/GameEvents.hs --- a/src/Nomyx/Core/Engine/GameEvents.hs +++ b/src/Nomyx/Core/Engine/GameEvents.hs @@ -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 diff --git a/src/Nomyx/Core/Engine/Test.hs b/src/Nomyx/Core/Engine/Test.hs --- a/src/Nomyx/Core/Engine/Test.hs +++ b/src/Nomyx/Core/Engine/Test.hs @@ -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 diff --git a/src/Nomyx/Core/Engine/Types.hs b/src/Nomyx/Core/Engine/Types.hs --- a/src/Nomyx/Core/Engine/Types.hs +++ b/src/Nomyx/Core/Engine/Types.hs @@ -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] ) diff --git a/src/Nomyx/Core/Multi.hs b/src/Nomyx/Core/Multi.hs --- a/src/Nomyx/Core/Multi.hs +++ b/src/Nomyx/Core/Multi.hs @@ -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" diff --git a/src/Nomyx/Core/Profile.hs b/src/Nomyx/Core/Profile.hs --- a/src/Nomyx/Core/Profile.hs +++ b/src/Nomyx/Core/Profile.hs @@ -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 diff --git a/src/Nomyx/Core/Serialize.hs b/src/Nomyx/Core/Serialize.hs --- a/src/Nomyx/Core/Serialize.hs +++ b/src/Nomyx/Core/Serialize.hs @@ -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) diff --git a/src/Nomyx/Core/Session.hs b/src/Nomyx/Core/Session.hs --- a/src/Nomyx/Core/Session.hs +++ b/src/Nomyx/Core/Session.hs @@ -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 diff --git a/src/Nomyx/Core/Test.hs b/src/Nomyx/Core/Test.hs --- a/src/Nomyx/Core/Test.hs +++ b/src/Nomyx/Core/Test.hs @@ -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