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.1 +version: 0.6.2 cabal-version: >=1.6 build-type: Simple license: BSD3 @@ -15,7 +15,7 @@ data-dir: data library - build-depends: Nomyx-Language == 0.6.1, + build-depends: Nomyx-Language == 0.6.2, DebugTraceHelpers == 0.12.*, MissingH == 1.2.*, acid-state == 0.12.*, @@ -71,11 +71,13 @@ Nomyx.Core.Test Nomyx.Core.Engine Nomyx.Core.Engine.Evaluation - Nomyx.Core.Engine.Game + Nomyx.Core.Engine.EvalUtils + Nomyx.Core.Engine.Types Nomyx.Core.Engine.GameEvents Nomyx.Core.Engine.Test Nomyx.Core.Engine.Utils Paths_Nomyx_Core + Data.Todo ghc-options: -W -threaded source-repository head diff --git a/src/Data/Todo.hs b/src/Data/Todo.hs new file mode 100644 --- /dev/null +++ b/src/Data/Todo.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +module Data.Todo where + +import Control.Applicative +import Data.Typeable + +data Todo a b = Todo [a] | Done b + deriving (Eq, Ord, Read, Show, Typeable) + +instance Alternative (Todo a) where + empty = Todo [] + Todo a <|> Todo b = Todo $ a ++ b + 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 + +instance Functor (Todo a) where + fmap _ (Todo x) = Todo x + fmap f (Done y) = Done $ f y + +toEither :: Todo a b -> Either [a] b +toEither (Todo as) = Left as +toEither (Done a) = Right a + +fromEither :: Either [a] b -> Todo a b +fromEither (Left as) = Todo as +fromEither (Right a) = Done a + + 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 @@ -27,9 +27,6 @@ activeRules, pendingRules, rejectedRules, -- * Events management - EventInfo(..), - EventHandler, - Status(..), events, getEventFields, getInput, @@ -56,7 +53,8 @@ ) where import Nomyx.Core.Engine.Evaluation -import Nomyx.Core.Engine.Game +import Nomyx.Core.Engine.EvalUtils +import Nomyx.Core.Engine.Types import Nomyx.Core.Engine.GameEvents import Nomyx.Core.Engine.Utils import Nomyx.Core.Engine.Test diff --git a/src/Nomyx/Core/Engine/EvalUtils.hs b/src/Nomyx/Core/Engine/EvalUtils.hs new file mode 100644 --- /dev/null +++ b/src/Nomyx/Core/Engine/EvalUtils.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE StandaloneDeriving #-} + +-- | additional tools for evaluation +module Nomyx.Core.Engine.EvalUtils where + +import Prelude hiding ((.), log) +import Control.Monad +import Control.Monad.State +import Control.Monad.Reader +import Data.List +import Data.Typeable +import Data.Lens +import Data.Maybe +import Data.Either +import Control.Applicative +import Control.Monad.Error (ErrorT(..)) +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 + +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 + +logPlayer :: PlayerNumber -> String -> Evaluate () +logPlayer pn = log (Just pn) + +logAll :: String -> Evaluate () +logAll = log Nothing + +log :: Maybe PlayerNumber -> String -> Evaluate () +log mpn s = do + time <- access currentTime + void $ logs %= (Log mpn time s : ) + +liftEval :: Reader Game 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 + e <- runErrorT egs + case e of + Right _ -> return () + Left e -> do + tracePN (fromMaybe 0 pn) $ "Error: " ++ e + void $ runErrorT $ log pn "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 + + +instance Eq SomeField where + (SomeField e1) == (SomeField e2) = e1 === e2 + + +instance Show EventInfo where + show (EventInfo en rn e _ 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 @@ -5,6 +5,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE StandaloneDeriving #-} +-- | Evaluation of a Nomyx expression module Nomyx.Core.Engine.Evaluation where import Prelude hiding ((.), log) @@ -13,33 +14,67 @@ import Control.Monad.Reader import Data.List import Data.Typeable -import Data.Function hiding ((.)) import Data.Time import Data.Lens import Data.Maybe import Control.Category hiding (id) import Control.Applicative -import Control.Monad.Error (ErrorT(..)) import Control.Monad.Error.Class (MonadError(..)) import Language.Nomyx.Expression -import Nomyx.Core.Engine.Game +import Nomyx.Core.Engine.Types +import Nomyx.Core.Engine.EvalUtils import Nomyx.Core.Engine.Utils -import Safe -type Evaluate a = ErrorT String (State Game) a - --- data sent back by the forms -data InputData = RadioData Int - | CheckboxData [Int] - | TextData String - | TextAreaData String - | ButtonData - deriving (Show, Read, Eq, Ord) +-- * Evaluation --- | evaluate an expression. +-- | 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 name def) rn = do +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 + +-- | 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 + +evSimu :: Nomex a -> NomexNE Bool -> RuleNumber -> Reader Game Bool +evSimu sim ev rn = do + let s = runEvalError Nothing (evalNomex sim rn) + g <- ask + let g' = execState s g + return $ runReader (evalNomexNE ev rn) g' + +evNewVar :: (Typeable a, Show a) => VarName -> a -> RuleNumber -> Evaluate (Maybe (V a)) +evNewVar name def rn = do vars <- access variables case find ((== name) . getL vName) vars of Nothing -> do @@ -47,7 +82,8 @@ return $ Just (V name) Just _ -> return Nothing -evalNomex (DelVar (V name)) _ = do +evDelVar :: (V a) -> Evaluate Bool +evDelVar (V name) = do vars <- access variables case find ((== name) . getL vName) vars of Nothing -> return False @@ -55,7 +91,8 @@ variables %= filter ((/= name) . getL vName) return True -evalNomex (WriteVar (V name) val) _ = do +evWriteVar :: (Typeable a, Show a) => V a -> a -> Evaluate Bool +evWriteVar (V name) val = do vars <- access variables case find (\(Var _ myName _) -> myName == name) vars of Nothing -> return False @@ -63,168 +100,15 @@ variables %= replaceWith ((== name) . getL vName) (Var rn myName val) return True -evalNomex (OnEvent event handler) rn = do +evOnEvent :: (Typeable e, Show e) => Event e -> ((EventNumber, e) -> Nomex ()) -> RuleNumber -> Evaluate EventNumber +evOnEvent event handler rn = do evs <- access events let en = getFreeNumber (map _eventNumber evs) events %= (EventInfo en rn (indexInputs event) handler SActive [] : ) return en -evalNomex (DelEvent en) _ = evDelEvent en - -evalNomex (SendMessage (Msg id) myData) _ = triggerEvent (Message (Msg id)) myData - -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 (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 (SetVictory ps) rn = do - void $ victory ~= (Just $ VictoryCond rn ps) - triggerEvent Victory (VictoryCond rn ps) - -evalNomex (Return a) _ = return a -evalNomex (Bind exp f) rn = do - e <- evalNomex exp rn - evalNomex (f e) rn - -liftEval :: Reader Game a -> Evaluate a -liftEval r = runReader r <$> get - -evalNomexNE :: NomexNE a -> RuleNumber -> Reader Game a -evalNomexNE (ReadVar (V name)) _ = do - vars <- asks _variables - let var = find ((== name) . getL vName) vars - case var of - Nothing -> return Nothing - Just (Var _ _ val) -> case cast val of - Just v -> return $ Just v - Nothing -> return Nothing - -evalNomexNE (GetOutput on) _ = evGetOutput on -evalNomexNE GetRules _ = asks _rules -evalNomexNE GetPlayers _ = asks _players -evalNomexNE SelfRuleNumber rn = return rn -evalNomexNE (CurrentTime) _ = asks _currentTime -evalNomexNE (Return a) _ = return a -evalNomexNE (Bind exp f) rn = do - e <- evalNomexNE exp rn - evalNomexNE (f e) rn - -evalNomexNE (Simu sim ev) rn = do - let s = runEvalError Nothing (evalNomex sim rn) - g <- ask - let g' = execState s g - return $ runReader (evalNomexNE ev rn) g' - -getVictorious :: Game -> [PlayerNumber] -getVictorious g = case _victory g of - Nothing -> [] - Just (VictoryCond rn v) -> runReader (evalNomexNE v rn) g - -evalOutput :: Game -> Output -> String -evalOutput g (Output _ rn _ o _) = runReader (evalNomexNE o rn) g - -allOutputs :: Game -> [String] -allOutputs g = map (evalOutput g) (_outputs g) - -triggerEvent :: (Typeable e, Show e) => Field e -> e -> Evaluate () -triggerEvent e dat = do - evs <- access events - triggerEvent' e dat evs - --- receive a field data -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') - mapM triggerIfComplete evs' - return () - -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 - BE (Left _) -> (env ^= (eventRes : envi) $ ei, Nothing) -- some fields are left to complete: add ours in the environment - BE (Right 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 - -data SomeData = forall e. (Typeable e, Show e) => SomeData e -deriving instance Show SomeData - --- in the case an event is complete, trigger its handler -triggerIfComplete :: (EventInfo, Maybe SomeData) -> Evaluate () -triggerIfComplete (EventInfo en rn _ h SActive _, Just (SomeData val)) = do - case (cast val) of - Just a -> do - let exp = h (en, a) - (evalNomex exp rn) `catchError` (errorHandler rn en) - Nothing -> error "Bad trigger data type" -triggerIfComplete _ = return () - --- 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] -> BEither [SomeField] a -getEventResult (PureEvent a) _ = BE (Right a) -getEventResult EmptyEvent _ = BE (Left []) -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 -> BE (Right r) - Nothing -> BE (Left [SomeField a]) - --- 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 lefft to be completed in an event -getEventFields :: Event a -> [EventEnv] -> [SomeField] -getEventFields e er = case (getEventResult e er) of - BE (Right _) -> [] - BE (Left a) -> a - -errorHandler :: RuleNumber -> EventNumber -> String -> Evaluate () -errorHandler rn en s = logAll $ "Error in rule " ++ show rn ++ " (triggered by event " ++ show en ++ "): " ++ s - --- trigger the input event with the input data -triggerInput :: EventNumber -> InputNumber -> InputData -> Evaluate () -triggerInput en inn ir = do - evs <- access events - let mei = find ((== en) . getL eventNumber) evs - when (isJust mei) $ execInputHandler ir inn (fromJust mei) - -execInputHandler :: InputData -> InputNumber -> EventInfo -> Evaluate () -execInputHandler ir inn ei = do - case (getInput ei inn) of - Just sf -> execInputHandler' ir sf ei - Nothing -> error "Input not found" - -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 - --- 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 () +evSendMessage :: (Typeable a, Show a) => Msg a -> a -> Evaluate () +evSendMessage (Msg id) d = triggerEvent (Message (Msg id)) d evProposeRule :: RuleInfo -> Evaluate Bool evProposeRule rule = do @@ -287,15 +171,6 @@ triggerEvent (RuleEv Modified) r return True -addPlayer :: PlayerInfo -> Evaluate Bool -addPlayer pi = do - pls <- access players - let exists = any (((==) `on` _playerNumber) pi) pls - unless exists $ do - players %= (pi:) - triggerEvent (Player Arrive) pi - return $ not exists - evDelPlayer :: PlayerNumber -> Evaluate Bool evDelPlayer pn = do g <- get @@ -330,29 +205,9 @@ return True SDeleted -> return False - evTriggerTime :: UTCTime -> Evaluate () evTriggerTime t = triggerEvent (Time t) t - ---delete all variables of a rule -delVarsRule :: RuleNumber -> Evaluate () -delVarsRule rn = void $ variables %= filter ((/= rn) . getL vRuleNumber) - ---delete all events of a rule -delEventsRule :: RuleNumber -> Evaluate () -delEventsRule rn = do - evs <- access 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 - let toDelete = filter ((== rn) . getL oRuleNumber) os - mapM_ (evDelOutput . _outputNumber) toDelete - evNewOutput :: Maybe PlayerNumber -> RuleNumber -> NomexNE String -> Evaluate OutputNumber evNewOutput pn rn s = do ops <- access outputs @@ -390,63 +245,106 @@ return True SDeleted -> return False -logPlayer :: PlayerNumber -> String -> Evaluate () -logPlayer pn = log (Just pn) +evSetVictory :: NomexNE [PlayerNumber] -> RuleNumber -> Evaluate () +evSetVictory ps rn = do + void $ victory ~= (Just $ VictoryCond rn ps) + triggerEvent Victory (VictoryCond rn ps) -logAll :: String -> Evaluate () -logAll = log Nothing +evReadVar :: (Typeable a, Show a) => V a -> Reader Game (Maybe a) +evReadVar (V name) = do + vars <- asks _variables + let var = find ((== name) . getL vName) vars + case var of + Nothing -> return Nothing + Just (Var _ _ val) -> case cast val of + Just v -> return $ Just v + Nothing -> return Nothing -log :: Maybe PlayerNumber -> String -> Evaluate () -log mpn s = do - time <- access currentTime - void $ logs %= (Log mpn time s : ) +-- * Event triggers ---remove the ErrorT layer from the Evaluate monad stack. -runEvalError :: Maybe PlayerNumber -> Evaluate a -> State Game () -runEvalError pn egs = do - e <- runErrorT egs - case e of - Right _ -> return () - Left e -> do - tracePN (fromMaybe 0 pn) $ "Error: " ++ e - void $ runErrorT $ log pn "Error: " +-- trigger an event +triggerEvent :: (Typeable e, Show e) => Field e -> e -> Evaluate () +triggerEvent e dat = do + evs <- access events + triggerEvent' e dat evs --- Put an index on every input fields -indexInputs :: Event a -> Event a -indexInputs e = fst $ indexInputs' 0 e +-- 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') + mapM triggerIfComplete evs' + return () -indexInputs' :: Int -> Event a -> (Event a, Int) -indexInputs' n (BaseEvent (Input _ pn s ifo)) = (BaseEvent (Input (Just n) pn s ifo), n+1) -indexInputs' n (BaseEvent a) = (BaseEvent a, n) -indexInputs' n (PureEvent a) = (PureEvent a, n) -indexInputs' n EmptyEvent = (EmptyEvent, n) -indexInputs' n (SumEvent a b) = (SumEvent e1 e2, n2) where - (e1, n1) = indexInputs' n a - (e2, n2) = indexInputs' n1 b -indexInputs' n (AppEvent a b) = (AppEvent e1 e2, n2) where - (e1, n1) = indexInputs' n a - (e2, n2) = indexInputs' n1 b +-- if the event is complete, trigger its handler +triggerIfComplete :: (EventInfo, Maybe SomeData) -> Evaluate () +triggerIfComplete (EventInfo en rn _ h SActive _, Just (SomeData val)) = do + case (cast val) of + Just a -> do + let exp = h (en, a) + (evalNomex exp rn) `catchError` (errorHandler rn en) + Nothing -> error "Bad trigger data type" +triggerIfComplete _ = return () -newtype BEither a b = BE (Either a b) deriving (Show, Eq, Typeable) -bLeft = BE . Left -bRight = BE . Right -instance Alternative (BEither [a]) where - empty = bLeft [] - BE (Left a) <|> BE (Left b) = bLeft $ a ++ b - BE (Left _) <|> n = n - m <|> _ = m +-- * input triggers -instance Applicative (BEither [a]) where - pure = BE . Right - BE (Left a) <*> BE (Left b) = BE (Left (a ++ b)) - BE (Left a) <*> _ = BE (Left a) - BE (Right f) <*> r = fmap f r +-- trigger the input event with the input data +triggerInput :: EventNumber -> InputNumber -> InputData -> Evaluate () +triggerInput en inn ir = do + evs <- access events + let mei = find ((== en) . getL eventNumber) evs + when (isJust mei) $ execInputHandler ir inn (fromJust mei) -instance Functor (BEither a) where - fmap _ (BE (Left x)) = BE (Left x) - fmap f (BE (Right y)) = BE (Right (f y)) +-- 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 + 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 () + +-- * misc + +getVictorious :: Game -> [PlayerNumber] +getVictorious g = case _victory g of + Nothing -> [] + Just (VictoryCond rn v) -> runReader (evalNomexNE v rn) g + +evalOutput :: Game -> Output -> String +evalOutput g (Output _ rn _ o _) = runReader (evalNomexNE o rn) g + +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) + +--delete all events of a rule +delEventsRule :: RuleNumber -> Evaluate () +delEventsRule rn = do + evs <- access 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 + let toDelete = filter ((== rn) . getL oRuleNumber) os + mapM_ (evDelOutput . _outputNumber) toDelete + + -- | Show instance for Game -- showing a game involves evaluating some parts (such as victory and outputs) instance Show Game where @@ -461,13 +359,3 @@ "\n currentTime = " ++ show _currentTime ++ "\n" -instance Show EventInfo where - show (EventInfo en rn e _ s env) = - "event num: " ++ (show en) ++ - ", rule num: " ++ (show rn) ++ - ", event fields: " ++ (show $ getEventFields e env) ++ - ", envs: " ++ (show env) ++ - ", status: " ++ (show s) - -instance Eq SomeField where - (SomeField e1) == (SomeField e2) = e1 === e2 diff --git a/src/Nomyx/Core/Engine/Game.hs b/src/Nomyx/Core/Engine/Game.hs deleted file mode 100644 --- a/src/Nomyx/Core/Engine/Game.hs +++ /dev/null @@ -1,116 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE StandaloneDeriving #-} - --- | This module implements game engine (for the nomyx language, see Language.Nomyx) -module Nomyx.Core.Engine.Game where - -import Prelude hiding (log) -import Language.Nomyx.Expression -import Data.Lens.Template -import Data.Time -import Data.Typeable -import Data.Data - --- * Game - -type GameName = String - --- | The state of the game: -data Game = Game { _gameName :: GameName, - _gameDesc :: GameDesc, - _rules :: [RuleInfo], - _players :: [PlayerInfo], - _variables :: [Var], - _events :: [EventInfo], - _outputs :: [Output], - _victory :: Maybe VictoryCond, - _logs :: [Log], - _currentTime :: UTCTime} - deriving (Typeable) - -data GameDesc = GameDesc { _desc :: String, _agora :: String} deriving (Eq, Show, Read, Ord) - -instance Eq Game where - (Game {_gameName=gn1}) == (Game {_gameName=gn2}) = gn1 == gn2 - -instance Ord Game where - compare (Game {_gameName=gn1}) (Game {_gameName=gn2}) = compare gn1 gn2 - -emptyGame name desc date = Game { - _gameName = name, - _gameDesc = desc, - _rules = [], - _players = [], - _variables = [], - _events = [], - _outputs = [], - _victory = Nothing, - _logs = [], - _currentTime = date} - - --- * Variables - --- | stores the variable's data -data Var = forall a . (Typeable a, Show a) => - Var { _vRuleNumber :: RuleNumber, - _vName :: String, - vData :: a} - -instance Show Var where - show (Var a b c) = "Rule number = " ++ (show a) ++ ", Name = " ++ (show b) ++ ", Value = " ++ (show c) ++ "\n" - --- * Events - -type EventHandler e = (EventNumber, e) -> Nomex () - -data EventInfo = forall e. (Typeable e, Show e) => - EventInfo {_eventNumber :: EventNumber, - _ruleNumber :: RuleNumber, - event :: Event e, - handler :: EventHandler e, - _evStatus :: Status, - _env :: [EventEnv]} - -data EventEnv = forall e. (Typeable e, Show e) => EventEnv (Field e) e - -deriving instance Show EventEnv - -data Status = SActive | SDeleted deriving (Eq, Show) - -instance Eq EventInfo where - (EventInfo {_eventNumber=e1}) == (EventInfo {_eventNumber=e2}) = e1 == e2 - -instance Ord EventInfo where - (EventInfo {_eventNumber=e1}) <= (EventInfo {_eventNumber=e2}) = e1 <= e2 - - --- * Outputs - -data Output = Output { _outputNumber :: OutputNumber, -- number of the output - _oRuleNumber :: RuleNumber, -- rule that triggered the output - _oPlayerNumber :: (Maybe PlayerNumber), -- player to display the output to (Nothing means display to all players) - _output :: NomexNE String, -- output string - _oStatus :: Status} -- status of the output - deriving (Show) - --- * Logs - -data Log = Log { _lPlayerNumber :: Maybe PlayerNumber, - _lTime :: UTCTime, - _lMsg :: String} - deriving (Show) - --- * Rules - -data SubmitRule = SubmitRule RuleName RuleDesc RuleCode deriving (Show, Read, Eq, Ord, Data, Typeable) - - -$( makeLenses [''Game, ''GameDesc, ''EventInfo, ''Var, ''Output] ) - - - 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 @@ -9,7 +9,8 @@ import Data.List import Language.Nomyx.Expression import Nomyx.Core.Engine.Evaluation -import Nomyx.Core.Engine.Game +import Nomyx.Core.Engine.EvalUtils +import Nomyx.Core.Engine.Types import Nomyx.Core.Engine.Utils import Data.Lens import Control.Category ((>>>)) 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 @@ -12,14 +12,15 @@ import Language.Nomyx.Inputs import Language.Nomyx.Vote import Language.Nomyx.Examples -import Language.Nomyx.Players import Nomyx.Core.Engine.Evaluation -import Nomyx.Core.Engine.Game +import Nomyx.Core.Engine.EvalUtils +import Nomyx.Core.Engine.Types import Nomyx.Core.Engine.Utils import Control.Monad.State import Data.Lens import Data.Typeable -import qualified Data.Foldable as T +import Data.Function hiding ((.)) +import Data.Maybe import Control.Applicative date1 = parse822Time "Tue, 02 Sep 1997 09:00:00 -0400" @@ -96,9 +97,8 @@ ("test assess on every vote 3", testVoteAssessOnEveryVote3), ("test assess on every vote 4", testVoteAssessOnEveryVote4), ("test majority with", testVoteMajorityWith), - ("test number positive votes", testVoteNumberPositiveVotes), +-- ("test number positive votes", testVoteNumberPositiveVotes), ("test vote with quorum 1", testVoteWithQuorum1), - ("test vote with quorum 2", testVoteWithQuorum2), ("test assess on time limit 1", testVoteAssessOnTimeLimit1), ("test assess on time limit 2", testVoteAssessOnTimeLimit2), ("test assess on time limit 3", testVoteAssessOnTimeLimit3), @@ -107,7 +107,8 @@ ("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) + ] allTests = all snd tests @@ -290,8 +291,8 @@ evs <- lift getChoiceEvents let pos = take positives evs let neg = take negatives $ drop positives evs - mapM_ (\x -> triggerInput x 0 (RadioData $ fromEnum For)) pos - mapM_ (\x -> triggerInput x 0 (RadioData $ fromEnum Against)) neg + mapM_ (\(en, inum) -> triggerInput en inum (RadioData 0)) pos --issuing positive votes + mapM_ (\(en, inum) -> triggerInput en inum (RadioData 1)) neg --issuing negative votes when timeEvent $ evTriggerTime date2 voteGame' :: Int -> Int -> Int -> Bool -> Rule -> Game @@ -303,22 +304,21 @@ voteGameTimed :: Int -> Int -> Int -> Rule -> Game voteGameTimed positives negatives notVoted = voteGame' positives negatives notVoted True --- vote rules |Expected result |pos |neg |total |description of voting system -testVoteAssessOnVoteComplete1 = testVoteRule Active $ voteGame 10 0 10 $ onRuleProposed $ voteWith_ majority assessWhenEverybodyVoted -testVoteAssessOnVoteComplete2 = testVoteRule Pending $ voteGame 9 0 10 $ onRuleProposed $ voteWith_ majority assessWhenEverybodyVoted -testVoteAssessOnEveryVote1 = testVoteRule Active $ voteGame 10 0 10 $ onRuleProposed $ voteWith_ unanimity assessOnEveryVote -testVoteAssessOnEveryVote2 = testVoteRule Active $ voteGame 6 0 10 $ onRuleProposed $ voteWith_ majority assessOnEveryVote -testVoteAssessOnEveryVote3 = testVoteRule Pending $ voteGame 5 0 10 $ onRuleProposed $ voteWith_ majority assessOnEveryVote -testVoteAssessOnEveryVote4 = testVoteRule Reject $ voteGame 0 5 10 $ onRuleProposed $ voteWith_ majority assessOnEveryVote -testVoteMajorityWith = testVoteRule Active $ voteGame 6 0 10 $ onRuleProposed $ voteWith_ (majorityWith 50) assessOnEveryVote -testVoteNumberPositiveVotes = testVoteRule Active $ voteGame 3 7 10 $ onRuleProposed $ voteWith_ (numberVotes 3) assessOnEveryVote -testVoteWithQuorum1 = testVoteRule Active $ voteGame 7 3 10 $ onRuleProposed $ voteWith_ (majority `withQuorum` 7) assessOnEveryVote -testVoteWithQuorum2 = testVoteRule Pending $ voteGame 6 0 10 $ onRuleProposed $ voteWith_ (majority `withQuorum` 7) assessOnEveryVote -testVoteAssessOnTimeLimit1 = testVoteRule Active $ voteGameTimed 10 0 10 $ onRuleProposed $ voteWith_ unanimity $ assessOnTimeLimit date2 -testVoteAssessOnTimeLimit2 = testVoteRule Active $ voteGameTimed 1 0 10 $ onRuleProposed $ voteWith_ unanimity $ assessOnTimeLimit date2 -testVoteAssessOnTimeLimit3 = testVoteRule Reject $ voteGameTimed 1 0 10 $ onRuleProposed $ voteWith_ (unanimity `withQuorum` 5) $ assessOnTimeLimit date2 -testVoteAssessOnTimeLimit4 = testVoteRule Reject $ voteGameTimed 0 0 10 $ onRuleProposed $ voteWith_ (unanimity `withQuorum` 1) $ assessOnTimeLimit date2 -testVoteAssessOnTimeLimit5 = testVoteRule Pending $ voteGameTimed 10 0 10 $ onRuleProposed $ voteWith_ unanimity $ assessOnTimeLimit date3 +-- vote rules |Expected result |pos |neg |total |description of voting system +testVoteAssessOnVoteComplete1 = testVoteRule Active $ voteGame 10 0 10 $ onRuleProposed $ (callVoteRule majority oneDay) +testVoteAssessOnVoteComplete2 = testVoteRule Pending $ voteGame 9 0 10 $ onRuleProposed $ (callVoteRule unanimity oneDay) +testVoteAssessOnEveryVote1 = testVoteRule Active $ voteGame 10 0 10 $ onRuleProposed $ (callVoteRule unanimity oneDay) +testVoteAssessOnEveryVote2 = testVoteRule Active $ voteGame 6 0 10 $ onRuleProposed $ (callVoteRule majority oneDay) +testVoteAssessOnEveryVote3 = testVoteRule Pending $ voteGame 5 0 10 $ onRuleProposed $ (callVoteRule majority oneDay) +testVoteAssessOnEveryVote4 = testVoteRule Reject $ voteGame 0 5 10 $ onRuleProposed $ (callVoteRule majority oneDay) +testVoteMajorityWith = testVoteRule Active $ voteGame 6 0 10 $ onRuleProposed $ (callVoteRule (majorityWith 50) oneDay) +testVoteNumberPositiveVotes = testVoteRule Active $ voteGame 3 7 10 $ onRuleProposed $ (callVoteRule (numberVotes 3) oneDay) +testVoteWithQuorum1 = testVoteRule Active $ voteGame 7 3 10 $ onRuleProposed $ (callVoteRule (majority `withQuorum` 7) oneDay) +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) testVoteRule s g = (_rStatus $ head $ _rules g) == s @@ -352,27 +352,35 @@ --Get all event numbers of type choice (radio button) -getChoiceEvents :: State Game [EventNumber] +getChoiceEvents :: State Game [(EventNumber, InputNumber)] getChoiceEvents = do evs <- access events - return $ map _eventNumber $ filter choiceEvent evs - where choiceEvent (EventInfo _ _ (BaseEvent (Input _ _ _ (Radio _))) _ _ _) = True - choiceEvent _ = False + return $ [(_eventNumber ev, inum) | ev <- evs, inum <- getInputChoices ev ] +getInputChoices :: EventInfo -> [InputNumber] +getInputChoices (EventInfo _ _ ev _ _ env) = mapMaybe isInput (getEventFields ev env) where + isInput (SomeField (Input (Just inum) _ _ (Radio _))) = Just inum + isInput _ = Nothing + --Get all event numbers of type text (text field) -getTextEvents :: State Game [EventNumber] +getTextEvents :: State Game [(EventNumber, InputNumber)] getTextEvents = do evs <- access events - return $ map _eventNumber $ filter choiceEvent evs - where choiceEvent (EventInfo _ _ (BaseEvent (Input _ _ _ Text)) _ _ _) = True - choiceEvent _ = False + return $ [(_eventNumber ev, inum) | ev <- evs, inum <- getInputTexts ev ] -isOutput :: String -> Game -> Bool -isOutput s g = s `elem` allOutputs g +getInputTexts :: EventInfo -> [InputNumber] +getInputTexts (EventInfo _ _ ev _ _ env) = mapMaybe isInput (getEventFields ev env) where + isInput (SomeField (Input (Just inum) _ _ Text)) = Just inum + isInput _ = Nothing +addPlayer :: PlayerInfo -> Evaluate Bool +addPlayer pi = do + pls <- access players + let exists = any (((==) `on` _playerNumber) pi) pls + unless exists $ do + players %= (pi:) + triggerEvent (Player Arrive) pi + return $ not exists -myEvent :: NomexNE (Event String) -myEvent = do - ps <- getAllPlayerNumbers - let oneButton pn = inputText pn "test" - return $ T.asum (map oneButton ps) +isOutput :: String -> Game -> Bool +isOutput s g = s `elem` allOutputs g diff --git a/src/Nomyx/Core/Engine/Types.hs b/src/Nomyx/Core/Engine/Types.hs new file mode 100644 --- /dev/null +++ b/src/Nomyx/Core/Engine/Types.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE StandaloneDeriving #-} + +-- | Types for the engine +module Nomyx.Core.Engine.Types where + +import Prelude hiding (log) +import Language.Nomyx.Expression +import Data.Lens.Template +import Data.Time +import Data.Typeable +import Data.Data +import Control.Monad.Error (ErrorT(..)) +import Control.Monad.State + +-- * Game + +type GameName = String + +-- | The state of the game: +data Game = Game { _gameName :: GameName, + _gameDesc :: GameDesc, + _rules :: [RuleInfo], + _players :: [PlayerInfo], + _variables :: [Var], + _events :: [EventInfo], + _outputs :: [Output], + _victory :: Maybe VictoryCond, + _logs :: [Log], + _currentTime :: UTCTime} + deriving (Typeable) + +data GameDesc = GameDesc { _desc :: String, _agora :: String} deriving (Eq, Show, Read, Ord) + +instance Eq Game where + (Game {_gameName=gn1}) == (Game {_gameName=gn2}) = gn1 == gn2 + +instance Ord Game where + compare (Game {_gameName=gn1}) (Game {_gameName=gn2}) = compare gn1 gn2 + +emptyGame name desc date = Game { + _gameName = name, + _gameDesc = desc, + _rules = [], + _players = [], + _variables = [], + _events = [], + _outputs = [], + _victory = Nothing, + _logs = [], + _currentTime = date} + + +-- * Variables + +-- | stores the variable's data +data Var = forall a . (Typeable a, Show a) => + Var { _vRuleNumber :: RuleNumber, + _vName :: String, + vData :: a} + +instance Show Var where + show (Var a b c) = "Rule number = " ++ (show a) ++ ", Name = " ++ (show b) ++ ", Value = " ++ (show c) ++ "\n" + +-- * Events + +type Evaluate a = ErrorT String (State Game) a + +-- data sent back by the forms +data InputData = RadioData Int + | CheckboxData [Int] + | TextData String + | TextAreaData String + | ButtonData + deriving (Show, Read, Eq, Ord) + +data SomeData = forall e. (Typeable e, Show e) => SomeData e +deriving instance Show SomeData + +-- * Outputs + +data Output = Output { _outputNumber :: OutputNumber, -- number of the output + _oRuleNumber :: RuleNumber, -- rule that triggered the output + _oPlayerNumber :: (Maybe PlayerNumber), -- player to display the output to (Nothing means display to all players) + _output :: NomexNE String, -- output string + _oStatus :: Status} -- status of the output + deriving (Show) + +-- * Logs + +data Log = Log { _lPlayerNumber :: Maybe PlayerNumber, + _lTime :: UTCTime, + _lMsg :: String} + deriving (Show) + +-- * Rules + +data SubmitRule = SubmitRule RuleName RuleDesc RuleCode deriving (Show, Read, Eq, Ord, Data, Typeable) + + +$( makeLenses [''Game, ''GameDesc, ''Var, ''Output] ) + + + + + 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 @@ -4,7 +4,6 @@ module Nomyx.Core.Multi where import Language.Haskell.Interpreter.Server (ServerHandle) -import Data.Maybe import Data.Lens import Data.List import Data.Time as T @@ -45,7 +44,7 @@ -- | the initial rule set for a game. rVoteUnanimity = SubmitRule "Unanimity Vote" "A proposed rule will be activated if all players vote for it" - [cr|onRuleProposed $ voteWith_ unanimity $ assessOnEveryVote |] + [cr|onRuleProposed $ callVoteRule unanimity oneDay|] rVictory5Rules = SubmitRule "Victory 5 accepted rules" "Victory is achieved if you have 5 active rules" @@ -53,7 +52,7 @@ rVoteMajority = SubmitRule "Majority Vote" "A proposed rule will be activated if a majority of players is reached, with a minimum of 2 players, and within oone day" - [cr|onRuleProposed $ voteWith_ (majority `withQuorum` 2) $ assessOnEveryVote >> assessOnTimeDelay oneMinute |] + [cr|onRuleProposed $ callVoteRule (majority `withQuorum` 2) oneDay|] initialGame :: ServerHandle -> StateT GameInfo IO () diff --git a/src/Nomyx/Core/Quotes.hs b/src/Nomyx/Core/Quotes.hs --- a/src/Nomyx/Core/Quotes.hs +++ b/src/Nomyx/Core/Quotes.hs @@ -44,7 +44,8 @@ setImports unQualImports typeOf s case res of - Right "Exp Effect ()" -> [| s |] + Right "Exp Effect ()" -> [| s |] + Right "Nomex ()" -> [| s |] Right "Exp 'Effect ()" -> [| s |] Right "Rule" -> [| s |] Right a -> fail $ "Rule doesn't typecheck: " ++ show a 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 @@ -316,14 +316,14 @@ inputAllRadios choice pn = do s <- get let evs = evalState getChoiceEvents (firstGame $ _multi s) - mapM_ (\en -> inputResult pn en 0 (RadioData choice) "test") evs + mapM_ (\(en, inum) -> inputResult pn en inum (RadioData choice) "test") evs -- input text for all text fields inputAllTexts :: String -> PlayerNumber -> StateT Session IO () inputAllTexts a pn = do s <- get let evs = evalState getTextEvents (firstGame $ _multi s) - mapM_ (\en -> inputResult pn en 0 (TextData a) "test") evs + mapM_ (\(en, inum) -> inputResult pn en inum (TextData a) "test") evs firstGame :: Multi -> Game firstGame = G._game . _loggedGame . head . _gameInfos