packages feed

Nomyx-Language 0.3.2 → 0.4.0

raw patch · 25 files changed

+2260/−1914 lines, 25 filesdep −hint-serverdep −hsloggerdep −safecopydep ~Booleandep ~DebugTraceHelpersdep ~basebuild-type:Customsetup-changed

Dependencies removed: hint-server, hslogger, safecopy, stm, template-haskell

Dependency ranges changed: Boolean, DebugTraceHelpers, base, containers, data-lens, data-lens-fd, data-lens-template, ghc, mtl, old-locale, safe, time, time-recurrence, transformers

Files

Nomyx-Language.cabal view
@@ -1,9 +1,9 @@ name: Nomyx-Language-version: 0.3.2+version: 0.4.0 cabal-version: >=1.6----Warning: For using "cabal sdist", this patch is needed in cabal: https://github.com/haskell/cabal/pull/1110----To allow sdist to work with exported generated modules (Paths_Nomyx_Language)-build-type: Simple+---Warning: to use "cabal sdist", this patch is needed in cabal: https://github.com/haskell/cabal/pull/1110+---This allows cabal to work with exported generated modules (Paths_Nomyx_Language)+build-type: Custom license: BSD3 license-file: LICENSE copyright: 2012 Corentin Dupont@@ -12,47 +12,53 @@ synopsis: Language to express rules for Nomic description: Provide a DSL to express rules for a Nomic game, with evaluation engine. See package Nomyx for a full game implementation. category: Language-Homepage: www.nomyx.net+Homepage: http://www.nomyx.net author: Corentin Dupont-data-files: src/Language/Nomyx/Definition.hs+data-files: src/Language/Nomyx.hs             src/Language/Nomyx/Examples.hs             src/Language/Nomyx/Expression.hs-            src/Language/Nomyx/Rule.hs-            src/Language/Nomyx/Test.hs+            src/Language/Nomyx/Rules.hs+            src/Language/Nomyx/Inputs.hs+            src/Language/Nomyx/Outputs.hs+            src/Language/Nomyx/Variables.hs+            src/Language/Nomyx/Events.hs+            src/Language/Nomyx/Players.hs             src/Language/Nomyx/Vote.hs+             data-dir: "" extra-source-files: AUTHORS README   library-    build-depends: base ==4.*,-                   containers -any,-                   ghc -any,-                   hint-server -any,-                   hslogger -any,-                   mtl -any,-                   old-locale -any,-                   safe -any,-                   stm -any,-                   template-haskell -any,-                   time -any,-                   time-recurrence -any,-                   DebugTraceHelpers -any,-                   data-lens -any,-                   data-lens-template -any,-                   data-lens-fd -any,-                   Boolean -any,-                   safecopy -any,-                   transformers -any+    build-depends: DebugTraceHelpers  == 0.12.*,+                   Boolean            == 0.2.*,+                   base               == 4.6.*,+                   containers         == 0.5.*,+                   data-lens          == 2.10.*,+                   data-lens-template == 2.1.*,+                   data-lens-fd       == 2.0.*,+                   ghc                == 7.6.*,+                   mtl                == 2.1.*,+                   old-locale         == 1.0.*,+                   safe               == 0.3.*,+                   time               == 1.4.*,+                   time-recurrence    == 0.9.*,+                   transformers       == 0.3.*     exposed-modules: Language.Nomyx                      Language.Nomyx.Expression-                     Language.Nomyx.Definition-                     Language.Nomyx.Evaluation                      Language.Nomyx.Examples-                     Language.Nomyx.Rule+                     Language.Nomyx.Variables+                     Language.Nomyx.Events+                     Language.Nomyx.Inputs+                     Language.Nomyx.Outputs+                     Language.Nomyx.Players+                     Language.Nomyx.Rules                      Language.Nomyx.Vote-                     Language.Nomyx.Test-                     Language.Nomyx.Game-                     Language.Nomyx.Utils+                     Language.Nomyx.Engine+                     Language.Nomyx.Engine.Evaluation+                     Language.Nomyx.Engine.Game+                     Language.Nomyx.Engine.GameEvents+                     Language.Nomyx.Engine.Test+                     Language.Nomyx.Engine.Utils                      Paths_Nomyx_Language     exposed: True     buildable: True
+ Setup.hs view
@@ -0,0 +1,9 @@+module Main where+import Distribution.Simple+import Paths_Nomyx_Language++main :: IO ()+main = do+   putStrLn "toto"+   defaultMain+
− Setup.lhs 
@@ -1,6 +0,0 @@-#!/usr/bin/runhaskell -> module Main where-> import Distribution.Simple-> main :: IO ()-> main = defaultMain-
src/Language/Nomyx.hs view
@@ -1,19 +1,24 @@ +-- | This module re-exports the elements necessary to compose a Nomyx rule. module Language.Nomyx (-   module Language.Nomyx.Expression,-   module Language.Nomyx.Definition,-   module Language.Nomyx.Rule,-   module Language.Nomyx.Examples,-   module Language.Nomyx.Evaluation,-   module Language.Nomyx.Vote,-   module Language.Nomyx.Utils)  where+   module Language.Nomyx.Expression, -- Nomyx Expression DSL+   module Language.Nomyx.Outputs,    -- create outputs+   module Language.Nomyx.Inputs,     -- create inputs+   module Language.Nomyx.Events,     -- create events+   module Language.Nomyx.Players,    -- manage players+   module Language.Nomyx.Variables,  -- create variables+   module Language.Nomyx.Rules,      -- manage rules+   module Language.Nomyx.Vote        -- create votations+   )  where  import Language.Nomyx.Expression-import Language.Nomyx.Definition-import Language.Nomyx.Rule-import Language.Nomyx.Examples-import Language.Nomyx.Evaluation+import Language.Nomyx.Outputs+import Language.Nomyx.Inputs+import Language.Nomyx.Events+import Language.Nomyx.Players+import Language.Nomyx.Variables+import Language.Nomyx.Rules import Language.Nomyx.Vote-import Language.Nomyx.Utils+
− src/Language/Nomyx/Definition.hs 
@@ -1,637 +0,0 @@-{-# LANGUAGE DeriveDataTypeable, GADTs, ScopedTypeVariables, TupleSections, QuasiQuotes, FlexibleInstances #-}
-
--- | All the building blocks to build rules.
-module Language.Nomyx.Definition where
-
-import Language.Nomyx.Expression
-import Data.Typeable
-import Control.Monad.State
-import Data.List
-import Data.Maybe
-import Data.Time hiding (getCurrentTime)
-import qualified Data.Map as M
-import Data.Map hiding (map, filter, insert, mapMaybe, null)
-import Data.Time.Recurrence hiding (filter)
-import Safe
-import Data.Lens
-import Control.Applicative
-import Data.Boolean-import Control.Monad.Error-import Language.Nomyx.Utils-
--- * Variables
--- | variable creation
-newVar :: (Typeable a, Show a, Eq a) => VarName -> a -> Nomex (Maybe (V a))
-newVar = NewVar
-
-newVar_ :: (Typeable a, Show a, Eq a) => VarName -> a -> Nomex (V a)
-newVar_ s a = partial "newVar_: Variable existing" (newVar s a)
-
--- | variable reading
-readVar :: (Typeable a, Show a, Eq a) => (V a) -> Nomex (Maybe a)
-readVar = ReadVar
-
-readVar_ :: forall a. (Typeable a, Show a, Eq a) => (V a) -> Nomex a
-readVar_ v@(V a) = partial ("readVar_: Variable \"" ++ a ++ "\" with type \"" ++ (show $ typeOf v) ++ "\" not existing") (readVar v)
-
--- | variable writing
-writeVar :: (Typeable a, Show a, Eq a) => (V a) -> a -> Nomex Bool
-writeVar = WriteVar
-
-writeVar_ :: (Typeable a, Show a, Eq a) => (V a) -> a -> Nomex ()
-writeVar_ var val = void $ writeVar var val-
--- | modify a variable using the provided function
-modifyVar :: (Typeable a, Show a, Eq a) => (V a) -> (a -> a) -> Nomex ()
-modifyVar v f = writeVar_ v . f =<< readVar_ v
-
--- | delete variable
-delVar :: (V a) -> Nomex Bool
-delVar = DelVar
-
-delVar_ :: (V a) -> Nomex ()
-delVar_ v = void $ delVar v
---- * Message Variable--- | a MsgVar is a variable with a message attached, allowing to trigger registered functions anytime the var if modified-data VEvent a = VUpdated a | VDeleted deriving (Typeable, Show, Eq)-data MsgVar a = MsgVar (Msg (VEvent a)) (V a)--msgVar :: String -> MsgVar a-msgVar a = MsgVar (Message a) (V a)--newMsgVar :: (Typeable a, Show a, Eq a) => VarName -> a -> Nomex (Maybe (MsgVar a))
-newMsgVar name a = do
-    mv <- newVar name a-    return $ mv >>= Just . MsgVar (Message name)-
-newMsgVar_ :: (Typeable a, Show a, Eq a) => VarName -> a -> Nomex (MsgVar a)
-newMsgVar_ name a = partial "newMsgVar_: Variable existing" (newMsgVar name a)
---newMsgVar' :: (Typeable a, Show a, Eq a) => VarName -> a -> (VEvent a -> Nomex()) -> Nomex (Maybe (MsgVar a))
-newMsgVar' name a f = do
-    mv <- newMsgVar name a-    case mv of-       Just (MsgVar m _) -> do-          onMessage m $ f . messageData
-          return mv-       Nothing -> return Nothing
--writeMsgVar :: (Typeable a, Show a, Eq a) => MsgVar a -> a -> Nomex Bool
-writeMsgVar (MsgVar m v) a = do
-   r <- writeVar v a-   sendMessage m (VUpdated a)-   return r--writeMsgVar_ :: (Typeable a, Show a, Eq a) => MsgVar a -> a -> Nomex ()-writeMsgVar_ mv a = void $ writeMsgVar mv a--readMsgVar :: (Typeable a, Show a, Eq a) => MsgVar a -> Nomex (Maybe a)
-readMsgVar (MsgVar _ v) = readVar v--readMsgVar_ :: (Typeable a, Show a, Eq a) => MsgVar a -> Nomex a
-readMsgVar_ mv = partial "readMsgVar_: variable not existing" (readMsgVar mv)--modifyMsgVar :: (Typeable a, Show a, Eq a) => MsgVar a -> (a -> a) -> Nomex ()-modifyMsgVar mv f = writeMsgVar_ mv . f =<< readMsgVar_ mv--delMsgVar :: (Typeable a, Show a, Eq a) => MsgVar a -> Nomex Bool
-delMsgVar (MsgVar m v) = do-   sendMessage m VDeleted-   delAllEvents m-   delVar v--onMsgVarChange :: (Typeable a, Show a, Eq a) => MsgVar a -> (VEvent a -> Nomex()) -> Nomex ()-onMsgVarChange mv f = do-   m <- getMsgVarMessage mv-   onMessage m $ \(MessageData v) -> f v--onMsgVarEvent :: (Typeable a, Show a, Eq a)-               => MsgVar a-               -> (a -> Nomex b)-               -> (a -> b -> Nomex())-               -> (b -> Nomex())-               -> Nomex ()-onMsgVarEvent mv create update delete = do-   val <- readMsgVar_ mv-   c <- create val-   onMsgVarChange mv $ f c where-      f c' (VUpdated v) = update v c'-      f c' VDeleted     = delete c'---- | get the messsage triggered when the array is filled
-getMsgVarMessage :: (Typeable a, Show a, Eq a) => (MsgVar a) -> Nomex (Msg (VEvent a))
-getMsgVarMessage (MsgVar m _) = return m
---- | get the association array
-getMsgVarData :: (Typeable a, Show a, Eq a) => (MsgVar a) -> Nomex (Maybe a)
-getMsgVarData (MsgVar _ v) = readVar v
--getMsgVarData_ :: (Typeable a, Show a, Eq a) => (MsgVar a) -> Nomex a
-getMsgVarData_ (MsgVar _ v) = readVar_ v--getMsgVarName :: (Typeable a, Show a, Eq a) => (MsgVar a) -> String-getMsgVarName (MsgVar _ (V varName)) = varName--    
--- * Variable arrays
--- | ArrayVar is an indexed array with a signal attached triggered at every change.
--- | each indexed elements starts empty (value=Nothing).
-type ArrayVar i a = MsgVar [(i, Maybe a)]
-
--- | initialize an empty ArrayVar
-newArrayVar :: (Typeable a, Show a, Eq a, Typeable i, Show i, Eq i) => VarName -> [i] -> Nomex (Maybe (ArrayVar i a))
-newArrayVar name l = do
-    let list = map (\i -> (i, Nothing)) l
-    newMsgVar name list--newArrayVar_ :: (Typeable a, Show a, Eq a, Typeable i, Show i, Eq i) => VarName -> [i] -> Nomex (ArrayVar i a)
-newArrayVar_ name l = partial "newArrayVar_: Variable existing" (newArrayVar name l)
-
--- | initialize an empty ArrayVar, registering a callback that will be triggered at every change
-newArrayVar' :: (Typeable a, Show a, Eq a, Typeable i, Show i, Eq i) => VarName -> [i] -> (VEvent [(i,Maybe a)] -> Nomex ()) -> Nomex (Maybe (ArrayVar i a))
-newArrayVar' name l f = do-    let list = map (\i -> (i, Nothing)) l
-    newMsgVar' name list f
-
--- | initialize an empty ArrayVar, registering a callback.
--- the ArrayVar will be deleted when full
-newArrayVarOnce :: (Ord i, Typeable a, Show a, Eq a, Typeable i, Show i) => VarName -> [i] -> (VEvent [(i, Maybe a)] -> Nomex ()) -> Nomex (Maybe (ArrayVar i a))
-newArrayVarOnce name l f = do
-   mv <- newArrayVar' name l f-   when (isJust mv) $ cleanOnFull $ fromJust mv
-   return mv--cleanOnFull :: (Typeable a, Show a, Eq a, Ord i, Typeable i, Show i) => (ArrayVar i a) -> Nomex ()-cleanOnFull ar = do-   m <- getMsgVarMessage ar 
-   onMessage m $ \_ -> do
-      full <- (isFullArrayVar_ ar)
-      when full $ void $ delMsgVar ar-      return ()-   return ()-
-isFullArrayVar_ :: (Ord i, Typeable a, Show a, Eq a, Typeable i, Show i) => (ArrayVar i a) -> Nomex Bool
-isFullArrayVar_ av = do
-   md <- getMsgVarData av-   return $ and $ map isJust $ map snd $ fromJust md
-       
-   
--- | store one value and the given index. If this is the last filled element, the registered callbacks are triggered.
-putArrayVar :: (Ord i, Typeable a, Show a, Eq a, Typeable i, Show i) => (ArrayVar i a) -> i -> a -> Nomex Bool
-putArrayVar mv i a = do
-    ma <- readMsgVar mv-    case ma of-       Just ar -> do-          let ar2 = M.insert i (Just a) (fromList ar)
-          writeMsgVar mv (toList ar2)-       Nothing -> return False--putArrayVar_ :: (Ord i, Typeable a, Show a, Eq a, Typeable i, Show i) => (ArrayVar i a) -> i -> a -> Nomex ()
-putArrayVar_ mv i a = void $ putArrayVar mv i a       
-
--
-
--- * Events
-
--- | register a callback on an event
-onEvent :: (Typeable e, Show e, Eq e) => Event e -> ((EventNumber, EventData e) -> Nomex ()) -> Nomex EventNumber
-onEvent = OnEvent
-
--- | register a callback on an event, disregard the event number
-onEvent_ :: forall e. (Typeable e, Show e, Eq e) => Event e -> (EventData e -> Nomex ()) -> Nomex ()
-onEvent_ e h = do
-    OnEvent e (\(_, d) -> h d)
-    return ()
-
--- | set an handler for an event that will be triggered only once
-onEventOnce :: (Typeable e, Show e, Eq e) => Event e -> (EventData e -> Nomex ()) -> Nomex EventNumber
-onEventOnce e h = do
-    let handler (en, ed) = delEvent_ en >> h ed
-    n <- OnEvent e handler
-    return n
-
--- | set an handler for an event that will be triggered only once
-onEventOnce_ :: (Typeable e, Show e, Eq e) => Event e -> (EventData e -> Nomex ()) -> Nomex ()
-onEventOnce_ e h = do
-    let handler (en, ed) = delEvent_ en >> h ed
-    OnEvent e handler
-    return ()
-
-delEvent :: EventNumber -> Nomex Bool
-delEvent = DelEvent
-
-delEvent_ :: EventNumber -> Nomex ()
-delEvent_ e = delEvent e >> return ()
-
-delAllEvents :: (Typeable e, Show e, Eq e) => Event e -> Nomex ()
-delAllEvents = DelAllEvents
-
--- | broadcast a message that can be catched by another rule
-sendMessage :: (Typeable a, Show a, Eq a) => Msg a -> a -> Nomex ()
-sendMessage = SendMessage
-
-sendMessage_ :: Msg () -> Nomex ()
-sendMessage_ m = SendMessage m ()
-
--- | subscribe on a message 
-onMessage :: (Typeable m, Show m) => Msg m -> (MsgData m -> Nomex ()) -> Nomex ()
-onMessage m f = onEvent_ m f
-
-onMessageOnce :: (Typeable m, Show m) => Msg m -> (MsgData m -> Nomex ()) -> Nomex ()
-onMessageOnce m f = onEventOnce_ m f
-
--- | on the provided schedule, the supplied function will be called
-schedule :: (Schedule Freq) -> (UTCTime -> Nomex ()) -> Nomex ()
-schedule sched f = do
-    now <- getCurrentTime
-    let next = head $ starting now $ sched
-    if (next == now) then executeAndScheduleNext (f . timeData) sched (TimeData now)
-                     else onEventOnce_ (Time next) $ executeAndScheduleNext (f . timeData) sched where
-
-executeAndScheduleNext :: (EventData Time -> Nomex ()) -> (Schedule Freq) -> (EventData Time) -> Nomex ()
-executeAndScheduleNext f sched now = do
-   f now
-   let rest = drop 1 $ starting (timeData now) $ sched
-   when (rest /= []) $ onEventOnce_ (Time $ head rest) $ executeAndScheduleNext f sched
-
-
-schedule_ :: (Schedule Freq) -> Nomex () -> Nomex ()
-schedule_ ts f = schedule ts (\_-> f)
-
---at each time provided, the supplied function will be called
-schedule' :: [UTCTime] -> (UTCTime -> Nomex ()) -> Nomex ()
-schedule' sched f = do
-    let sched' = sort sched
-    now <- getCurrentTime
-    let nextMay = headMay $ filter (>=now) $ sched'
-    case nextMay of
-        Just next -> do
-           if (next == now) then executeAndScheduleNext' (f . timeData) sched' (TimeData now)
-                     else onEventOnce_ (Time next) $ executeAndScheduleNext' (f . timeData) sched'
-        Nothing -> return ()
-            
-
-executeAndScheduleNext' :: (EventData Time -> Nomex ()) -> [UTCTime] -> (EventData Time) -> Nomex ()
-executeAndScheduleNext' f sched now = do
-   f now
-   let rest = drop 1 $ sched
-   when (rest /= []) $ onEventOnce_ (Time $ head rest) $ executeAndScheduleNext' f sched
-   
-
-schedule'_ :: [UTCTime] -> Nomex () -> Nomex ()
-schedule'_ ts f = schedule' ts (\_-> f)
-
--- * Rule management
-
--- | activate a rule: change its state to Active and execute it
-activateRule :: RuleNumber -> Nomex Bool
-activateRule = ActivateRule
-
-activateRule_ :: RuleNumber -> Nomex ()
-activateRule_ r = activateRule r >> return ()
-
--- | reject a rule: change its state to Suppressed and suppresses all its environment (events, variables, inputs)
--- the rule can be activated again later
-rejectRule :: RuleNumber -> Nomex Bool
-rejectRule = RejectRule
-
-rejectRule_ :: RuleNumber -> Nomex ()
-rejectRule_ r = void $ rejectRule r
-
-getRules :: Nomex [Rule]
-getRules = GetRules
-
-getActiveRules :: Nomex [Rule]
-getActiveRules = return . (filter ((== Active) . _rStatus) ) =<< getRules
-
-getRule :: RuleNumber -> Nomex (Maybe Rule)
-getRule rn = do
-   rs <- GetRules
-   return $ find ((== rn) . getL rNumber) rs
-
-getRulesByNumbers :: [RuleNumber] -> Nomex [Rule]
-getRulesByNumbers rns = mapMaybeM getRule rns
-
-getRuleFuncs :: Nomex [RuleFunc]
-getRuleFuncs = return . (map _rRuleFunc) =<< getRules
-
--- | add a rule to the game, it will have to be activated 
-addRule :: Rule -> Nomex Bool
-addRule r = AddRule r
-
-addRule_ :: Rule -> Nomex ()
-addRule_ r = void $ AddRule r
-
-addRuleParams :: RuleName -> RuleFunc -> RuleCode -> String -> Nomex RuleNumber
-addRuleParams name func code desc = do-   number <- getFreeRuleNumber-   res <- addRule $ defaultRule {_rName = name, _rRuleFunc = func, _rRuleCode = code, _rNumber = number, _rDescription = desc}-   return $ if res then number else error "addRuleParams: cannot add rule"-   
--getFreeRuleNumber :: Nomex RuleNumber-getFreeRuleNumber = do-   rs <- getRules-   return $ getFreeNumber $ map _rNumber rs--
---suppresses completly a rule and its environment from the system
-suppressRule :: RuleNumber -> Nomex Bool
-suppressRule rn = RejectRule rn
-
-suppressRule_ :: RuleNumber -> Nomex ()
-suppressRule_ rn = void $ RejectRule rn
-
-suppressAllRules :: Nomex Bool
-suppressAllRules = do
-    rs <- getRules
-    res <- mapM (suppressRule . _rNumber) rs
-    return $ and res
-
-modifyRule :: RuleNumber -> Rule -> Nomex Bool
-modifyRule rn r = ModifyRule rn r
-
-
--- * Inputs
----- ** Radio inputs-
-inputRadio :: (Eq c, Show c, Typeable c) => PlayerNumber -> String -> [c] -> c -> Event (Input c)
-inputRadio pn title cs _ = InputEv (Input pn title (Radio (zip cs (show <$> cs))))
-
-inputRadioHead :: (Eq c, Show c, Typeable c) => PlayerNumber -> String -> [c] -> Event (Input c)
-inputRadioHead pn title choices = inputRadio pn title choices (head choices)
-
-inputRadioEnum :: forall c. (Enum c, Bounded c, Typeable c, Eq c,  Show c) => PlayerNumber -> String -> c -> Event (Input c)
-inputRadioEnum pn title defaultChoice = inputRadio pn title (enumFrom (minBound::c)) defaultChoice
--inputRadioData :: (Show c) => EventData (Input c) -> c-inputRadioData (InputData (RadioData a)) = a-inputRadioData a = error $ "Not a Radio Data: " ++ (show a)-
--- | triggers a choice input to the user. The result will be sent to the callback
-onInputRadio :: (Typeable a, Eq a,  Show a) => String -> [a] -> (EventNumber -> a -> Nomex ()) -> PlayerNumber -> Nomex EventNumber
-onInputRadio title choices handler pn = onEvent (inputRadioHead pn title choices) (\(en, InputData (RadioData a)) -> handler en a)
-
--- | the same, disregard the event number
-onInputRadio_ :: (Typeable a, Eq a, Show a) => String -> [a] -> (a -> Nomex ()) -> PlayerNumber -> Nomex ()
-onInputRadio_ title choices handler pn = onEvent_ (inputRadioHead pn title choices) (handler . inputRadioData)
-
--- | the same, suppress the event after first trigger
-onInputRadioOnce :: (Typeable a, Eq a, Show a) => String -> [a] -> (a -> Nomex ()) -> PlayerNumber -> Nomex EventNumber
-onInputRadioOnce title choices handler pn = onEventOnce (inputRadioHead pn title choices) (handler . inputRadioData)
-
--- | the same, disregard the event number
-onInputRadioOnce_ :: (Typeable a, Eq a, Show a) => String -> [a] -> (a -> Nomex ()) -> PlayerNumber -> Nomex ()
-onInputRadioOnce_ title choices handler pn = onEventOnce_ (inputRadioHead pn title choices) (handler . inputRadioData)
-
--- | triggers a choice input to the user, using an enumerate as input
-onInputRadioEnum :: forall a. (Enum a, Bounded a, Typeable a, Eq a,  Show a) => String -> a -> (EventNumber -> a -> Nomex ()) -> PlayerNumber -> Nomex EventNumber
-onInputRadioEnum title defaultChoice handler pn = onEvent (inputRadioEnum pn title defaultChoice) (\(en, a) -> handler en (inputRadioData a))
-
--- | the same, disregard the event number
-onInputRadioEnum_ :: forall a. (Enum a, Bounded a, Typeable a, Eq a,  Show a) => String -> a -> (a -> Nomex ()) -> PlayerNumber -> Nomex ()
-onInputRadioEnum_ title defaultChoice handler pn = onEvent_ (inputRadioEnum pn title defaultChoice) (handler . inputRadioData)
-
--- | the same, suppress the event after first trigger
-onInputRadioEnumOnce_ :: forall a. (Enum a, Bounded a, Typeable a, Eq a,  Show a) => String -> a -> (a -> Nomex ()) -> PlayerNumber -> Nomex ()
-onInputRadioEnumOnce_ title defaultChoice handler pn = onEventOnce_ (inputRadioEnum pn title defaultChoice) (handler . inputRadioData)
-
--- ** Text inputs-
-inputText :: PlayerNumber -> String -> Event (Input String)
-inputText pn title = InputEv (Input pn title Text)--inputTextData :: EventData (Input String) -> String-inputTextData (InputData (TextData a)) = a-inputTextData a = error $ "Not a Text Data: " ++ (show a)-
--- | triggers a string input to the user. The result will be sent to the callback
-onInputText :: String -> (EventNumber -> String -> Nomex ()) -> PlayerNumber -> Nomex EventNumber
-onInputText title handler pn = onEvent (inputText pn title) (\(en, a) -> handler en (inputTextData a))
-
--- | asks the player pn to answer a question, and feed the callback with this data.
-onInputText_ :: String -> (String -> Nomex ()) -> PlayerNumber -> Nomex ()
-onInputText_ title handler pn = onEvent_ (inputText pn title) (handler . inputTextData)
-
--- | asks the player pn to answer a question, and feed the callback with this data.
-onInputTextOnce_ :: String -> (String -> Nomex ()) -> PlayerNumber -> Nomex ()
-onInputTextOnce_ title handler pn = onEventOnce_ (inputText pn title) (handler . inputTextData)
---- ** Checkbox inputs--inputCheckboxData :: (Show c) => EventData (Input c) -> [c]-inputCheckboxData (InputData (CheckboxData a)) = a-inputCheckboxData a = error $ "Not a Checkbox Data: " ++ (show a)--inputCheckbox :: (Eq c, Show c, Typeable c) => PlayerNumber -> String -> [(c, String)] -> Event (Input c)
-inputCheckbox pn title cs = InputEv (Input pn title (Checkbox cs))--onInputCheckbox :: (Typeable a, Eq a,  Show a) => String -> [(a, String)] -> (EventNumber -> [a] -> Nomex ()) -> PlayerNumber -> Nomex EventNumber
-onInputCheckbox title choices handler pn = onEvent (inputCheckbox pn title choices) (\(en, InputData (CheckboxData a)) -> handler en a)--onInputCheckbox_ :: (Typeable a, Eq a,  Show a) => String -> [(a, String)] -> ([a] -> Nomex ()) -> PlayerNumber -> Nomex ()
-onInputCheckbox_ title choices handler pn = onEvent_ (inputCheckbox pn title choices) (handler . inputCheckboxData)---- ** Button inputs--inputButtonData :: EventData (Input ()) -> ()-inputButtonData (InputData ButtonData) = ()-inputButtonData a = error $ "Not a Button Data: " ++ (show a)--inputButton :: PlayerNumber -> String -> Event (Input ())
-inputButton pn title = InputEv (Input pn title Button)--onInputButton :: String -> (EventNumber -> () -> Nomex ()) -> PlayerNumber -> Nomex EventNumber
-onInputButton title handler pn = onEvent (inputButton pn title) (\(en, InputData ButtonData) -> handler en ())--onInputButton_ :: String -> (() -> Nomex ()) -> PlayerNumber -> Nomex ()
-onInputButton_ title handler pn = onEvent_ (inputButton pn title) (handler . inputButtonData)---- ** Textarea inputs--inputTextareaData :: EventData (Input String) -> String-inputTextareaData (InputData (TextAreaData a)) = a-inputTextareaData a = error $ "Not a Textarea Data: " ++ (show a)--inputTextarea :: PlayerNumber -> String -> Event (Input String)
-inputTextarea pn title = InputEv (Input pn title TextArea)--onInputTextarea :: String -> (EventNumber -> String -> Nomex ()) -> PlayerNumber -> Nomex EventNumber
-onInputTextarea title handler pn = onEvent (inputTextarea pn title) (\(en, a) -> handler en (inputTextareaData a))
-
-onInputTextarea_ :: String -> (String -> Nomex ()) -> PlayerNumber -> Nomex ()
-onInputTextarea_ title handler pn = onEvent_ (inputTextarea pn title) (handler . inputTextareaData)
-
-onInputTextareaOnce_ :: String -> (String -> Nomex ()) -> PlayerNumber -> Nomex ()
-onInputTextareaOnce_ title handler pn = onEventOnce_ (inputTextarea pn title) (handler . inputTextareaData)-
--- * Players-
--- | get all the players-getPlayers :: Nomex [PlayerInfo]
-getPlayers = GetPlayers
---- | Get a specific player-getPlayer :: PlayerNumber -> Nomex (Maybe PlayerInfo)-getPlayer pn = do-   pls <- GetPlayers
-   return $ find ((== pn) . getL playerNumber) pls---- | Set the name of a player-getPlayerName :: PlayerNumber -> Nomex (Maybe PlayerName)
-getPlayerName pn = do-  p <- getPlayer pn
-  return $ _playerName <$> p---- | Set the name of a player-setPlayerName :: PlayerNumber -> PlayerName -> Nomex Bool
-setPlayerName = SetPlayerName
--modifyPlayerName :: PlayerNumber -> (PlayerName -> PlayerName) -> Nomex Bool-modifyPlayerName pn f = do-   mn <- getPlayerName pn-   case mn of-      Just name -> setPlayerName pn (f name)-      Nothing -> return False--
--- | Get the total number of players
getPlayersNumber :: Nomex Int
-getPlayersNumber = length <$> getPlayers
---- | Get all the players number
-getAllPlayerNumbers :: Nomex [PlayerNumber]
-getAllPlayerNumbers = map _playerNumber <$> getPlayers---- | Remove the player from the game (kick)-delPlayer :: PlayerNumber -> Nomex Bool
-delPlayer = DelPlayer
---- * Outputs-
--- | outputs a message to one player
-newOutput :: String -> PlayerNumber -> Nomex OutputNumber
-newOutput s pn = NewOutput pn s
--newOutput_ :: String -> PlayerNumber -> Nomex ()
-newOutput_ s pn = void $ NewOutput pn s-
-outputAll :: String -> Nomex ()
-outputAll s = getPlayers >>= mapM_ ((newOutput s) . _playerNumber)
--updateOutput :: OutputNumber -> String -> Nomex Bool-updateOutput = UpdateOutput--updateOutput_ :: OutputNumber -> String -> Nomex ()-updateOutput_ on s = void $ updateOutput on s--delOutput :: OutputNumber -> Nomex Bool-delOutput = DelOutput--delOutput_ :: OutputNumber -> Nomex ()-delOutput_ on = void $ delOutput on---- permanently display a variable (update display when variable is updated)-displayVar :: (Typeable a, Show a, Eq a) => PlayerNumber -> MsgVar a -> (a -> String) -> Nomex ()-displayVar pn mv dis = onMsgVarEvent-   mv-   (\a -> newOutput (dis a) pn)-   (\a n -> updateOutput_ n (dis a))-   delOutput_--displaySimpleVar :: (Typeable a, Show a, Eq a) => PlayerNumber -> String -> MsgVar a -> Nomex ()-displaySimpleVar pn title mv = displayVar pn mv (\a -> title ++ ": " ++ (show a) ++ "\n")--displayArrayVar :: (Typeable a, Show a, Eq a, Typeable i, Show i, Eq i) => PlayerNumber -> String -> ArrayVar i a -> Nomex ()-displayArrayVar pn title mv = displayVar pn mv (showArrayVar title)--showArrayVar :: (Show a, Show i) => String -> [(i,a)] -> String-showArrayVar title l = title ++ "\n" ++-                      concatMap (\(i,a) -> (show i) ++ "\t" ++ (show a) ++ "\n") l-
--- * Victory, time and self-number
-
--- | set victory to a list of players
-setVictory :: [PlayerNumber] -> Nomex ()
-setVictory = SetVictory
-
--- | give victory to one player
-giveVictory :: PlayerNumber -> Nomex ()
-giveVictory pn = SetVictory [pn]
-
-getCurrentTime :: Nomex UTCTime
-getCurrentTime = CurrentTime
-
--- | allows a rule to retrieve its own number (for auto-deleting for example)
-getSelfRuleNumber :: Nomex RuleNumber
-getSelfRuleNumber = SelfRuleNumber
-
-getSelfRule :: Nomex Rule
-getSelfRule  = do
-   srn <- getSelfRuleNumber
-   rs:[] <- getRulesByNumbers [srn]
-   return rs
-
-getSelfProposedByPlayer :: Nomex PlayerNumber
-getSelfProposedByPlayer = getSelfRule >>= return . _rProposedBy
---- * Miscellaneous
-
-voidRule :: Nomex a -> Nomex RuleResp
-voidRule e = e >> return Void---instance Boolean (Nomex BoolResp) where
-  true  = return $ BoolResp True
-  false = return $ BoolResp False
-  notB  = undefined-  (||*) = undefined-  (&&*) na nb = do-     a <- na-     b <- nb-     case a of-        (BoolResp a') -> case b of-           (BoolResp b') -> return $ BoolResp $ a' && b'-           (MsgResp  b') -> andMsgBool a' b' >>= (return . MsgResp) 
-        (MsgResp a') -> case b of-           (BoolResp b') -> andMsgBool b' a' >>= (return . MsgResp)-           (MsgResp  b') -> andMsgMsg  a' b' >>= (return . MsgResp)--andMsgBool :: Bool -> (Msg Bool) -> Nomex (Msg Bool)-andMsgBool a b = do-   let m = Message ((show a) ++ " &&* " ++ (show b))
-   onMessageOnce b (f m)
-   return m where
-        f m (MessageData b1) = sendMessage m $ a && b1--andMsgMsg :: Msg Bool -> Msg Bool -> Nomex (Msg Bool)-andMsgMsg a b = do-   let m = Message ((show a) ++ " &&* " ++ (show b))
-   newArrayVarOnce ((show a) ++ ", " ++ (show b)) [1::Integer, 2] (f m)
-   return m where
-        f m (VUpdated ((_, Just a):(_, Just b):[])) = sendMessage m $ a && b-        f _ _ = return ()---partial :: String -> Nomex (Maybe a) -> Nomex a-partial s nm = do-   m <- nm-   case m of-      Just a -> return a-      Nothing -> throwError s-
-
--- | a default rule
-defaultRule = Rule  {
-    _rNumber       = 1,
-    _rName         = "",
-    _rDescription  = "",
-    _rProposedBy   = 0,
-    _rRuleCode     = "",
-    _rRuleFunc     = return Void,
-    _rStatus       = Pending,
-    _rAssessedBy   = Nothing}
+ src/Language/Nomyx/Engine.hs view
@@ -0,0 +1,51 @@++-- | Warning: Nomyx internals (not required to compose rules and play the game)+-- This module implements game engine.+-- the module manages the effects of rules over each others.+-- This module is not required+module Language.Nomyx.Engine(+   -- * Game management+   GameEvent(..),+   LoggedGame(..),+   GameName,+   Game(..),+   GameDesc(..),+   execGameEvent, execGameEvent',+   execWithGame, execWithGame',+   game,+   emptyGame,+   getLoggedGame,+   gameName,++   -- * Variables management+   Var(..),++   -- * Rules management+   SubmitRule(..),+   activeRules, pendingRules, rejectedRules,++   -- * Events management+   EventHandler(..),+   Status(..),+   getEventHandler,+   events,++   -- Inputs management+   UInputData(..),++   -- Outputs management+   Output(..),+   displayGame,+   Log(..),++   -- Time+   getTimes,+   currentTime,++   tracePN+   ) where++import Language.Nomyx.Engine.Evaluation+import Language.Nomyx.Engine.Game+import Language.Nomyx.Engine.GameEvents+import Language.Nomyx.Engine.Utils
+ src/Language/Nomyx/Engine/Evaluation.hs view
@@ -0,0 +1,354 @@+{-# LANGUAGE GADTs, NamedFieldPuns, ScopedTypeVariables #-}++module Language.Nomyx.Engine.Evaluation where++import Prelude hiding ((.), log)+import Language.Nomyx.Engine.Utils+import Control.Monad+import Control.Monad.State.Lazy+import Data.List+import Data.Typeable+import Data.Function hiding ((.))+import Data.Time+import Data.Lens+import Control.Category+import Control.Monad.Error (ErrorT(..))+import Control.Monad.Error.Class (MonadError(..))+import Control.Applicative ((<$>))+import Language.Nomyx.Expression+import Language.Nomyx.Engine.Game++type Evaluate a = ErrorT String (State Game) a++-- an untyped version of InputData for serialization+data UInputData = URadioData Int+                | UCheckboxData [Int]+                | UTextData String+                | UTextAreaData String+                | UButtonData+                  deriving (Show, Read, Eq, Ord)++-- | evaluate an expression.+-- The rule number passed is the number of the rule containing the expression.+evalExp :: Nomex a -> RuleNumber -> Evaluate a+evalExp (NewVar name def) rn = do+   vars <- access variables+   case find ((== name) . getL vName) vars of+      Nothing -> do+         variables %= ((Var rn name def) : )+         return $ Just (V name)+      Just _ -> return Nothing++evalExp (DelVar (V name)) _ = do+   vars <- access variables+   case find ((== name) . getL vName) vars of+      Nothing -> return False+      Just _ -> do+         variables %= filter ((/= name) . getL vName)+         return True++evalExp (ReadVar (V name)) _ = do+   vars <- access 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++evalExp (WriteVar (V name) val) _ = do+   vars <- access 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)+         return True++evalExp (OnEvent event handler) rn = do+   evs <- access events+   let en = getFreeNumber (map _eventNumber evs)+   events %= ((EH en rn event handler SActive) : )+   return en++evalExp (DelEvent en) _ = evDelEvent en++evalExp (DelAllEvents e) _ = do+   evs <- access events+   let filtered = filter (\EH {event} -> event === e) evs+   mapM_ (\e -> evDelEvent e) (_eventNumber <$> filtered)++evalExp (SendMessage (Message id) myData) _ = triggerEvent_ (Message id) (MessageData myData)++evalExp (NewOutput pn s)      rn = evNewOutput pn rn s+evalExp (GetOutput on)        _  = evGetOutput on+evalExp (UpdateOutput on s)   _  = evUpdateOutput on s+evalExp (DelOutput on)        _  = evDelOutput on+evalExp (ProposeRule rule)    _  = evProposeRule rule+evalExp (ActivateRule rule)   rn = evActivateRule rule rn+evalExp (RejectRule rule)     rn = evRejectRule rule rn+evalExp (AddRule rule)        _  = evAddRule rule+evalExp (ModifyRule mod rule) _  = evModifyRule mod rule+evalExp GetRules              _  = access rules+evalExp GetPlayers            _  = access players+evalExp (SetPlayerName pn n)  _  = evChangeName pn n+evalExp (DelPlayer pn)        _  = evDelPlayer pn+evalExp SelfRuleNumber        rn = return rn+evalExp (CurrentTime)         _  = access currentTime+evalExp (Return a)            _  = return a+evalExp (ThrowError s)        _  = throwError s+evalExp (CatchError n h)      rn = catchError (evalExp n rn) (\a -> evalExp (h a) rn)+evalExp (SetVictory ps)       _  = do+   victory ~= ps+   pls <- access players+   let victorious = filter (\pl -> _playerNumber pl `elem` ps) pls+   triggerEvent_ Victory (VictoryData victorious)++evalExp (Bind exp f) rn = do+   a <- evalExp exp rn+   evalExp (f a) rn+++--execute all the handlers of the specified event with the given data+triggerEvent :: (Typeable e, Show e, Eq e) => Event e -> EventData e -> Evaluate Bool+triggerEvent e dat = do+   evs <- access events+   let filtered = filter (\(EH {event, _evStatus}) -> e === event && _evStatus == SActive) (reverse evs)+   case filtered of+      [] -> return False+      xs -> do+         mapM_ (triggerHandler dat) xs+         return True+++triggerHandler :: (Typeable e, Show e, Eq e) => EventData e -> EventHandler -> Evaluate ()+triggerHandler dat (EH {_ruleNumber, _eventNumber, handler}) = case cast handler of+    Just castedH -> do+       let (exp :: Nomex ()) = castedH (_eventNumber, dat)+       (evalExp exp _ruleNumber) `catchError` (errorHandler _ruleNumber _eventNumber)+    Nothing -> logAll ("failed " ++ (show $ typeOf handler))++triggerEvent_ :: (Typeable e, Show e, Eq e) => Event e -> EventData e -> Evaluate ()+triggerEvent_ e ed = void $ triggerEvent e ed++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 -> UInputData -> Evaluate ()+triggerInput en ir = do+   evs <- access events+   let filtered = filter ((== en) . getL eventNumber) evs+   mapM_ (execInputHandler ir) filtered++-- execute the event handler using the data received from user+execInputHandler :: UInputData -> EventHandler -> Evaluate ()+execInputHandler (UTextData s)      (EH en rn (InputEv (Input _ _ Text))          h SActive) = evalExp (h (en, InputData $ TextData s)) rn+execInputHandler (UTextAreaData s)  (EH en rn (InputEv (Input _ _ TextArea))      h SActive) = evalExp (h (en, InputData $ TextAreaData s)) rn+execInputHandler (UButtonData)      (EH en rn (InputEv (Input _ _ Button))        h SActive) = evalExp (h (en, InputData $ ButtonData)) rn+execInputHandler (URadioData i)     (EH en rn (InputEv (Input _ _ (Radio cs)))    h SActive) = evalExp (h (en, InputData $ RadioData $ fst $ cs!!i)) rn+execInputHandler (UCheckboxData is) (EH en rn (InputEv (Input _ _ (Checkbox cs))) h SActive) = evalExp (h (en, InputData $ CheckboxData $ fst <$> cs `sel` is)) rn+execInputHandler _ _ = return ()++findEvent :: EventNumber -> [EventHandler] -> Maybe (EventHandler)+findEvent en evs = find ((== en) . getL eventNumber) evs++getChoiceEvents :: Evaluate [EventNumber]+getChoiceEvents = do+   evs <- access events+   return $ map _eventNumber $ filter choiceEvent evs+   where choiceEvent (EH _ _ (InputEv (Input _ _ (Radio _))) _ _) = True+         choiceEvent _ = False+++evProposeRule :: Rule -> Evaluate Bool+evProposeRule rule = do+   rs <- access rules+   case find ((== (rNumber ^$ rule)) . getL rNumber) rs of+      Nothing -> do+         rules %= (rule:)+         triggerEvent_ (RuleEv Proposed) (RuleData 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+   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+         --execute the rule+         evalExp (_rRuleFunc r) rn+         triggerEvent_ (RuleEv Activated) (RuleData r)+         return True++evRejectRule :: RuleNumber -> RuleNumber -> Evaluate Bool+evRejectRule rn by = do+   rs <- access 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+         triggerEvent_ (RuleEv Rejected) (RuleData r)+         delVarsRule rn+         delEventsRule rn+         delOutputsRule rn+         return True++evAddRule :: Rule -> Evaluate Bool+evAddRule rule = do+   rs <- access rules+   case find ((== (rNumber ^$ rule)) . getL rNumber) rs of+      Nothing -> do+         rules %= (rule:)+         triggerEvent_ (RuleEv Added) (RuleData rule)+         return True+      Just _ -> return False+++--TODO: clean and execute new rule+evModifyRule :: RuleNumber -> Rule -> Evaluate Bool+evModifyRule mod rule = do+   rs <- access rules+   let newRules = replaceWith ((== mod) . getL rNumber) rule rs+   case find ((== mod) . getL rNumber) rs of+      Nothing -> return False+      Just r ->  do+         rules ~= newRules+         triggerEvent_ (RuleEv Modified) (RuleData r)+         return True++addPlayer :: PlayerInfo -> Evaluate Bool+addPlayer pi = do+   pls <- access players+   let exists = any (((==) `on` _playerNumber) pi) pls+   when (not exists) $ do+       players %= (pi:)+       triggerEvent_ (Player Arrive) (PlayerData pi)+   return $ not exists++evDelPlayer :: PlayerNumber -> Evaluate Bool+evDelPlayer pn = do+   g <- get+   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)+         triggerEvent_ (Player Leave) (PlayerData pi)+         tracePN pn $ "leaving the game: " ++ (_gameName g)+         return True++evChangeName :: PlayerNumber -> PlayerName -> Evaluate Bool+evChangeName pn name = do+   pls <- access players+   case find ((== pn) . getL playerNumber) pls of+      Nothing -> return False+      Just _ -> do+         players ~= replaceWith ((== pn) . getL playerNumber) (PlayerInfo pn name) pls+         return True++evDelEvent :: EventNumber -> Evaluate Bool+evDelEvent en = do+   --traceM ("DelEvent: called with en=" ++ (show en))+   evs <- access events+   case find ((== en) . getL eventNumber) evs of+      Nothing -> do+         --traceM ("DelEvent: event number not found! en=" ++ (show en) ++ " rn=" ++ (show rn))+         return False+      Just eh -> do+         case (_evStatus eh) of+            SActive -> do+               --traceM ("DelEvent: deleting event en=" ++ (show en) ++ " rn=" ++ (show rn))+               let newEvents = replaceWith ((== en) . getL eventNumber) eh{_evStatus = SDeleted} evs+               events ~= newEvents+               return True+            SDeleted -> do+               --traceM ("DelEvent: Event already deleted! en=" ++ (show en) ++ "rn event=" ++ (show $ _ruleNumber eh) ++ " rn=" ++ (show rn))+               return False+++evTriggerTime :: UTCTime -> Evaluate Bool+evTriggerTime t = triggerEvent (Time t) (TimeData 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 -> String -> Evaluate OutputNumber+evNewOutput pn rn s = do+   ops <- access outputs+   let on = getFreeNumber (map _outputNumber ops)+   outputs %= ((Output on rn pn s SActive) : )+   return on++evGetOutput :: OutputNumber -> Evaluate (Maybe String)+evGetOutput on = do+   ops <- access outputs+   case find (\(Output myOn _ _ _ s) -> myOn == on && s == SActive) ops of+      Nothing -> return Nothing+      Just (Output _ _ _ o _) -> return (Just o)++evUpdateOutput :: OutputNumber -> String -> Evaluate Bool+evUpdateOutput on s = do+   ops <- access 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)+         return True++evDelOutput :: OutputNumber -> Evaluate Bool+evDelOutput on = do+   ops <- access outputs+   case find ((== on) . getL outputNumber) ops of+      Nothing -> do+         return False+      Just o -> do+         case (_oStatus o) of+            SActive -> do+               let newOutputs = replaceWith ((== on) . getL outputNumber) o{_oStatus = SDeleted} ops+               outputs ~= newOutputs+               return True+            SDeleted -> do+               return False++logPlayer :: PlayerNumber -> String -> Evaluate ()+logPlayer pn s = log (Just pn) s++logAll :: String -> Evaluate ()+logAll s = log Nothing s++log :: Maybe PlayerNumber -> String -> Evaluate ()+log mpn s = do+   time <- access currentTime+   void $ logs %= (Log mpn time s : )++runEvalError :: PlayerNumber -> Evaluate () -> State Game ()+runEvalError pn egs = do+   e <- runErrorT egs+   case e of+      Right gs -> return gs+      Left e -> do+         tracePN pn $ "Error: " ++ e+         void $ runErrorT (logPlayer pn "Error: ")
+ src/Language/Nomyx/Engine/Game.hs view
@@ -0,0 +1,161 @@+{-# LANGUAGE GADTs, TemplateHaskell, ScopedTypeVariables, NamedFieldPuns, DeriveDataTypeable #-}++-- | This module implements game engine.+module Language.Nomyx.Engine.Game where++import Prelude hiding (log)+import Data.List+import Language.Nomyx.Expression+import Language.Nomyx.Engine.Utils+import Data.Lens.Template+import Data.Time+import Data.Typeable+import GHC.Show (showList__)+import GHC.Read (readListPrecDefault, readListDefault, Read(..), lexP, parens)+import qualified Text.ParserCombinators.ReadPrec as ReadPrec (prec)+import Text.Read.Lex (Lexeme(..))+import Text.ParserCombinators.ReadPrec (reset)+import Data.Data++-- * Game++type GameName = String++-- | The state of the game:+data Game = Game { _gameName    :: GameName,+                   _gameDesc    :: GameDesc,+                   _rules       :: [Rule],+                   _players     :: [PlayerInfo],+                   _variables   :: [Var],+                   _events      :: [EventHandler],+                   _outputs     :: [Output],+                   _victory     :: [PlayerNumber],+                   _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++--Game is not serializable in its entierety. We serialize only the adequate parts.+instance Read Game where+  readPrec = parens $ ReadPrec.prec 11 $ do+     Ident "Game" <- lexP;+     Punc "{" <- lexP;+     Ident "_gameName" <- lexP;+     Punc "=" <- lexP;+     name <- reset readPrec;+     Punc "," <- lexP;+     Ident "_gameDesc" <- lexP;+     Punc "=" <- lexP;+     desc <- reset readPrec;+     Punc "," <- lexP;+     Ident "_currentTime" <- lexP;+     Punc "=" <- lexP;+     time <- reset readPrec;+     Punc "}" <- lexP;+     return $ Game name desc [] [] [] [] [] [] [] time+  readList = readListDefault+  readListPrec = readListPrecDefault++instance Show Game where+   showsPrec p(Game name desc _ _ _ _ _ _ _ time) = showParen (p >= 11) $+      showString "Game {" .+      showString "_gameName = " .+      showsPrec 0 name .+      showString ", " .+      showString "_gameDesc = " .+      showsPrec 0 desc .+      showString ", " .+      showString "_currentTime = " .+      showsPrec 0 time .+      showString "}"+   showList = showList__ (showsPrec 0)+++displayGame :: Game -> String+displayGame (Game { _gameName, _rules, _players, _variables, _events, _outputs, _victory, _currentTime}) =+        "Game Name = " ++ (show _gameName) ++ "\n Rules = " ++ (concat $ intersperse "\n " $ map show _rules) ++ "\n Players = " ++ (show _players) ++ "\n Variables = " +++        (show _variables) ++ "\n Events = " ++ (show _events) ++ "\n Outputs = " ++ (show _outputs) ++ "\n Victory = " ++ (show _victory) ++ "\n currentTime = " ++ (show _currentTime) ++ "\n"++emptyGame name desc date = Game {+    _gameName      = name,+    _gameDesc      = desc,+    _rules         = [],+    _players       = [],+    _variables     = [],+    _events        = [],+    _outputs       = [],+    _victory       = [],+    _logs          = [],+    _currentTime   = date}+++-- * Variables++-- | stores the variable's data+data Var = forall a . (Typeable a, Show a, Eq 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"++instance Eq Var where+    Var a b c == Var d e f = (a,b,c) === (d,e,f)++-- * Events++data EventHandler where+    EH :: (Typeable e, Show e, Eq e) =>+        {_eventNumber :: EventNumber,+         _ruleNumber  :: RuleNumber,+         event        :: Event e,+         handler      :: (EventNumber, EventData e) -> Nomex (),+         _evStatus    :: Status} -> EventHandler++data Status = SActive | SDeleted deriving (Eq, Show)++instance Show EventHandler where+    show (EH en rn e _ s) = (show en) ++ " " ++ (show rn) ++ " (" ++ (show e) ++"), status = " ++ (show s)++instance Eq EventHandler where+    (EH {_eventNumber=e1}) == (EH {_eventNumber=e2}) = e1 == e2++instance Ord EventHandler where+    (EH {_eventNumber=e1}) <= (EH {_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        :: String,               -- output string+                       _oStatus       :: Status}               -- status of the output+                       deriving (Eq, 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, ''EventHandler, ''Var, ''Output] )+++
+ src/Language/Nomyx/Engine/GameEvents.hs view
@@ -0,0 +1,190 @@+{-# LANGUAGE GADTs, TemplateHaskell, DoAndIfThenElse #-}++-- | This module implements the events that can affect a game.+module Language.Nomyx.Engine.GameEvents where++import Prelude hiding (log)+import Control.Monad.State+import Data.List+import Language.Nomyx.Expression+import Language.Nomyx.Engine.Evaluation+import Language.Nomyx.Engine.Game+import Language.Nomyx.Engine.Utils+import Data.Lens+import Control.Category ((>>>))+import Data.Lens.Template+import Control.Exception as E+import Control.Monad.Trans.State hiding (get)+import Data.Maybe+import Data.Time+++-- | a list of possible events affecting a game+data GameEvent = GameSettings      GameName GameDesc UTCTime+               | JoinGame          PlayerNumber PlayerName+               | LeaveGame         PlayerNumber+               | ProposeRuleEv     PlayerNumber SubmitRule+               | InputResult       PlayerNumber EventNumber UInputData+               | GLog              (Maybe PlayerNumber) String+               | TimeEvent         UTCTime+               | SystemAddRule     SubmitRule+                 deriving (Show, Read, Eq, Ord)++data TimedEvent = TimedEvent UTCTime GameEvent deriving (Show, Read, Eq, Ord)++-- | A game being non serializable, we have to store events in parralel in order to rebuild the state latter.+data LoggedGame = LoggedGame { _game :: Game,+                               _gameLog :: [TimedEvent]}+                               deriving (Read, Show)++instance Eq LoggedGame where+   (LoggedGame {_game=g1}) == (LoggedGame {_game=g2}) = g1 == g2++instance Ord LoggedGame where+   compare (LoggedGame {_game=g1}) (LoggedGame {_game=g2}) = compare g1 g2++$( makeLens ''LoggedGame)++-- | perform a game event+enactEvent :: GameEvent -> Maybe (RuleCode -> IO RuleFunc) -> StateT Game IO ()+enactEvent (GameSettings name desc date) _    = mapStateIO $ gameSettings name desc date+enactEvent (JoinGame pn name) _               = mapStateIO $ joinGame name pn+enactEvent (LeaveGame pn) _                   = mapStateIO $ leaveGame pn+enactEvent (ProposeRuleEv pn sr) (Just inter) = void $ proposeRule sr pn inter+enactEvent (InputResult pn en ir) _           = mapStateIO $ inputResult pn en ir+enactEvent (GLog mpn s) _                     = mapStateIO $ logGame s mpn+enactEvent (TimeEvent t) _                    = mapStateIO $ runEvalError 0 $ void $ evTriggerTime t+enactEvent (SystemAddRule r) (Just inter)     = systemAddRule r inter+enactEvent (ProposeRuleEv _ _) Nothing        = error "ProposeRuleEv: interpreter function needed"+enactEvent (SystemAddRule _) Nothing          = error "SystemAddRule: interpreter function needed"++enactTimedEvent :: Maybe (RuleCode -> IO RuleFunc) -> TimedEvent -> StateT Game IO ()+enactTimedEvent inter (TimedEvent t ge) = flip stateCatch updateError $ do+   currentTime ~= t+   enactEvent ge inter+   lg <- get+   lift $ evaluate lg+   return ()++updateError :: SomeException -> StateT Game IO ()+updateError e = do+   liftIO $ putStrLn $ "IO error: " ++ (show e)+   mapStateIO $ logGame ("IO error: " ++ (show e)) Nothing++execGameEvent :: GameEvent -> StateT LoggedGame IO ()+execGameEvent ge = execGameEvent' Nothing ge++execGameEvent' :: Maybe (RuleCode -> IO RuleFunc) -> GameEvent -> StateT LoggedGame IO ()+execGameEvent' inter ge = do+   t <- access $ game >>> currentTime+   let te = TimedEvent t ge+   gameLog %= \gl -> gl ++ [te]+   focus game $ enactTimedEvent inter te++getLoggedGame :: Game -> (RuleCode -> IO RuleFunc) -> [TimedEvent] -> IO LoggedGame+getLoggedGame g mInter tes = do+   let a = mapM_ (enactTimedEvent (Just mInter)) tes+   g' <- execStateT a g+   return $ LoggedGame g' tes+++-- | initialize the game.+gameSettings :: GameName -> GameDesc -> UTCTime -> State Game ()+gameSettings name desc date = do+   gameName ~= name+   gameDesc ~= desc+   currentTime ~= date+   return ()+++-- | join the game.+joinGame :: PlayerName -> PlayerNumber -> State Game ()+joinGame name pn = do+   g <- get+   case find ((== pn) . getL playerNumber) (_players g) of+      Just _ -> return ()+      Nothing -> do+         tracePN pn $ "Joining game: " ++ (_gameName g)+         let player = PlayerInfo { _playerNumber = pn, _playerName = name}+         players %= (player : )+         runEvalError pn $ triggerEvent_ (Player Arrive) (PlayerData player)+++-- | leave the game.+leaveGame :: PlayerNumber -> State Game ()+leaveGame pn = runEvalError pn $ void $ evDelPlayer pn++-- | insert a rule in pending rules.+proposeRule :: SubmitRule -> PlayerNumber -> (RuleCode -> IO RuleFunc) -> StateT Game IO ()+proposeRule sr pn inter = do+   rule <- createRule sr pn inter+   mapStateIO $ runEvalError pn $ do+      r <- evProposeRule rule+      if r == True then tracePN pn $ "Your rule has been added to pending rules."+      else tracePN pn $ "Error: Rule could not be proposed"++-- | add a rule forcefully (no votes etc.)+systemAddRule :: SubmitRule -> (RuleCode -> IO RuleFunc) -> StateT Game IO ()+systemAddRule sr inter = do+   rule <- createRule sr 0 inter+   let sysRule = (rStatus ^= Active) >>> (rAssessedBy ^= Just 0)+   rules %= (sysRule rule : )+   mapStateIO $ runEvalError 0 $ void $ evalExp (_rRuleFunc rule) (_rNumber rule)++-- | insert a log message.+logGame :: String -> (Maybe PlayerNumber) -> State Game ()+logGame s mpn = do+   time <- access currentTime+   void $ logs %= (Log mpn time s : )++-- | the user has provided an input result+inputResult :: PlayerNumber -> EventNumber -> UInputData -> State Game ()+inputResult pn en ir = do+   tracePN pn $ "input result: Event " ++ (show en) ++ ", choice " ++  (show ir)+   runEvalError pn $ triggerInput en ir+++getEventHandler :: EventNumber -> LoggedGame -> EventHandler+getEventHandler en g = fromJust $ findEvent en (_events $ _game g)+++getTimes :: EventHandler -> Maybe UTCTime+getTimes (EH _ _ (Time t) _ SActive) = Just t+getTimes _ = Nothing++-- | A helper function to use the state transformer GameState.+-- It additionally sets the current time.+execWithGame :: UTCTime -> State LoggedGame () -> LoggedGame -> LoggedGame+execWithGame t gs g = execState gs $ ((game >>> currentTime) `setL` t $ g)++execWithGame' :: UTCTime -> StateT LoggedGame IO () -> LoggedGame -> IO LoggedGame+execWithGame' t gs g = execStateT gs ((game >>> currentTime) `setL` t $ g)+++activeRules :: Game -> [Rule]+activeRules = sort . filter ((==Active) . getL rStatus) . _rules++pendingRules :: Game -> [Rule]+pendingRules = sort . filter ((==Pending) . getL rStatus) . _rules++rejectedRules :: Game -> [Rule]+rejectedRules = sort . filter ((==Reject) . getL rStatus) . _rules+++createRule :: SubmitRule -> PlayerNumber -> (RuleCode -> IO RuleFunc) -> StateT Game IO Rule+createRule (SubmitRule name desc code) pn inter = do+   rs <- access rules+   let rn = getFreeNumber $ map _rNumber rs+   rf <- lift $ inter code+   tracePN pn $ "Creating rule n=" ++ (show rn) ++ " code=" ++ code+   return $ Rule {_rNumber = rn,+                  _rName = name,+                  _rDescription = desc,+                  _rProposedBy = pn,+                  _rRuleCode = code,+                  _rRuleFunc = rf,+                  _rStatus = Pending,+                  _rAssessedBy = Nothing}+++stateCatch = liftCatch E.catch
+ src/Language/Nomyx/Engine/Test.hs view
@@ -0,0 +1,321 @@+{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable, GADTs#-}++module Language.Nomyx.Engine.Test where++import Language.Nomyx.Expression+import Language.Nomyx.Variables+import Language.Nomyx.Rules+import Language.Nomyx.Events+import Language.Nomyx.Outputs+import Language.Nomyx.Inputs+import Language.Nomyx.Vote+import Language.Nomyx.Engine.Evaluation+import Language.Nomyx.Engine.Game+import Language.Nomyx.Engine.Utils+import Control.Monad.State+import Data.Typeable+import Data.Lens+++date1 = parse822Time "Tue, 02 Sep 1997 09:00:00 -0400"+date2 = parse822Time "Tue, 02 Sep 1997 10:00:00 -0400"+date3 = parse822Time "Tue, 02 Sep 1997 11:00:00 -0400"++testGame = Game { _gameName      = "test",+                  _gameDesc      = GameDesc "test" "test",+                  _rules         = [],+                  _players       = [PlayerInfo 1 "coco"],+                  _variables     = [],+                  _events        = [],+                  _outputs       = [],+                  _victory       = [],+                  _logs          = [],+                  _currentTime   = date1}++testRule = Rule  { _rNumber       = 0,+                   _rName         = "test",+                   _rDescription  = "test",+                   _rProposedBy   = 0,+                   _rRuleCode     = "",+                   _rRuleFunc     = return Void,+                   _rStatus       = Pending,+                   _rAssessedBy   = Nothing}++evalRuleFunc f = evalState (runEvalError 0 $ evalExp f 0) testGame+execRuleFuncEvent f e d = execState (runEvalError 0 $ evalExp f 0 >> (triggerEvent_ e d)) testGame+execRuleFuncGame f g = execState (runEvalError 0 $ void $ evalExp f 0) g+execRuleFuncEventGame f e d g = execState (runEvalError 0 $ evalExp f 0 >> (triggerEvent_ e d)) g+execRuleFunc f = execRuleFuncGame f testGame++addActivateRule :: RuleFunc -> RuleNumber -> Evaluate ()+addActivateRule rf rn = do+   let rule = testRule {_rName = "testRule", _rRuleFunc = rf, _rNumber = rn, _rStatus = Pending}+   evAddRule rule+   evActivateRule (_rNumber rule) 0+   return ()++tests = [("test var 1", testVarEx1),+         ("test var 2", testVarEx2),+         ("test var 3", testVarEx3),+         ("test var 4", testVarEx4),+         ("test var 5", testVarEx5),+         ("test single input", testSingleInputEx),+         ("test multiple input", testMultipleInputsEx),+         ("test input string", testInputStringEx),+         ("test send messsage", testSendMessageEx),+         ("test send message 2", testSendMessageEx2),+         ("test user input write", testUserInputWriteEx),+         ("test activate rule", testActivateRuleEx),+         ("test auto activate", testAutoActivateEx),+         --("test meta rules vote", testApplicationMetaRuleEx),+         ("test time event", testTimeEventEx),+         ("test time event 2", testTimeEventEx2),+         ("test delete rule", testDeleteRuleEx1),+         ("test assess on vote complete 1", testVoteAssessOnVoteComplete1),+         ("test assess on vote complete 2", testVoteAssessOnVoteComplete2),+         ("test assess on every vote 1", testVoteAssessOnEveryVote1),+         ("test assess on every vote 2", testVoteAssessOnEveryVote2),+         ("test assess on every vote 3", testVoteAssessOnEveryVote3),+         ("test assess on every vote 4", testVoteAssessOnEveryVote4),+         ("test majority with", testVoteMajorityWith),+         ("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),+         ("test assess on time limit 4", testVoteAssessOnTimeLimit4),+         ("test assess on time limit 5", testVoteAssessOnTimeLimit5)]++allTests = and $ map snd tests++--Test variable creation+testVar1 :: RuleFunc+testVar1 = voidRule $ do+   NewVar "toto" (1::Integer)+   return ()++testVarEx1 = (variables ^$ execRuleFunc testVar1) == [(Var 0 "toto" (1::Integer))]++--Test variable deleting+testVar2 :: RuleFunc+testVar2 = voidRule $ do+   var <- newVar_ "toto" (1::Int)+   delVar var+   return ()++testVarEx2 = _variables (execRuleFunc testVar2) == []++--Test variable reading+testVar3 :: RuleFunc+testVar3 = voidRule $ do+   var <- newVar_ "toto" (1::Int)+   a <- readVar var+   case a of+      Just (1::Int) -> newOutput_ (return "ok") (Just 1)+      _ -> newOutput_ (return "nok") (Just 1)++testVarEx3 = isOutput "ok" (execRuleFunc testVar3)++--Test variable writing+testVar4 :: RuleFunc+testVar4 = voidRule $ do+   var <- newVar_ "toto" (1::Int)+   writeVar var (2::Int)+   a <- readVar var+   case a of+      Just (2::Int) -> newOutput_ (return "ok") (Just 1)+      _ -> newOutput_ (return "nok") (Just 1)++testVarEx4 = isOutput "ok" (execRuleFunc testVar4)++--Test variable writing+testVar5 :: RuleFunc+testVar5 = voidRule $ do+   var <- newVar_ "toto" ([]::[Int])+   writeVar var ([1]::[Int])+   a <- readVar var+   case a of+      Just (a::[Int]) -> do+         writeVar var (2:a)+         return ()+      Nothing -> newOutput_ (return "nok") (Just 1)++testVarEx5 = _variables (execRuleFunc testVar5) == [(Var 0 "toto" ([2,1]::[Int]))]++data Choice = Holland | Sarkozy deriving (Enum, Typeable, Show, Eq, Bounded)++-- Test input+testSingleInput :: RuleFunc+testSingleInput = voidRule $ do+    onInputRadioEnum_ "Vote for Holland or Sarkozy" Holland h 1 where+        h a = newOutput_ (return $ "voted for " ++ (show a)) (Just 1)++testSingleInputEx = isOutput "voted for Holland" g where+   g = execRuleFuncEvent testSingleInput (inputRadioEnum 1 "Vote for Holland or Sarkozy" Holland) (InputData (RadioData Holland))++testMultipleInputs :: RuleFunc+testMultipleInputs = voidRule $ do+    onInputCheckbox_ "Vote for Holland and Sarkozy" [(Holland, "Holland"), (Sarkozy, "Sarkozy")] h 1 where+        h a = newOutput_ (return $ "voted for " ++ (show a)) (Just 1)++testMultipleInputsEx = isOutput "voted for [Holland,Sarkozy]" g where+   g = execRuleFuncEvent testMultipleInputs (inputCheckbox 1 "Vote for Holland and Sarkozy" [(Holland, "Holland"), (Sarkozy, "Sarkozy")]) (InputData (CheckboxData [Holland, Sarkozy]))+++testInputString :: RuleFunc+testInputString = voidRule $ do+    onInputText_ "Enter a number:" h 1 where+        h a = newOutput_ (return $ "You entered: " ++ a) (Just 1)++testInputStringEx = isOutput "You entered: 1" g where+   g = execRuleFuncEvent testInputString (inputText 1 "Enter a number:") (InputData (TextData "1"))++-- Test message+testSendMessage :: RuleFunc+testSendMessage = voidRule $ do+    let msg = Message "msg" :: Event(Message String)+    onEvent_ msg f+    sendMessage msg "toto" where+        f (MessageData a :: EventData(Message String)) = newOutput_ (return a) (Just 1)++testSendMessageEx = isOutput "toto" (execRuleFunc testSendMessage)++testSendMessage2 :: RuleFunc+testSendMessage2 = voidRule $ do+    onEvent_ (Message "msg":: Event(Message ())) $ const $ newOutput_ (return "Received") (Just 1)+    sendMessage_ (Message "msg")+++testSendMessageEx2 = isOutput "Received" (execRuleFunc testSendMessage2)++data Choice2 = Me | You deriving (Enum, Typeable, Show, Eq, Bounded)++-- Test user input + variable read/write+testUserInputWrite :: RuleFunc+testUserInputWrite = voidRule $ do+    newVar_ "vote" (Nothing::Maybe Choice2)+    onEvent_ (Message "voted" :: Event (Message ())) h2+    onEvent_ (InputEv (Input 1 "Vote for" (Radio [(Me, "Me"), (You, "You")]))) h1 where+        h1 (InputData (RadioData a) :: EventData (Input Choice2)) = do+            writeVar (V "vote") (Just a)+            SendMessage (Message "voted") ()+        h1 _ = undefined+        h2 (MessageData _) = do+            a <- readVar (V "vote")+            case a of+                Just (Just Me) -> newOutput_ (return "voted Me") (Just 1)+                _ -> newOutput_ (return "problem") (Just 1)+        h2 _ = undefined++testUserInputWriteEx = isOutput "voted Me" g where+   g = execRuleFuncEvent testUserInputWrite (InputEv (Input 1 "Vote for" (Radio [(Me, "Me"), (You, "You")]))) (InputData (RadioData Me))++-- Test rule activation+testActivateRule :: RuleFunc+testActivateRule = voidRule $ do+    a <- GetRules+    if (_rStatus (head a) == Pending) then do+        ActivateRule $ _rNumber (head a)+        return ()+        else return ()+++testActivateRuleEx = _rStatus (head $ _rules (execRuleFuncGame testActivateRule testGame {_rules=[testRule]}))  == Active++testAutoActivateEx = _rStatus (head $ _rules (execRuleFuncEventGame autoActivate (RuleEv Proposed) (RuleData testRule) (testGame {_rules=[testRule]})))  == Active++--Time tests++testTimeEvent :: RuleFunc+testTimeEvent = voidRule $ do+    onEvent_ (Time date1) f where+        f _ = outputAll' $ show date1++testTimeEventEx = isOutput (show date1) g where+   g = execRuleFuncEvent testTimeEvent (Time date1) (TimeData date1)++testTimeEvent2 :: Nomex ()+testTimeEvent2 = schedule' [date1, date2] (outputAll' . show)++testTimeEventEx2 = isOutput (show date1) g && isOutput (show date2) g where+    g = flip execState testGame (runEvalError 0 $ evalExp testTimeEvent2 0 >> void gameEvs)+    gameEvs = do+        evTriggerTime date1+        evTriggerTime date2++-- Test deletes+testDeleteRule :: RuleFunc+testDeleteRule = voidRule $ do+    newVar_ "toto" (1::Int)+    onMessage (Message "msg":: Event(Message ())) (const $ return ())+    newOutput_ (return "toto") (Just 1)++testDeleteGame :: Game+testDeleteGame = flip execState testGame {_players = []} $ runEvalError 0 $ do+  addActivateRule testDeleteRule 1+  addActivateRule (voidRule $ suppressRule 1) 2++testDeleteRuleEx1 = (_rStatus $ head $ drop 1 $ _rules testDeleteGame) == Reject &&+                    (_variables testDeleteGame == []) &&+                    (_oStatus $ head $ _outputs testDeleteGame) == SDeleted &&+                    (_evStatus $ head $ _events testDeleteGame) == SDeleted+-- Test votes++voteGameActions :: Int -> Int -> Int  -> Bool -> Evaluate () -> Game+voteGameActions positives negatives total timeEvent actions = flip execState testGame {_players = []} $ runEvalError 0 $ do+    mapM_ (\x -> addPlayer (PlayerInfo x $ "coco " ++ (show x))) [1..total]+    actions+    evProposeRule testRule+    evs <- getChoiceEvents+    let pos = take positives evs+    let neg = take negatives $ drop positives evs+    mapM_ (\x -> triggerInput x (URadioData $ fromEnum For)) pos+    mapM_ (\x -> triggerInput x (URadioData $ fromEnum Against)) neg+    when timeEvent $ void $ evTriggerTime date2++voteGame' :: Int -> Int -> Int -> Bool -> RuleFunc -> Game+voteGame' positives negatives notVoted timeEvent rf  = voteGameActions positives negatives notVoted timeEvent $ addActivateRule rf 1++voteGame :: Int -> Int -> Int -> RuleFunc -> Game+voteGame positives negatives notVoted rf = voteGame' positives negatives notVoted True rf++voteGameTimed :: Int -> Int -> Int -> RuleFunc -> Game+voteGameTimed positives negatives notVoted rf = voteGame' positives negatives notVoted True rf++-- Test application meta rule+--unanimityRule = testRule {_rName = "unanimityRule", _rRuleFunc = return $ Meta $ voteWith unanimity $ assessWhenEverybodyVoted, _rNumber = 1, _rStatus = Active}+--applicationMetaRuleRule = testRule {_rName = "onRuleProposedUseMetaRules", _rRuleFunc = onRuleProposed checkWithMetarules, _rNumber = 2, _rStatus = Active}+--testApplicationMetaRuleVote :: Game+--testApplicationMetaRuleVote = voteGameActions 2 0 2 False $ do+--    evAddRule unanimityRule+--    evActivateRule (_rNumber unanimityRule) 0+--    evAddRule applicationMetaRuleRule+--    evActivateRule (_rNumber applicationMetaRuleRule) 0+--    return ()++--testApplicationMetaRuleEx = (_rStatus $ head $ _rules testApplicationMetaRuleVote) == Active++-- 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++testVoteRule s g = (_rStatus $ head $ _rules g) == s++isOutput :: String -> Game -> Bool+isOutput s g = any (\(Output _ _ _ mys SActive) -> mys == s) (_outputs g)++
+ src/Language/Nomyx/Engine/Utils.hs view
@@ -0,0 +1,52 @@+
+module Language.Nomyx.Engine.Utils where
+++import Data.Time+import Data.Typeable (cast, Typeable)+import Debug.Trace.Helpers (traceM)+import Data.Maybe (fromJust)+import System.Locale (rfc822DateFormat, defaultTimeLocale)+import Control.Monad.State+import Control.Monad.Identity+import Debug.Trace (trace)++-- | an equality that tests also the types.
+(===) :: (Typeable a, Typeable b, Eq b) => a -> b -> Bool
+(===) x y = cast x == Just y
+
+-- | Replaces all instances of a value in a list by another value.
+replaceWith :: (a -> Bool)   -- ^ Value to search
+        -> a   -- ^ Value to replace it with
+        -> [a] -- ^ Input list
+        -> [a] -- ^ Output list
+replaceWith f y = map (\z -> if f z then y else z)
++tracePN :: (Monad m ) => Int -> String -> m ()+tracePN pn s = traceM $ "Player " ++ (show pn) ++ " " ++ s++traceData :: (Show a) => String -> a -> a+traceData s a = trace (s ++ " " ++ (show a)) a+
+parse822Time :: String -> UTCTime
+parse822Time = zonedTimeToUTC
+              . fromJust
+              . parseTime defaultTimeLocale rfc822DateFormat
+
+sndMaybe :: (a, Maybe b) -> Maybe (a,b)
+sndMaybe (a, Just b) = Just (a,b)
+sndMaybe (_, Nothing) = Nothing++mapStateIO :: Show s => State s a -> StateT s IO a+mapStateIO = mapStateT $ return . runIdentity++getFreeNumber :: (Eq a, Num a, Enum a) => [a] -> a+getFreeNumber l = head [a| a <- [1..], not $ a `elem` l]+++sel :: [a]   -- ^ List of indices to select+    -> [Int] -- ^ List of elements+    -> [a]   -- ^ List composed of elements selected from original set by indices provided+sel xs is = map (\i -> xs!!i) is++
− src/Language/Nomyx/Evaluation.hs 
@@ -1,330 +0,0 @@-{-# LANGUAGE FlexibleInstances, NoMonomorphismRestriction, GADTs, NamedFieldPuns, ScopedTypeVariables, DoAndIfThenElse #-}--module Language.Nomyx.Evaluation where--import Prelude hiding ((.), log)-import Language.Nomyx.Utils-import Control.Monad-import Control.Monad.State.Lazy-import Data.List-import Data.Typeable-import Data.Function hiding ((.))-import Data.Time-import Data.Lens-import Control.Category-import Control.Monad.Error (ErrorT(..))-import Control.Monad.Error.Class (MonadError(..))-import Control.Applicative ((<$>))-import Language.Nomyx.Expression--type Evaluate a = ErrorT String (State Game) a---- | evaluate an expression.--- The rule number passed is the number of the rule containing the expression.-evalExp :: Nomex a -> RuleNumber -> Evaluate a-evalExp (NewVar name def) rn = do-   vars <- access variables-   case find ((== name) . getL vName) vars of-      Nothing -> do-         variables %= ((Var rn name def) : )-         return $ Just (V name)-      Just _ -> return Nothing--evalExp (DelVar (V name)) _ = do-   vars <- access variables-   case find ((== name) . getL vName) vars of-      Nothing -> return False-      Just _ -> do-         variables %= filter ((/= name) . getL vName)-         return True--evalExp (ReadVar (V name)) _ = do-   vars <- access 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--evalExp (WriteVar (V name) val) _ = do-   vars <- access 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)-         return True--evalExp (OnEvent event handler) rn = do-   evs <- access events-   let en = getFreeNumber (map _eventNumber evs)-   events %= ((EH en rn event handler SActive) : )-   return en--evalExp (DelEvent en) _ = evDelEvent en--evalExp (DelAllEvents e) _ = do-   evs <- access events-   let filtered = filter (\EH {event} -> event === e) evs-   mapM_ (\e -> evDelEvent e) (_eventNumber <$> filtered)--evalExp (SendMessage (Message id) myData) _ = triggerEvent_ (Message id) (MessageData myData)--evalExp (NewOutput pn s)      rn = evNewOutput pn rn s-evalExp (UpdateOutput on s) _    = evUpdateOutput on s-evalExp (DelOutput on) _         = evDelOutput on-evalExp (ProposeRule rule)    _  = evProposeRule rule-evalExp (ActivateRule rule)   rn = evActivateRule rule rn-evalExp (RejectRule rule)     rn = evRejectRule rule rn-evalExp (AddRule rule)        _  = evAddRule rule-evalExp (ModifyRule mod rule) _  = evModifyRule mod rule-evalExp GetRules              _  = access rules-evalExp GetPlayers            _  = access players-evalExp (SetPlayerName pn n)  _  = evChangeName pn n-evalExp (DelPlayer pn)        _  = evDelPlayer pn-evalExp SelfRuleNumber        rn = return rn-evalExp (CurrentTime)         _  = access currentTime-evalExp (Return a)            _  = return a-evalExp (ThrowError s)        _  = throwError s-evalExp (CatchError n h)      rn = catchError (evalExp n rn) (\a -> evalExp (h a) rn)-evalExp (SetVictory ps)       _  = do-   victory ~= ps-   pls <- access players-   let victorious = filter (\pl -> _playerNumber pl `elem` ps) pls-   triggerEvent_ Victory (VictoryData victorious)--evalExp (Bind exp f) rn = do-   a <- evalExp exp rn-   evalExp (f a) rn-----execute all the handlers of the specified event with the given data-triggerEvent :: (Typeable e, Show e, Eq e) => Event e -> EventData e -> Evaluate Bool-triggerEvent e dat = do-   evs <- access events-   let filtered = filter (\(EH {event, _evStatus}) -> e === event && _evStatus == SActive) (reverse evs)-   case filtered of-      [] -> return False-      xs -> do-         mapM_ (triggerHandler dat) xs-         return True---triggerHandler :: (Typeable e, Show e, Eq e) => EventData e -> EventHandler -> Evaluate ()-triggerHandler dat (EH {_ruleNumber, _eventNumber, handler}) = case cast handler of-    Just castedH -> do-       let (exp :: Nomex ()) = castedH (_eventNumber, dat)-       (evalExp exp _ruleNumber) `catchError` (errorHandler _ruleNumber _eventNumber)-    Nothing -> logAll ("failed " ++ (show $ typeOf handler))--triggerEvent_ :: (Typeable e, Show e, Eq e) => Event e -> EventData e -> Evaluate ()-triggerEvent_ e ed = void $ triggerEvent e ed--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 -> UInputData -> Evaluate ()-triggerInput en ir = do-   evs <- access events-   let filtered = filter ((== en) . getL eventNumber) evs-   mapM_ (execInputHandler ir) filtered---- execute the event handler using the data received from user-execInputHandler :: UInputData -> EventHandler -> Evaluate ()-execInputHandler (UTextData s)      (EH en rn (InputEv (Input _ _ Text))          h SActive) = evalExp (h (en, InputData $ TextData s)) rn-execInputHandler (UTextAreaData s)  (EH en rn (InputEv (Input _ _ TextArea))      h SActive) = evalExp (h (en, InputData $ TextAreaData s)) rn-execInputHandler (UButtonData)      (EH en rn (InputEv (Input _ _ Button))        h SActive) = evalExp (h (en, InputData $ ButtonData)) rn-execInputHandler (URadioData i)     (EH en rn (InputEv (Input _ _ (Radio cs)))    h SActive) = evalExp (h (en, InputData $ RadioData $ fst $ cs!!i)) rn-execInputHandler (UCheckboxData is) (EH en rn (InputEv (Input _ _ (Checkbox cs))) h SActive) = evalExp (h (en, InputData $ CheckboxData $ fst <$> cs `sel` is)) rn-execInputHandler _ _ = return ()--findEvent :: EventNumber -> [EventHandler] -> Maybe (EventHandler)-findEvent en evs = find ((== en) . getL eventNumber) evs--getChoiceEvents :: Evaluate [EventNumber]-getChoiceEvents = do-   evs <- access events-   return $ map _eventNumber $ filter choiceEvent evs-   where choiceEvent (EH _ _ (InputEv (Input _ _ (Radio _))) _ _) = True-         choiceEvent _ = False---evProposeRule :: Rule -> Evaluate Bool-evProposeRule rule = do-   rs <- access rules-   case find ((== (rNumber ^$ rule)) . getL rNumber) rs of-      Nothing -> do-         rules %= (rule:)-         triggerEvent_ (RuleEv Proposed) (RuleData 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-   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-         --execute the rule-         evalExp (_rRuleFunc r) rn-         triggerEvent_ (RuleEv Activated) (RuleData r)-         return True--evRejectRule :: RuleNumber -> RuleNumber -> Evaluate Bool-evRejectRule rn by = do-   rs <- access 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-         triggerEvent_ (RuleEv Rejected) (RuleData r)-         delVarsRule rn-         delEventsRule rn-         return True--evAddRule :: Rule -> Evaluate Bool-evAddRule rule = do-   rs <- access rules-   case find ((== (rNumber ^$ rule)) . getL rNumber) rs of-      Nothing -> do-         rules %= (rule:)-         triggerEvent_ (RuleEv Added) (RuleData rule)-         return True-      Just _ -> return False-----TODO: clean and execute new rule-evModifyRule :: RuleNumber -> Rule -> Evaluate Bool-evModifyRule mod rule = do-   rs <- access rules-   let newRules = replaceWith ((== mod) . getL rNumber) rule rs-   case find ((== mod) . getL rNumber) rs of-      Nothing -> return False-      Just r ->  do-         rules ~= newRules-         triggerEvent_ (RuleEv Modified) (RuleData r)-         return True--addPlayer :: PlayerInfo -> Evaluate Bool-addPlayer pi = do-   pls <- access players-   let exists = any (((==) `on` _playerNumber) pi) pls-   when (not exists) $ do-       players %= (pi:)-       triggerEvent_ (Player Arrive) (PlayerData pi)-   return $ not exists--evDelPlayer :: PlayerNumber -> Evaluate Bool-evDelPlayer pn = do-   g <- get-   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)-         triggerEvent_ (Player Leave) (PlayerData pi)-         tracePN pn $ "leaving the game: " ++ (_gameName g)-         return True--evChangeName :: PlayerNumber -> PlayerName -> Evaluate Bool-evChangeName pn name = do-   pls <- access players-   case find ((== pn) . getL playerNumber) pls of-      Nothing -> return False-      Just _ -> do-         players ~= replaceWith ((== pn) . getL playerNumber) (PlayerInfo pn name) pls-         return True--evDelEvent :: EventNumber -> Evaluate Bool-evDelEvent en = do-   --traceM ("DelEvent: called with en=" ++ (show en))-   evs <- access events-   case find ((== en) . getL eventNumber) evs of-      Nothing -> do-         --traceM ("DelEvent: event number not found! en=" ++ (show en) ++ " rn=" ++ (show rn))-         return False-      Just eh -> do-         case (_evStatus eh) of-            SActive -> do-               --traceM ("DelEvent: deleting event en=" ++ (show en) ++ " rn=" ++ (show rn))-               let newEvents = replaceWith ((== en) . getL eventNumber) eh{_evStatus = SDeleted} evs-               events ~= newEvents-               return True-            SDeleted -> do-               --traceM ("DelEvent: Event already deleted! en=" ++ (show en) ++ "rn event=" ++ (show $ _ruleNumber eh) ++ " rn=" ++ (show rn))-               return False---evTriggerTime :: UTCTime -> Evaluate Bool-evTriggerTime t = triggerEvent (Time t) (TimeData 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---evNewOutput :: PlayerNumber -> RuleNumber -> String -> Evaluate OutputNumber-evNewOutput pn rn s = do-   ops <- access outputs-   let on = getFreeNumber (map _outputNumber ops)-   outputs %= ((Output on rn pn s SActive) : )-   return on--evUpdateOutput :: OutputNumber -> String -> Evaluate Bool-evUpdateOutput on s = do-   ops <- access 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)-         return True--evDelOutput :: OutputNumber -> Evaluate Bool-evDelOutput on = do-   ops <- access outputs-   case find ((== on) . getL outputNumber) ops of-      Nothing -> do-         return False-      Just o -> do-         case (_oStatus o) of-            SActive -> do-               let newOutputs = replaceWith ((== on) . getL outputNumber) o{_oStatus = SDeleted} ops-               outputs ~= newOutputs-               return True-            SDeleted -> do-               return False--logPlayer :: PlayerNumber -> String -> Evaluate ()-logPlayer pn s = log (Just pn) s--logAll :: String -> Evaluate ()-logAll s = log Nothing s--log :: Maybe PlayerNumber -> String -> Evaluate ()-log mpn s = do-   time <- access currentTime-   void $ logs %= (Log mpn time s : )---runEvalError :: PlayerNumber -> Evaluate () -> State Game ()-runEvalError pn egs = do-   e <- runErrorT egs-   case e of-      Right gs -> return gs-      Left e -> do-         tracePN pn $ "Error: " ++ e-         void $ runErrorT (logPlayer pn "Error: ")
+ src/Language/Nomyx/Events.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE ScopedTypeVariables #-}+
+-- | All the building blocks to allow rules to build events.
+module Language.Nomyx.Events where+--   Event(..),+--   EventNumber,+--   EventData(..),+--   InputData(..),+--   Msg,+--   MsgData,+--   onEvent, onEvent_,
+--   onEventOnce, onEventOnce_,
+--   delEvent, delEvent_, delAllEvents,
+--   sendMessage, sendMessage_,
+--   onMessage, onMessageOnce,
+--   schedule, schedule_, schedule', schedule'_,
+--   getCurrentTime,+--   oneWeek, oneDay, oneHour, oneMinute,+
+import Language.Nomyx.Expression+import Data.Typeable
+import Control.Monad.State
+import Data.List
+import Data.Time hiding (getCurrentTime)
+import Data.Time.Recurrence hiding (filter)
+import Safe
++
+-- * Events
+
+-- | register a callback on an event
+onEvent :: (Typeable e, Show e, Eq e) => Event e -> ((EventNumber, EventData e) -> Nomex ()) -> Nomex EventNumber
+onEvent = OnEvent
+
+-- | register a callback on an event, disregard the event number
+onEvent_ :: forall e. (Typeable e, Show e, Eq e) => Event e -> (EventData e -> Nomex ()) -> Nomex ()
+onEvent_ e h = do
+    OnEvent e (\(_, d) -> h d)
+    return ()
+
+-- | set an handler for an event that will be triggered only once
+onEventOnce :: (Typeable e, Show e, Eq e) => Event e -> (EventData e -> Nomex ()) -> Nomex EventNumber
+onEventOnce e h = do
+    let handler (en, ed) = delEvent_ en >> h ed
+    n <- OnEvent e handler
+    return n
+
+-- | set an handler for an event that will be triggered only once
+onEventOnce_ :: (Typeable e, Show e, Eq e) => Event e -> (EventData e -> Nomex ()) -> Nomex ()
+onEventOnce_ e h = do
+    let handler (en, ed) = delEvent_ en >> h ed
+    OnEvent e handler
+    return ()
+
+delEvent :: EventNumber -> Nomex Bool
+delEvent = DelEvent
+
+delEvent_ :: EventNumber -> Nomex ()
+delEvent_ e = delEvent e >> return ()
+
+delAllEvents :: (Typeable e, Show e, Eq e) => Event e -> Nomex ()
+delAllEvents = DelAllEvents
+
+-- | broadcast a message that can be catched by another rule
+sendMessage :: (Typeable a, Show a, Eq a) => Msg a -> a -> Nomex ()
+sendMessage = SendMessage
+
+sendMessage_ :: Msg () -> Nomex ()
+sendMessage_ m = SendMessage m ()
+
+-- | subscribe on a message 
+onMessage :: (Typeable m, Show m) => Msg m -> (MsgData m -> Nomex ()) -> Nomex ()
+onMessage m f = onEvent_ m f
+
+onMessageOnce :: (Typeable m, Show m) => Msg m -> (MsgData m -> Nomex ()) -> Nomex ()
+onMessageOnce m f = onEventOnce_ m f
+
+-- | on the provided schedule, the supplied function will be called
+schedule :: (Schedule Freq) -> (UTCTime -> Nomex ()) -> Nomex ()
+schedule sched f = do
+    now <- getCurrentTime
+    let next = head $ starting now $ sched
+    if (next == now) then executeAndScheduleNext (f . timeData) sched (TimeData now)
+                     else onEventOnce_ (Time next) $ executeAndScheduleNext (f . timeData) sched where
+
+executeAndScheduleNext :: (EventData Time -> Nomex ()) -> (Schedule Freq) -> (EventData Time) -> Nomex ()
+executeAndScheduleNext f sched now = do
+   f now
+   let rest = drop 1 $ starting (timeData now) $ sched
+   when (rest /= []) $ onEventOnce_ (Time $ head rest) $ executeAndScheduleNext f sched
+
+
+schedule_ :: (Schedule Freq) -> Nomex () -> Nomex ()
+schedule_ ts f = schedule ts (\_-> f)
+
+--at each time provided, the supplied function will be called
+schedule' :: [UTCTime] -> (UTCTime -> Nomex ()) -> Nomex ()
+schedule' sched f = do
+    let sched' = sort sched
+    now <- getCurrentTime
+    let nextMay = headMay $ filter (>=now) $ sched'
+    case nextMay of
+        Just next -> do
+           if (next == now) then executeAndScheduleNext' (f . timeData) sched' (TimeData now)
+                     else onEventOnce_ (Time next) $ executeAndScheduleNext' (f . timeData) sched'
+        Nothing -> return ()
+            
+
+executeAndScheduleNext' :: (EventData Time -> Nomex ()) -> [UTCTime] -> (EventData Time) -> Nomex ()
+executeAndScheduleNext' f sched now = do
+   f now
+   let rest = drop 1 $ sched
+   when (rest /= []) $ onEventOnce_ (Time $ head rest) $ executeAndScheduleNext' f sched
+   
+
+schedule'_ :: [UTCTime] -> Nomex () -> Nomex ()
+schedule'_ ts f = schedule' ts (\_-> f)
+
+getCurrentTime :: Nomex UTCTime
+getCurrentTime = CurrentTime++-- | durations+oneWeek, oneDay, oneHour, oneMinute :: NominalDiffTime
+oneWeek = 7 * oneDay+oneDay = 24 * oneHour+oneHour = 60 * oneMinute+oneMinute = 60
src/Language/Nomyx/Examples.hs view
@@ -1,5 +1,4 @@-{-# LANGUAGE TupleSections, GADTs, EmptyDataDecls, TypeFamilies, DeriveDataTypeable,-    ScopedTypeVariables, TypeSynonymInstances #-}+{-# LANGUAGE GADTs, DeriveDataTypeable #-}  -- | This file gives a list of example rules that the players can submit. --You can copy-paste them in the field "Code" of the web GUI.@@ -11,18 +10,15 @@     enterHaiku, displayBankAccount,     module Data.Time.Recurrence, module Control.Monad, module Data.List, module Data.Time.Clock) where -import Language.Nomyx.Definition-import Language.Nomyx.Rule-import Language.Nomyx.Expression-import Language.Nomyx.Vote+import Language.Nomyx import Data.Function import Data.Time.Clock hiding (getCurrentTime) import Data.Time.Recurrence hiding (filter) import Control.Arrow import Data.List import Control.Monad-import Language.Nomyx.Utils (oneDay) import Safe (readDef)+import Data.Typeable  -- | A rule that does nothing nothing :: RuleFunc@@ -30,7 +26,7 @@  -- | A rule that says hello to all players helloWorld :: RuleFunc-helloWorld = voidRule $ outputAll "hello, world!"+helloWorld = voidRule $ outputAll' "hello, world!"  -- | account variable name and type accounts :: MsgVar [(PlayerNumber, Int)]@@ -42,8 +38,16 @@  -- | Permanently display the bank accounts displayBankAccount :: RuleFunc-displayBankAccount = voidRule $ forEachPlayer_ displayPlayerAccount+displayBankAccount = voidRule $ do+   let displayOneAccount (account_pn, a) = do+        name <- showPlayer account_pn+        return $ name ++ "\t" ++ (show a) ++ "\n"+   let displayAccounts l = do+        d <- concatMapM displayOneAccount l+        return $ "Accounts:\n" ++ d+   displayVar Nothing accounts displayAccounts + -- | each player wins X Ecu each day -- you can also try with "minutly" or "monthly" instead of "daily" and everything in the "time-recurrence" package winXEcuPerDay :: Int -> RuleFunc@@ -64,8 +68,8 @@        transfer src dst amount = do            modifyValueOfPlayer dst accounts (\a -> a + (readDef 0 amount))            modifyValueOfPlayer src accounts (\a -> a - (readDef 0 amount))-           newOutput_ ("You gave " ++ amount ++ " ecus to player " ++ show dst) src-           newOutput_ ("Player " ++ show src ++ " gaved you " ++ amount ++ "ecus") dst+           newOutput_ (return $ "You gave " ++ amount ++ " ecus to player " ++ show dst) (Just src)+           newOutput_ (return $ "Player " ++ show src ++ " gaved you " ++ amount ++ "ecus") (Just dst)   -- | delete a rule@@ -76,16 +80,16 @@ -- and we prefix his name with "King" makeKing :: PlayerNumber -> RuleFunc makeKing pn = voidRule $ do-   voidRule $ newVar_ "King" pn+   voidRule $ newMsgVar_ "King" pn    modifyPlayerName pn ("King " ++) -king :: V PlayerNumber-king = V "King"+king :: MsgVar PlayerNumber+king = msgVar "King"  -- | Monarchy: only the king decides which rules to accept or reject monarchy :: RuleFunc monarchy = voidRule $ onEvent_ (RuleEv Proposed) $ \(RuleData rule) -> do-    k <- readVar_ king+    k <- readMsgVar_ king     onInputRadioEnumOnce_ ("Your Royal Highness, do you accept rule " ++ (show $ _rNumber rule) ++ "?") True (activateOrReject rule) k  @@ -117,7 +121,7 @@ displayTime :: RuleFunc displayTime = voidRule $ do     t <- getCurrentTime-    onEventOnce_ (Time $ addUTCTime 5 t) $ \(TimeData t) -> outputAll $ show t+    onEventOnce_ (Time $ addUTCTime 5 t) $ \(TimeData t) -> outputAll' $ show t  -- | Only one player can achieve victory: No group victory. -- Forbidding group victory usually becomes necessary when lowering the voting quorum:@@ -165,20 +169,41 @@  makeGM :: PlayerNumber -> Nomex() makeGM pn = do-   newVar "GameMaster" pn+   newMsgVar "GameMaster" pn    void $ modifyPlayerName pn ("GameMaster " ++) -gameMaster :: V PlayerNumber-gameMaster = V "GameMaster"+gameMaster :: MsgVar PlayerNumber+gameMaster =msgVar "GameMaster"  -- | display a button and greets you when pressed (for player 1) bravoButton :: RuleFunc-bravoButton = voidRule $ voidRule $ onInputButton_ "Click here:" (const $ outputAll "Bravo!") 1+bravoButton = voidRule $ voidRule $ onInputButton_ "Click here:" (const $ outputAll' "Bravo!") 1  enterHaiku :: RuleFunc-enterHaiku = voidRule $ onInputTextarea_ "Enter a haiku:" outputAll 1+enterHaiku = voidRule $ onInputTextarea_ "Enter a haiku:" outputAll' 1 -displayPlayerAccount :: PlayerNumber -> Nomex ()-displayPlayerAccount pn = do-   sp <- showPlayer-   displayVar pn accounts (\l -> "Accounts:\n" ++ concatMap (\(i,a) -> (sp i) ++ "\t" ++ (show a) ++ "\n") l)+tournamentMasterCandidates :: RuleFunc+tournamentMasterCandidates = voidRule $ do+   let tournamentMasterCandidates = msgVar "tournamentMasterCandidates" :: MsgVar [PlayerNumber]+   let candidate pn = void $ modifyMsgVar tournamentMasterCandidates (pn : )+   let displayCandidates pns = return $ "Candidates for the election of Tournament Master: Players #" ++ (concat $ intersperse ", " $ map show pns)+   newMsgVar_ (getMsgVarName tournamentMasterCandidates) ([] :: [PlayerNumber])+   forEachPlayer_ (\pn -> onInputButtonOnce_ "I am candidate for the next Tournament Master elections " (const $ candidate pn) pn)+   displayVar Nothing tournamentMasterCandidates displayCandidates++-- | castle structure+data Castle = Castle { towers :: Int, dungeon :: Bool }+              deriving (Typeable, Show, Eq)++castles :: MsgVar [(PlayerNumber, Castle)]+castles = msgVar "Castles"++castleVictory :: RuleFunc+castleVictory = voidRule $ do+  let checkVict cs = do+       let vict = map fst $ filter ((== (Castle 4 True)) . snd) cs+       when (length vict > 0) $ setVictory vict+  onMsgVarChange castles $ (\(VUpdated cs) -> checkVict cs)++concatMapM        :: (Monad m) => (a -> m [b]) -> [a] -> m [b]+concatMapM f xs   =  liftM concat (mapM f xs)
src/Language/Nomyx/Expression.hs view
@@ -1,10 +1,5 @@-
-{-# LANGUAGE NoMonomorphismRestriction, FlexibleInstances, GADTs,
-    UndecidableInstances, DeriveDataTypeable, FlexibleContexts,
-    GeneralizedNewtypeDeriving, MultiParamTypeClasses, TypeFamilies,
-    TypeSynonymInstances, TemplateHaskell, ExistentialQuantification,
-    TypeFamilies, ScopedTypeVariables, StandaloneDeriving, NamedFieldPuns,
-    EmptyDataDecls, QuasiQuotes #-}
+{-# LANGUAGE FlexibleInstances, GADTs, DeriveDataTypeable, MultiParamTypeClasses, 
+    TemplateHaskell, ScopedTypeVariables, StandaloneDeriving, NamedFieldPuns, EmptyDataDecls #-}
 
 -- | This module containt the type definitions necessary to build a Nomic rule. 
 module Language.Nomyx.Expression where
@@ -13,15 +8,7 @@ import Data.Time
 import Control.Applicative hiding (Const)
 import Data.Lens.Template
-import Data.Data (Data)-import GHC.Read (readListPrecDefault, readListDefault, Read(..), lexP, parens)-import qualified Text.ParserCombinators.ReadPrec as ReadPrec (prec)-import Text.Read.Lex (Lexeme(..))-import Text.ParserCombinators.ReadPrec (reset)-import GHC.Show (showList__) import Control.Monad.Error-import Language.Nomyx.Utils ((===))-import Data.List (intersperse) 
 type PlayerNumber = Int
 type PlayerName = String
@@ -33,51 +20,49 @@ type EventNumber = Int
 type EventName = String
 type VarName = String
-type GameName = String
 type Code = String type OutputNumber = Int 
-
 -- * Nomyx Expression
 
 -- | A Nomex (Nomyx Expression) allows the players to write rules.--- | within the rules, you can access and modify the state of the game.
--- | It is a compositional algebra defined with a GADT.
+-- within the rules, you can access and modify the state of the game.
 data Nomex a where
    --Variable management-   NewVar       :: (Typeable a, Show a, Eq a) => VarName           -> a              -> Nomex (Maybe (V a))
-   ReadVar      :: (Typeable a, Show a, Eq a) => (V a)             -> Nomex (Maybe a)
-   WriteVar     :: (Typeable a, Show a, Eq a) => (V a)             -> a              -> Nomex Bool
-   DelVar       ::                               (V a)             -> Nomex Bool
+   NewVar         :: (Typeable a, Show a, Eq a) => VarName -> a -> Nomex (Maybe (V a))
+   ReadVar        :: (Typeable a, Show a, Eq a) => (V a) -> Nomex (Maybe a)
+   WriteVar       :: (Typeable a, Show a, Eq a) => (V a) -> a -> Nomex Bool
+   DelVar         ::                               (V a) -> Nomex Bool
    --Events management-   OnEvent      :: (Typeable e, Show e, Eq e) => Event e           -> ((EventNumber, EventData e) -> Nomex ()) -> Nomex EventNumber
-   DelEvent     ::                               EventNumber       -> Nomex Bool
-   DelAllEvents :: (Typeable e, Show e, Eq e) => Event e           -> Nomex ()
-   SendMessage  :: (Typeable a, Show a, Eq a) => Event (Message a) -> a              -> Nomex ()
+   OnEvent        :: (Typeable e, Show e, Eq e) => Event e -> ((EventNumber, EventData e) -> Nomex ()) -> Nomex EventNumber
+   DelEvent       :: EventNumber -> Nomex Bool
+   DelAllEvents   :: (Typeable e, Show e, Eq e) => Event e -> Nomex ()
+   SendMessage    :: (Typeable a, Show a, Eq a) => Event (Message a) -> a -> Nomex ()
    --Rules management
-   ProposeRule  ::                               Rule              -> Nomex Bool
-   ActivateRule ::                               RuleNumber        -> Nomex Bool
-   RejectRule   ::                               RuleNumber        -> Nomex Bool
-   AddRule      ::                               Rule              -> Nomex Bool
-   ModifyRule   ::                               RuleNumber        -> Rule           -> Nomex Bool
-   GetRules     ::                               Nomex [Rule]
+   ProposeRule    :: Rule -> Nomex Bool
+   ActivateRule   :: RuleNumber -> Nomex Bool
+   RejectRule     :: RuleNumber -> Nomex Bool
+   AddRule        :: Rule -> Nomex Bool
+   ModifyRule     :: RuleNumber -> Rule -> Nomex Bool
+   GetRules       :: Nomex [Rule]
    --Players management-   GetPlayers   ::                               Nomex [PlayerInfo]-   SetPlayerName::                               PlayerNumber      -> PlayerName     -> Nomex Bool-   DelPlayer    ::                               PlayerNumber      -> Nomex Bool+   GetPlayers     :: Nomex [PlayerInfo]+   SetPlayerName  :: PlayerNumber -> PlayerName -> Nomex Bool+   DelPlayer      :: PlayerNumber -> Nomex Bool    --Output-   NewOutput    ::                               PlayerNumber      -> String         -> Nomex OutputNumber-   UpdateOutput ::                               OutputNumber      -> String         -> Nomex Bool-   DelOutput    ::                               OutputNumber      -> Nomex Bool+   NewOutput      :: (Maybe PlayerNumber) -> String -> Nomex OutputNumber+   GetOutput      :: OutputNumber -> Nomex (Maybe String)+   UpdateOutput   :: OutputNumber -> String -> Nomex Bool+   DelOutput      :: OutputNumber -> Nomex Bool    --Mileacenous-   SetVictory   ::                               [PlayerNumber]    -> Nomex ()
-   CurrentTime  ::                               Nomex UTCTime
-   SelfRuleNumber ::                             Nomex RuleNumber+   SetVictory     :: [PlayerNumber] -> Nomex ()
+   CurrentTime    :: Nomex UTCTime
+   SelfRuleNumber :: Nomex RuleNumber    --Monadic bindings-   Return       ::                               a                 -> Nomex a
-   Bind         ::                               Nomex a           -> (a -> Nomex b) -> Nomex b-   ThrowError   ::                               String            -> Nomex a-   CatchError   ::                               Nomex a           -> (String -> Nomex a) -> Nomex a
+   Return         :: a -> Nomex a
+   Bind           :: Nomex a -> (a -> Nomex b) -> Nomex b+   ThrowError     :: String -> Nomex a+   CatchError     :: Nomex a -> (String -> Nomex a) -> Nomex a
    deriving (Typeable)
      
 instance Monad Nomex where
@@ -107,18 +92,6 @@ -- | a container for a variable name and type
 data V a = V {varName :: String} deriving (Typeable)
 
--- | stores the variable's data
-data Var = forall a . (Typeable a, Show a, Eq 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"
-
-instance Eq Var where
-    Var a b c == Var d e f = (a,b,c) === (d,e,f)
-
 -- * Events
 
 -- | events types
@@ -150,13 +123,7 @@                  | TextData String                  | TextAreaData String                  | ButtonData--- an untyped version of InputData for serialization-data UInputData = URadioData Int-                | UCheckboxData [Int]-                | UTextData String-                | UTextAreaData String-                | UButtonData-                  deriving (Show, Read, Eq, Ord)+                   
 -- | data associated with each events
 data EventData a where
@@ -187,43 +154,9 @@ deriving instance (Eq e) =>   Eq        (Input e) deriving instance (Eq e) =>   Eq        (InputForm e)
 
-data Status = SActive | SDeleted deriving (Eq, Show) -data EventHandler where
-    EH :: (Typeable e, Show e, Eq e) =>
-        {_eventNumber :: EventNumber,
-         _ruleNumber  :: RuleNumber,
-         event        :: Event e,
-         handler      :: (EventNumber, EventData e) -> Nomex (),-         _evStatus    :: Status} -> EventHandler
-
-instance Show EventHandler where
-    show (EH en rn e _ _) = (show en) ++ " " ++ (show rn) ++ " (" ++ (show e) ++"),\n"
-
-instance Eq EventHandler where
-    (EH {_eventNumber=e1}) == (EH {_eventNumber=e2}) = e1 == e2
-
-instance Ord EventHandler where
-    (EH {_eventNumber=e1}) <= (EH {_eventNumber=e2}) = e1 <= e2
- type Msg a = Event (Message a) type MsgData a = EventData (Message a)---- * Outputs--data Output = Output { _outputNumber  :: OutputNumber,-                       _oRuleNumber   :: PlayerNumber,-                       _oPlayerNumber :: PlayerNumber,-                       _output        :: String,-                       _oStatus       :: Status}-                         deriving (Show)---- * Logs--data Log = Log { _lPlayerNumber :: Maybe PlayerNumber,-                 _lTime         :: UTCTime,-                 _lMsg          :: String}-                 deriving (Show) 
 -- * Rule
 
@@ -265,10 +198,7 @@                 | Pending     -- Proposed rules
                 | Reject      -- Rejected rules
                 deriving (Eq, Show, Typeable)-                
-data SubmitRule = SubmitRule RuleName RuleDesc RuleCode deriving (Show, Read, Eq, Ord, Data, Typeable)--
+          
 -- * Player
 
 -- | informations on players
@@ -276,70 +206,16 @@                                _playerName   :: String}
                                deriving (Eq, Typeable, Show)
 
--- * Game+instance Ord PlayerInfo where+   h <= g = (_playerNumber h) <= (_playerNumber g) -           
--- | The state of the game:
-data Game = Game { _gameName    :: GameName,
-                   _gameDesc    :: GameDesc,
-                   _rules       :: [Rule],
-                   _players     :: [PlayerInfo],
-                   _variables   :: [Var],
-                   _events      :: [EventHandler],
-                   _outputs     :: [Output],
-                   _victory     :: [PlayerNumber],-                   _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 ---Game is not serializable in its entierety. We serialize only the adequate parts.   
-instance Read Game where-  readPrec = parens $ ReadPrec.prec 11 $ do-     Ident "Game" <- lexP;-     Punc "{" <- lexP;-     Ident "_gameName" <- lexP;-     Punc "=" <- lexP;-     name <- reset readPrec;-     Punc "," <- lexP;-     Ident "_gameDesc" <- lexP;-     Punc "=" <- lexP;-     desc <- reset readPrec;-     Punc "," <- lexP;-     Ident "_currentTime" <- lexP;-     Punc "=" <- lexP;-     time <- reset readPrec;-     Punc "}" <- lexP;-     return $ Game name desc [] [] [] [] [] [] [] time-  readList = readListDefault-  readListPrec = readListPrecDefault-
-instance Show Game where-   showsPrec p(Game name desc _ _ _ _ _ _ _ time) = showParen (p >= 11) $-      showString "Game {" .-      showString "_gameName = " .-      showsPrec 0 name .-      showString ", " .-      showString "_gameDesc = " .-      showsPrec 0 desc .-      showString ", " .-      showString "_currentTime = " .-      showsPrec 0 time .-      showString "}"-   showList = showList__ (showsPrec 0)--displayGame :: Game -> String-displayGame (Game { _gameName, _rules, _players, _variables, _events, _outputs, _victory, _currentTime}) =
-        "Game Name = " ++ (show _gameName) ++ "\n Rules = " ++ (concat $ intersperse "\n " $ map show _rules) ++ "\n Players = " ++ (show _players) ++ "\n Variables = " ++
-        (show _variables) ++ "\n Events = " ++ (show _events) ++ "\n Outputs = " ++ (show _outputs) ++ "\n Victory = " ++ (show _victory) ++ "\n currentTime = " ++ (show _currentTime) ++ "\n"
+partial :: String -> Nomex (Maybe a) -> Nomex a+partial s nm = do+   m <- nm+   case m of+      Just a -> return a+      Nothing -> throwError s 
-$( makeLenses [''Game, ''GameDesc, ''Rule, ''PlayerInfo, ''EventHandler, ''Var, ''Output] )
+$( makeLenses [''Rule, ''PlayerInfo] )
− src/Language/Nomyx/Game.hs 
@@ -1,198 +0,0 @@-{-# LANGUAGE StandaloneDeriving, GADTs, DeriveDataTypeable,-    FlexibleContexts, GeneralizedNewtypeDeriving, ScopedTypeVariables,-    MultiParamTypeClasses, TemplateHaskell, TypeFamilies,-    TypeOperators, FlexibleInstances, NoMonomorphismRestriction,-    TypeSynonymInstances, DoAndIfThenElse, RecordWildCards #-}---- | This module implements Game management.--- a game is a set of rules, and results of actions made by players (usually vote results)--- the module manages the effects of rules over each others.-module Language.Nomyx.Game (GameEvent(..), update, update', LoggedGame(..), game, gameLog, emptyGame,-  execWithGame, execWithGame', getLoggedGame, tracePN, getTimes, activeRules, pendingRules,-  rejectedRules, UInputData(..))  where--import Prelude hiding (log)-import Control.Monad.State-import Data.List-import Language.Nomyx hiding (outputAll)-import Data.Lens-import Control.Category ((>>>))-import Data.Lens.Template-import Control.Exception as E-import Control.Monad.Trans.State hiding (get)--data TimedEvent = TimedEvent UTCTime GameEvent deriving (Show, Read, Eq, Ord)--data GameEvent = GameSettings      GameName GameDesc UTCTime-               | JoinGame          PlayerNumber PlayerName-               | LeaveGame         PlayerNumber-               | ProposeRuleEv     PlayerNumber SubmitRule-               | InputResult       PlayerNumber EventNumber UInputData-               | GLog              (Maybe PlayerNumber) String-               | TimeEvent         UTCTime-               | SystemAddRule     SubmitRule-                 deriving (Show, Read, Eq, Ord)----A game being non serializable, we have to store events in parralel in order to rebuild the state latter.-data LoggedGame = LoggedGame { _game :: Game,-                               _gameLog :: [TimedEvent]}-                               deriving (Read, Show)--instance Eq LoggedGame where
-   (LoggedGame {_game=g1}) == (LoggedGame {_game=g2}) = g1 == g2
-
-instance Ord LoggedGame where
-   compare (LoggedGame {_game=g1}) (LoggedGame {_game=g2}) = compare g1 g2---emptyGame name desc date = Game {-    _gameName      = name,-    _gameDesc      = desc,-    _rules         = [],-    _players       = [],-    _variables     = [],-    _events        = [],-    _outputs       = [],-    _victory       = [],-    _logs          = [],-    _currentTime   = date}--$( makeLens ''LoggedGame)----TODO: get rid of inter param?-enactEvent :: GameEvent -> Maybe (RuleCode -> IO RuleFunc) -> StateT Game IO ()-enactEvent (GameSettings name desc date) _    = mapStateIO $ gameSettings name desc date-enactEvent (JoinGame pn name) _               = mapStateIO $ joinGame name pn-enactEvent (LeaveGame pn) _                   = mapStateIO $ leaveGame pn-enactEvent (ProposeRuleEv pn sr) (Just inter) = void $ proposeRule sr pn inter-enactEvent (InputResult pn en ir) _           = mapStateIO $ inputResult pn en ir-enactEvent (GLog mpn s) _                     = mapStateIO $ logGame s mpn-enactEvent (TimeEvent t) _                    = mapStateIO $ runEvalError 0 $ void $ evTriggerTime t-enactEvent (SystemAddRule r) (Just inter)     = systemAddRule r inter-enactEvent (ProposeRuleEv _ _) Nothing        = error "ProposeRuleEv: interpreter function needed"-enactEvent (SystemAddRule _) Nothing          = error "SystemAddRule: interpreter function needed"--enactTimedEvent :: Maybe (RuleCode -> IO RuleFunc) -> TimedEvent -> StateT Game IO ()-enactTimedEvent inter (TimedEvent t ge) = flip stateCatch updateError $ do-   currentTime ~= t-   enactEvent ge inter-   lg <- get-   lift $ evaluate lg-   return ()--updateError :: SomeException -> StateT Game IO ()-updateError e = do-   liftIO $ putStrLn $ "IO error: " ++ (show e)-   mapStateIO $ logGame ("IO error: " ++ (show e)) Nothing--update :: GameEvent -> StateT LoggedGame IO ()-update ge = update' Nothing ge--update' :: Maybe (RuleCode -> IO RuleFunc) -> GameEvent -> StateT LoggedGame IO ()-update' inter ge = do-   t <- access $ game >>> currentTime-   let te = TimedEvent t ge-   gameLog %= \gl -> gl ++ [te]-   focus game $ enactTimedEvent inter te--getLoggedGame :: Game -> (RuleCode -> IO RuleFunc) -> [TimedEvent] -> IO LoggedGame-getLoggedGame g mInter tes = do-   let a = mapM_ (enactTimedEvent (Just mInter)) tes-   g' <- execStateT a g-   return $ LoggedGame g' tes----- | initialize the game.-gameSettings :: GameName -> GameDesc -> UTCTime -> State Game ()-gameSettings name desc date = do-   gameName ~= name-   gameDesc ~= desc-   currentTime ~= date-   return ()----- | join the game.-joinGame :: PlayerName -> PlayerNumber -> State Game ()-joinGame name pn = do-   g <- get-   case find ((== pn) . getL playerNumber) (_players g) of-      Just _ -> return ()-      Nothing -> do-         tracePN pn $ "Joining game: " ++ (_gameName g)-         let player = PlayerInfo { _playerNumber = pn, _playerName = name}-         players %= (player : )-         runEvalError pn $ triggerEvent_ (Player Arrive) (PlayerData player)----- | leave the game.-leaveGame :: PlayerNumber -> State Game ()-leaveGame pn = runEvalError pn $ void $ evDelPlayer pn---- | insert a rule in pending rules.-proposeRule :: SubmitRule -> PlayerNumber -> (RuleCode -> IO RuleFunc) -> StateT Game IO ()-proposeRule sr pn inter = do-   rule <- createRule sr pn inter-   mapStateIO $ runEvalError pn $ do-      r <- evProposeRule rule-      if r == True then tracePN pn $ "Your rule has been added to pending rules."-      else tracePN pn $ "Error: Rule could not be proposed"--logGame :: String -> (Maybe PlayerNumber) -> State Game ()-logGame s mpn = do-   time <- access currentTime-   void $ logs %= (Log mpn time s : )--inputResult :: PlayerNumber -> EventNumber -> UInputData -> State Game ()-inputResult pn en ir = do-   tracePN pn $ "input result: Event " ++ (show en) ++ ", choice " ++  (show ir)-   runEvalError pn $ triggerInput en ir--getTimes :: EventHandler -> Maybe UTCTime-getTimes (EH _ _ (Time t) _ SActive) = Just t-getTimes _ = Nothing---- | A helper function to use the state transformer GameState.--- It additionally sets the current time.-execWithGame :: UTCTime -> State LoggedGame () -> LoggedGame -> LoggedGame-execWithGame t gs g = execState gs $ ((game >>> currentTime) `setL` t $ g)--execWithGame' :: UTCTime -> StateT LoggedGame IO () -> LoggedGame -> IO LoggedGame-execWithGame' t gs g = execStateT gs ((game >>> currentTime) `setL` t $ g)---activeRules :: Game -> [Rule]-activeRules = sort . filter ((==Active) . getL rStatus) . _rules--pendingRules :: Game -> [Rule]-pendingRules = sort . filter ((==Pending) . getL rStatus) . _rules--rejectedRules :: Game -> [Rule]-rejectedRules = sort . filter ((==Reject) . getL rStatus) . _rules--instance Ord PlayerInfo where-   h <= g = (_playerNumber h) <= (_playerNumber g)---createRule :: SubmitRule -> PlayerNumber -> (RuleCode -> IO RuleFunc) -> StateT Game IO Rule-createRule (SubmitRule name desc code) pn inter = do-   rs <- access rules-   let rn = getFreeNumber $ map _rNumber rs-   rf <- lift $ inter code-   tracePN pn $ "Creating rule n=" ++ (show rn) ++ " code=" ++ code-   return $ Rule {_rNumber = rn,-                  _rName = name,-                  _rDescription = desc,-                  _rProposedBy = pn,-                  _rRuleCode = code,-                  _rRuleFunc = rf,-                  _rStatus = Pending,-                  _rAssessedBy = Nothing}--systemAddRule :: SubmitRule -> (RuleCode -> IO RuleFunc) -> StateT Game IO ()-systemAddRule sr inter = do-   rule <- createRule sr 0 inter-   let sysRule = (rStatus ^= Active) >>> (rAssessedBy ^= Just 0)-   rules %= (sysRule rule : )-   mapStateIO $ runEvalError 0 $ void $ evalExp (_rRuleFunc rule) (_rNumber rule)--stateCatch = liftCatch E.catch
+ src/Language/Nomyx/Inputs.hs view
@@ -0,0 +1,168 @@+{-# LANGUAGE ScopedTypeVariables, GADTs #-}+
+-- | All the building blocks to allow rules to get inputs.
+module Language.Nomyx.Inputs where
+--   Input(..),+--   InputForm(..),+--   inputRadio, inputRadioHead, inputRadioEnum,
+--   inputRadioData, 
+--   onInputRadio, onInputRadio_,
+--   onInputRadioOnce, onInputRadioOnce_,
+--   onInputRadioEnum, onInputRadioEnum_,
+--   onInputRadioEnumOnce_, 
+--   inputText,
+--   inputTextData,
+--   onInputText, onInputText_,
+--   onInputTextOnce, onInputTextOnce_,
+--   inputCheckboxData,+--   inputCheckbox,
+--   onInputCheckbox, onInputCheckbox_,
+--   onInputCheckboxOnce, onInputCheckboxOnce_,+--   inputButtonData,
+--   inputButton,
+--   onInputButton, onInputButton_,
+--   onInputButtonOnce, onInputButtonOnce_,
+--   inputTextareaData,+--   inputTextarea, 
+--   onInputTextarea, onInputTextarea_,+--   onInputTextareaOnce, onInputTextareaOnce_,+
+import Language.Nomyx.Expression+import Language.Nomyx.Events
+import Data.Typeable
+import Control.Applicative
+
+
+-- * Inputs
+
+-- ** Radio inputs
+
+inputRadio :: (Eq c, Show c, Typeable c) => PlayerNumber -> String -> [c] -> c -> Event (Input c)
+inputRadio pn title cs _ = InputEv (Input pn title (Radio (zip cs (show <$> cs))))
+
+inputRadioHead :: (Eq c, Show c, Typeable c) => PlayerNumber -> String -> [c] -> Event (Input c)
+inputRadioHead pn title choices = inputRadio pn title choices (head choices)
+
+inputRadioEnum :: forall c. (Enum c, Bounded c, Typeable c, Eq c,  Show c) => PlayerNumber -> String -> c -> Event (Input c)
+inputRadioEnum pn title defaultChoice = inputRadio pn title (enumFrom (minBound::c)) defaultChoice
+
+inputRadioData :: (Show c) => EventData (Input c) -> c
+inputRadioData (InputData (RadioData a)) = a
+inputRadioData a = error $ "Not a Radio Data: " ++ (show a)
+
+-- | triggers a choice input to the user. The result will be sent to the callback
+onInputRadio :: (Typeable a, Eq a,  Show a) => String -> [a] -> (EventNumber -> a -> Nomex ()) -> PlayerNumber -> Nomex EventNumber
+onInputRadio title choices handler pn = onEvent (inputRadioHead pn title choices) (\(en, InputData (RadioData a)) -> handler en a)
+
+-- | the same, disregard the event number
+onInputRadio_ :: (Typeable a, Eq a, Show a) => String -> [a] -> (a -> Nomex ()) -> PlayerNumber -> Nomex ()
+onInputRadio_ title choices handler pn = onEvent_ (inputRadioHead pn title choices) (handler . inputRadioData)
+
+-- | the same, suppress the event after first trigger
+onInputRadioOnce :: (Typeable a, Eq a, Show a) => String -> [a] -> (a -> Nomex ()) -> PlayerNumber -> Nomex EventNumber
+onInputRadioOnce title choices handler pn = onEventOnce (inputRadioHead pn title choices) (handler . inputRadioData)
+
+-- | the same, disregard the event number
+onInputRadioOnce_ :: (Typeable a, Eq a, Show a) => String -> [a] -> (a -> Nomex ()) -> PlayerNumber -> Nomex ()
+onInputRadioOnce_ title choices handler pn = onEventOnce_ (inputRadioHead pn title choices) (handler . inputRadioData)
+
+-- | triggers a choice input to the user, using an enumerate as input
+onInputRadioEnum :: forall a. (Enum a, Bounded a, Typeable a, Eq a,  Show a) => String -> a -> (EventNumber -> a -> Nomex ()) -> PlayerNumber -> Nomex EventNumber
+onInputRadioEnum title defaultChoice handler pn = onEvent (inputRadioEnum pn title defaultChoice) (\(en, a) -> handler en (inputRadioData a))
+
+-- | the same, disregard the event number
+onInputRadioEnum_ :: forall a. (Enum a, Bounded a, Typeable a, Eq a,  Show a) => String -> a -> (a -> Nomex ()) -> PlayerNumber -> Nomex ()
+onInputRadioEnum_ title defaultChoice handler pn = onEvent_ (inputRadioEnum pn title defaultChoice) (handler . inputRadioData)
+
+-- | the same, suppress the event after first trigger
+onInputRadioEnumOnce_ :: forall a. (Enum a, Bounded a, Typeable a, Eq a,  Show a) => String -> a -> (a -> Nomex ()) -> PlayerNumber -> Nomex ()
+onInputRadioEnumOnce_ title defaultChoice handler pn = onEventOnce_ (inputRadioEnum pn title defaultChoice) (handler . inputRadioData)
+
+-- ** Text inputs
+
+inputText :: PlayerNumber -> String -> Event (Input String)
+inputText pn title = InputEv (Input pn title Text)
+
+inputTextData :: EventData (Input String) -> String
+inputTextData (InputData (TextData a)) = a
+inputTextData a = error $ "Not a Text Data: " ++ (show a)
+
+-- | triggers a string input to the user. The result will be sent to the callback
+onInputText :: String -> (EventNumber -> String -> Nomex ()) -> PlayerNumber -> Nomex EventNumber
+onInputText title handler pn = onEvent (inputText pn title) (\(en, a) -> handler en (inputTextData a))
+
+-- | asks the player pn to answer a question, and feed the callback with this data.
+onInputText_ :: String -> (String -> Nomex ()) -> PlayerNumber -> Nomex ()
+onInputText_ title handler pn = onEvent_ (inputText pn title) (handler . inputTextData)
+
+-- | asks the player pn to answer a question, and feed the callback with this data.
+onInputTextOnce :: String -> (String -> Nomex ()) -> PlayerNumber -> Nomex EventNumber
+onInputTextOnce title handler pn = onEventOnce (inputText pn title) (handler . inputTextData)
+
+onInputTextOnce_ :: String -> (String -> Nomex ()) -> PlayerNumber -> Nomex ()
+onInputTextOnce_ title handler pn = onEventOnce_ (inputText pn title) (handler . inputTextData)
+
+-- ** Checkbox inputs
+
+inputCheckboxData :: (Show c) => EventData (Input c) -> [c]
+inputCheckboxData (InputData (CheckboxData a)) = a
+inputCheckboxData a = error $ "Not a Checkbox Data: " ++ (show a)
+
+inputCheckbox :: (Eq c, Show c, Typeable c) => PlayerNumber -> String -> [(c, String)] -> Event (Input c)
+inputCheckbox pn title cs = InputEv (Input pn title (Checkbox cs))
+
+onInputCheckbox :: (Typeable a, Eq a,  Show a) => String -> [(a, String)] -> (EventNumber -> [a] -> Nomex ()) -> PlayerNumber -> Nomex EventNumber
+onInputCheckbox title choices handler pn = onEvent (inputCheckbox pn title choices) (\(en, InputData (CheckboxData a)) -> handler en a)
+
+onInputCheckbox_ :: (Typeable a, Eq a,  Show a) => String -> [(a, String)] -> ([a] -> Nomex ()) -> PlayerNumber -> Nomex ()
+onInputCheckbox_ title choices handler pn = onEvent_ (inputCheckbox pn title choices) (handler . inputCheckboxData)
+
+onInputCheckboxOnce :: (Typeable a, Eq a,  Show a) => String -> [(a, String)] -> ([a] -> Nomex ()) -> PlayerNumber -> Nomex EventNumber
+onInputCheckboxOnce title choices handler pn = onEventOnce (inputCheckbox pn title choices) (handler . inputCheckboxData)
+
+onInputCheckboxOnce_ :: (Typeable a, Eq a,  Show a) => String -> [(a, String)] -> ([a] -> Nomex ()) -> PlayerNumber -> Nomex ()
+onInputCheckboxOnce_ title choices handler pn = onEventOnce_ (inputCheckbox pn title choices) (handler . inputCheckboxData)
+
+
+-- ** Button inputs
+
+inputButtonData :: EventData (Input ()) -> ()
+inputButtonData (InputData ButtonData) = ()
+inputButtonData a = error $ "Not a Button Data: " ++ (show a)
+
+inputButton :: PlayerNumber -> String -> Event (Input ())
+inputButton pn title = InputEv (Input pn title Button)
+
+onInputButton :: String -> (EventNumber -> () -> Nomex ()) -> PlayerNumber -> Nomex EventNumber
+onInputButton title handler pn = onEvent (inputButton pn title) (\(en, InputData ButtonData) -> handler en ())
+
+onInputButton_ :: String -> (() -> Nomex ()) -> PlayerNumber -> Nomex ()
+onInputButton_ title handler pn = onEvent_ (inputButton pn title) (handler . inputButtonData)
+
+onInputButtonOnce :: String -> (() -> Nomex ()) -> PlayerNumber -> Nomex EventNumber
+onInputButtonOnce title handler pn = onEventOnce (inputButton pn title) (handler . inputButtonData)
+
+onInputButtonOnce_ :: String -> (() -> Nomex ()) -> PlayerNumber -> Nomex ()
+onInputButtonOnce_ title handler pn = onEventOnce_ (inputButton pn title) (handler . inputButtonData)
+
+-- ** Textarea inputs
+
+inputTextareaData :: EventData (Input String) -> String
+inputTextareaData (InputData (TextAreaData a)) = a
+inputTextareaData a = error $ "Not a Textarea Data: " ++ (show a)
+
+inputTextarea :: PlayerNumber -> String -> Event (Input String)
+inputTextarea pn title = InputEv (Input pn title TextArea)
+
+onInputTextarea :: String -> (EventNumber -> String -> Nomex ()) -> PlayerNumber -> Nomex EventNumber
+onInputTextarea title handler pn = onEvent (inputTextarea pn title) (\(en, a) -> handler en (inputTextareaData a))
+
+onInputTextarea_ :: String -> (String -> Nomex ()) -> PlayerNumber -> Nomex ()
+onInputTextarea_ title handler pn = onEvent_ (inputTextarea pn title) (handler . inputTextareaData)
+
+onInputTextareaOnce :: String -> (String -> Nomex ()) -> PlayerNumber -> Nomex EventNumber
+onInputTextareaOnce title handler pn = onEventOnce (inputTextarea pn title) (handler . inputTextareaData)
+
+onInputTextareaOnce_ :: String -> (String -> Nomex ()) -> PlayerNumber -> Nomex ()
+onInputTextareaOnce_ title handler pn = onEventOnce_ (inputTextarea pn title) (handler . inputTextareaData)
+
+ src/Language/Nomyx/Outputs.hs view
@@ -0,0 +1,78 @@+
+-- | All the building blocks to allow rules to produce outputs.
+module Language.Nomyx.Outputs where
+--   OutputNumber,+--   newOutput, newOutput_,+--   outputAll, outputAll_, outputAll',
+--   getOutput, getOutput_,
+--   updateOutput, updateOutput_, 
+--   delOutput, delOutput_,
+--   displayVar, displaySimpleVar,
+--   displayArrayVar, showArrayVar,+
+import Language.Nomyx.Expression+import Language.Nomyx.Variables
+import Data.Typeable
+import Control.Monad.State
+
+
+-- * Outputs
+
+-- | outputs a message to one player
+newOutput :: Nomex String -> (Maybe PlayerNumber) -> Nomex OutputNumber
+newOutput ns mpn = ns >>= NewOutput mpn
+
+newOutput_ :: Nomex String -> (Maybe PlayerNumber) -> Nomex ()
+newOutput_ ns pn = void $ newOutput ns pn
+
+-- | output a message to all players
+outputAll :: Nomex String -> Nomex OutputNumber
+outputAll ns = newOutput ns Nothing
+
+outputAll_ :: Nomex String -> Nomex ()
+outputAll_ ns = newOutput_ ns Nothing
+
+outputAll' :: String -> Nomex ()
+outputAll' s = newOutput_ (return s) Nothing
+
+getOutput :: OutputNumber -> Nomex (Maybe String)
+getOutput on = GetOutput on
+
+getOutput_ :: OutputNumber -> Nomex String
+getOutput_ on = partial "getOutput_ : Output number not existing" $ getOutput on
+
+updateOutput :: OutputNumber -> Nomex String -> Nomex Bool
+updateOutput on ns = ns >>= UpdateOutput on
+
+updateOutput_ :: OutputNumber -> Nomex String -> Nomex ()
+updateOutput_ on ns = void $ updateOutput on ns
+
+delOutput :: OutputNumber -> Nomex Bool
+delOutput = DelOutput
+
+delOutput_ :: OutputNumber -> Nomex ()
+delOutput_ on = void $ delOutput on
+
+-- permanently display a variable (update display when variable is updated)
+displayVar :: (Typeable a, Show a, Eq a) => (Maybe PlayerNumber) -> MsgVar a -> (a -> Nomex String) -> Nomex ()
+displayVar mpn mv dis = onMsgVarEvent
+   mv
+   (\a -> newOutput (dis a) mpn)
+   (\a n -> updateOutput_ n (dis a))
+   delOutput_
+
+displaySimpleVar :: (Typeable a, Show a, Eq a) => (Maybe PlayerNumber) -> Nomex String -> MsgVar a -> Nomex ()
+displaySimpleVar mpn ntitle mv = do
+   let title a = do
+        t <- ntitle
+        return $ (t ++ ": " ++ (show a) ++ "\n")
+   displayVar mpn mv title
+
+displayArrayVar :: (Typeable a, Show a, Eq a, Typeable i, Show i, Eq i) => (Maybe PlayerNumber) -> Nomex String -> ArrayVar i a -> Nomex ()
+displayArrayVar mpn ntitle mv = displayVar mpn mv (showArrayVar ntitle)
+
+showArrayVar :: (Show a, Show i) => Nomex String -> [(i,a)] -> Nomex String
+showArrayVar title l = do
+   t <- title
+   return $ t ++ "\n" ++ concatMap (\(i,a) -> (show i) ++ "\t" ++ (show a) ++ "\n") l
+
+ src/Language/Nomyx/Players.hs view
@@ -0,0 +1,135 @@+{-# LANGUAGE GADTs, ScopedTypeVariables, TupleSections #-}
+
+-- | All the building blocks to allow rules to manage players.
+module Language.Nomyx.Players where+--   PlayerNumber,+--   PlayerName,+--   PlayerInfo(..),+--   Player(..),+--   playerNumber, playerName,+--   getPlayers, getPlayer, getPlayerName,
+--   setPlayerName,
+--   modifyPlayerName,
+--   getPlayersNumber, getAllPlayerNumbers,
+--   delPlayer,+--   forEachPlayer, forEachPlayer_,+--   createValueForEachPlayer, createValueForEachPlayer_,+--   getValueOfPlayer,+--   modifyValueOfPlayer, modifyAllValues,+--   showPlayer,+--   getSelfProposedByPlayer,+--   setVictory, 
+--   giveVictory,+
+import Language.Nomyx.Expression+import Language.Nomyx.Events+import Language.Nomyx.Variables+import Language.Nomyx.Rules+import Data.Typeable
+import Data.List
+import Data.Lens
+import Control.Applicative
+import Control.Arrow+
+-- * Players
+
+-- | get all the players
+getPlayers :: Nomex [PlayerInfo]
+getPlayers = GetPlayers
+
+-- | Get a specific player
+getPlayer :: PlayerNumber -> Nomex (Maybe PlayerInfo)
+getPlayer pn = do
+   pls <- GetPlayers
+   return $ find ((== pn) . getL playerNumber) pls
+
+-- | Set the name of a player
+getPlayerName :: PlayerNumber -> Nomex (Maybe PlayerName)
+getPlayerName pn = do
+  p <- getPlayer pn
+  return $ _playerName <$> p
+
+-- | Set the name of a player
+setPlayerName :: PlayerNumber -> PlayerName -> Nomex Bool
+setPlayerName = SetPlayerName
+
+modifyPlayerName :: PlayerNumber -> (PlayerName -> PlayerName) -> Nomex Bool
+modifyPlayerName pn f = do
+   mn <- getPlayerName pn
+   case mn of
+      Just name -> setPlayerName pn (f name)
+      Nothing -> return False
+
+
+-- | Get the total number of players
+getPlayersNumber :: Nomex Int
+getPlayersNumber = length <$> getPlayers
+
+-- | Get all the players number
+getAllPlayerNumbers :: Nomex [PlayerNumber]
+getAllPlayerNumbers = map _playerNumber <$> getPlayers
+
+-- | Remove the player from the game (kick)
+delPlayer :: PlayerNumber -> Nomex Bool
+delPlayer = DelPlayer
+++-- | perform an action for each current players, new players and leaving players+forEachPlayer :: (PlayerNumber -> Nomex ()) -> (PlayerNumber -> Nomex ()) -> (PlayerNumber -> Nomex ()) -> Nomex ()+forEachPlayer action actionWhenArrive actionWhenLeave = do+    pns <- getAllPlayerNumbers+    mapM_ action pns+    onEvent_ (Player Arrive) $ \(PlayerData p) -> actionWhenArrive $ _playerNumber p+    onEvent_ (Player Leave) $ \(PlayerData p) -> actionWhenLeave $ _playerNumber p++-- | perform the same action for each players, including new players+forEachPlayer_ :: (PlayerNumber -> Nomex ()) -> Nomex ()+forEachPlayer_ action = forEachPlayer action action (\_ -> return ())+
+-- | create a value initialized for each players+--manages players joining and leaving+createValueForEachPlayer :: forall a. (Typeable a, Show a, Eq a) => a -> MsgVar [(PlayerNumber, a)] -> Nomex ()+createValueForEachPlayer initialValue mv = do+    pns <- getAllPlayerNumbers+    v <- newMsgVar_ (getMsgVarName mv) $ map (,initialValue::a) pns+    forEachPlayer (const $ return ())+                  (\p -> modifyMsgVar v ((p, initialValue) : ))+                  (\p -> modifyMsgVar v $ filter $ (/= p) . fst)++-- | create a value initialized for each players initialized to zero+--manages players joining and leaving+createValueForEachPlayer_ :: MsgVar [(PlayerNumber, Int)] -> Nomex ()+createValueForEachPlayer_ = createValueForEachPlayer 0++getValueOfPlayer :: forall a. (Typeable a, Show a, Eq a) => PlayerNumber -> MsgVar [(PlayerNumber, a)] -> Nomex (Maybe a)+getValueOfPlayer pn var = do+   value <- readMsgVar_ var+   return $ lookup pn value++modifyValueOfPlayer :: (Eq a, Show a, Typeable a) => PlayerNumber -> MsgVar [(PlayerNumber, a)] -> (a -> a) -> Nomex ()+modifyValueOfPlayer pn var f = modifyMsgVar var $ map $ (\(a,b) -> if a == pn then (a, f b) else (a,b))++modifyAllValues :: (Eq a, Show a, Typeable a) => MsgVar [(PlayerNumber, a)] -> (a -> a) -> Nomex ()+modifyAllValues var f = modifyMsgVar var $ map $ second f++-- | show a player name based on his number+showPlayer :: PlayerNumber -> Nomex String+showPlayer pn = do+   mn <- getPlayerName pn+   case mn of+      Just name -> return name+      Nothing -> return ("Player " ++ (show pn))++
+-- | set victory to a list of players
+setVictory :: [PlayerNumber] -> Nomex ()
+setVictory = SetVictory
+
+-- | give victory to one player
+giveVictory :: PlayerNumber -> Nomex ()
+giveVictory pn = SetVictory [pn]
+
+
+getSelfProposedByPlayer :: Nomex PlayerNumber
+getSelfProposedByPlayer = getSelfRule >>= return . _rProposedBy
+
− src/Language/Nomyx/Rule.hs 
@@ -1,122 +0,0 @@-{-# LANGUAGE DeriveDataTypeable, GADTs, ScopedTypeVariables, TupleSections,-    FlexibleInstances, TypeFamilies, FlexibleContexts, Rank2Types #-}
-
--- | Basic rules examples.
-module Language.Nomyx.Rule where
--import Prelude hiding (foldr)
-import Language.Nomyx.Expression
-import Language.Nomyx.Definition
-import Control.Arrow
-import Data.Lens
-import Data.Maybe-import Data.List---
--- | This rule will activate automatically any new rule.
-autoActivate :: RuleFunc
-autoActivate = voidRule $ onEvent_ (RuleEv Proposed) (activateRule_ . _rNumber . ruleData)
-
--- | This rule will forbid any new rule to delete the rule in parameter
---immutableRule :: RuleNumber -> RuleFunc
---immutableRule rn = return $ Meta f where
---   f r = do
---      protectedRule <- getRule rn
---      case protectedRule of
---         Just pr -> case _rRuleFunc r of
---            RuleRule paramRule -> paramRule pr
---            _ -> return $ BoolResp True
---         Nothing -> return $ BoolResp True
-
--- | A rule will be always legal
-legal :: RuleFunc
-legal =  return $ Meta (\_ -> return $ BoolResp True)
-
--- | A rule will be always illegal
-illegal :: RuleFunc
-illegal = return $ Meta (\_ -> return $ BoolResp False)
---- | active metarules are automatically used to evaluate a given rule
---checkWithMetarules :: Rule -> Nomex (Event (Message ForAgainst)
---checkWithMetarules rule = do
---    rs <- getActiveRules
---    (metas :: [Rule -> Nomex BoolResp]) <- mapMaybeM maybeMetaRule rs
---    let (evals :: [Nomex BoolResp]) = map (\meta -> meta rule) metas
---    foldr (&&*) true evals
-
-
-maybeMetaRule :: Rule -> Nomex (Maybe (Rule -> Nomex BoolResp))
-maybeMetaRule Rule {_rRuleFunc = rule} = do-   meta <- rule-   case meta of-      (Meta m) -> return $ Just m-      _ -> return Nothing
-
-
-
-
--- | activate or reject a rule
-activateOrReject :: Rule -> Bool -> Nomex ()
-activateOrReject r b = if b then activateRule_ (_rNumber r) else rejectRule_ (_rNumber r)
-
--- | perform an action for each current players, new players and leaving players
-forEachPlayer :: (PlayerNumber -> Nomex ()) -> (PlayerNumber -> Nomex ()) -> (PlayerNumber -> Nomex ()) -> Nomex ()
-forEachPlayer action actionWhenArrive actionWhenLeave = do
-    pns <- getAllPlayerNumbers
-    mapM_ action pns
-    onEvent_ (Player Arrive) $ \(PlayerData p) -> actionWhenArrive $ _playerNumber p
-    onEvent_ (Player Leave) $ \(PlayerData p) -> actionWhenLeave $ _playerNumber p
-
--- | perform the same action for each players, including new players
-forEachPlayer_ :: (PlayerNumber -> Nomex ()) -> Nomex ()
-forEachPlayer_ action = forEachPlayer action action (\_ -> return ())
-
-
--- | create a value initialized for each players
---manages players joining and leaving
-createValueForEachPlayer :: Int -> MsgVar [(Int, Int)] -> Nomex ()
-createValueForEachPlayer initialValue mv = do
-    pns <- getAllPlayerNumbers
-    v <- newMsgVar_ (getMsgVarName mv) $ map (,initialValue::Int) pns
-    forEachPlayer (const $ return ())
-                  (\p -> modifyMsgVar v ((p, initialValue) : ))
-                  (\p -> modifyMsgVar v $ filter $ (/= p) . fst)
-
--- | create a value initialized for each players initialized to zero
---manages players joining and leaving
-createValueForEachPlayer_ :: MsgVar [(Int, Int)] -> Nomex ()
-createValueForEachPlayer_ = createValueForEachPlayer 0
--getValueOfPlayer :: PlayerNumber -> MsgVar [(Int, Int)] -> Nomex (Maybe Int)-getValueOfPlayer pn var = do-   value <- readMsgVar_ var-   return $ lookup pn value-
-modifyValueOfPlayer :: PlayerNumber -> MsgVar [(Int, Int)] -> (Int -> Int) -> Nomex ()
-modifyValueOfPlayer pn var f = modifyMsgVar var $ map $ (\(a,b) -> if a == pn then (a, f b) else (a,b))
-
-modifyAllValues :: MsgVar [(Int, Int)] -> (Int -> Int) -> Nomex ()
-modifyAllValues var f = modifyMsgVar var $ map $ second f
-
--- | Player p cannot propose anymore rules
-noPlayPlayer :: PlayerNumber -> RuleFunc
-noPlayPlayer p = return $ Meta $ \r -> return $ BoolResp $ (_rProposedBy r) /= p
-
--- | a rule can autodelete itself (generaly after having performed some actions)
-autoDelete :: Nomex ()
-autoDelete = getSelfRuleNumber >>= suppressRule_
-
-
--- | All rules from player p are erased:
-eraseAllRules :: PlayerNumber -> Nomex Bool
-eraseAllRules p = do
-    rs <- getRules
-    let myrs = filter ((== p) . getL rProposedBy) rs
-    res <- mapM (suppressRule . _rNumber) myrs
-    return $ and res
--showPlayer :: Nomex (PlayerNumber -> String)-showPlayer = do-   pls <- getPlayers-   return $ (\pn -> _playerName $ fromJust $ find (\(PlayerInfo mypn _) -> mypn == pn) pls)
+ src/Language/Nomyx/Rules.hs view
@@ -0,0 +1,199 @@++-- | Basic rules examples.+module Language.Nomyx.Rules where+--   RuleFunc,+--   RuleResp(..),+--   Rule(..),+--   RuleNumber,+--   RuleCode,+--   RuleEvent(..),+--   RuleStatus(..),+--   voidRule,+--   activateRule, activateRule_,+--   rejectRule, rejectRule_,+--   getRules, getActiveRules, getRule,+--   getRulesByNumbers,+--   getRuleFuncs,+--   addRule, addRule_, addRuleParams,+--   getFreeRuleNumber,+--   suppressRule, suppressRule_, suppressAllRules,+--   modifyRule,+--   autoActivate,+--   activateOrReject,+--   noPlayPlayer,+--   autoDelete,+--   eraseAllRules,+--   getSelfRuleNumber, getSelfRule,++import Prelude hiding (foldr)+import Language.Nomyx.Expression+import Language.Nomyx.Events+import Data.Lens+import Control.Monad+import Data.List+import Data.Maybe+--import Language.Nomyx.Utils++-- * Rule management++voidRule :: Nomex a -> Nomex RuleResp
+voidRule e = e >> return Void++-- | activate a rule: change its state to Active and execute it+activateRule :: RuleNumber -> Nomex Bool+activateRule = ActivateRule++activateRule_ :: RuleNumber -> Nomex ()+activateRule_ r = activateRule r >> return ()++-- | reject a rule: change its state to Suppressed and suppresses all its environment (events, variables, inputs)+-- the rule can be activated again later+rejectRule :: RuleNumber -> Nomex Bool+rejectRule = RejectRule++rejectRule_ :: RuleNumber -> Nomex ()+rejectRule_ r = void $ rejectRule r++getRules :: Nomex [Rule]+getRules = GetRules++getActiveRules :: Nomex [Rule]+getActiveRules = return . (filter ((== Active) . _rStatus) ) =<< getRules++getRule :: RuleNumber -> Nomex (Maybe Rule)+getRule rn = do+   rs <- GetRules+   return $ find ((== rn) . getL rNumber) rs++getRulesByNumbers :: [RuleNumber] -> Nomex [Rule]+getRulesByNumbers rns = mapMaybeM getRule rns++getRuleFuncs :: Nomex [RuleFunc]+getRuleFuncs = return . (map _rRuleFunc) =<< getRules++-- | add a rule to the game, it will have to be activated+addRule :: Rule -> Nomex Bool+addRule r = AddRule r++addRule_ :: Rule -> Nomex ()+addRule_ r = void $ AddRule r++--TODO: too permissive. Should use SubmitRule instead.+addRuleParams :: RuleName -> RuleFunc -> RuleCode -> String -> Nomex RuleNumber+addRuleParams name func code desc = do+   number <- getFreeRuleNumber+   res <- addRule $ defaultRule {_rName = name, _rRuleFunc = func, _rRuleCode = code, _rNumber = number, _rDescription = desc}+   return $ if res then number else error "addRuleParams: cannot add rule"+++getFreeRuleNumber :: Nomex RuleNumber+getFreeRuleNumber = do+   rs <- getRules+   return $ getFreeNumber $ map _rNumber rs++getFreeNumber :: (Eq a, Num a, Enum a) => [a] -> a+getFreeNumber l = head [a| a <- [1..], not $ a `elem` l]++--suppresses completly a rule and its environment from the system+suppressRule :: RuleNumber -> Nomex Bool+suppressRule rn = RejectRule rn++suppressRule_ :: RuleNumber -> Nomex ()+suppressRule_ rn = void $ RejectRule rn++suppressAllRules :: Nomex Bool+suppressAllRules = do+    rs <- getRules+    res <- mapM (suppressRule . _rNumber) rs+    return $ and res++modifyRule :: RuleNumber -> Rule -> Nomex Bool+modifyRule rn r = ModifyRule rn r+++-- | This rule will activate automatically any new rule.+autoActivate :: RuleFunc+autoActivate = voidRule $ onEvent_ (RuleEv Proposed) (activateRule_ . _rNumber . ruleData)++-- | This rule will forbid any new rule to delete the rule in parameter+--immutableRule :: RuleNumber -> RuleFunc+--immutableRule rn = return $ Meta f where+--   f r = do+--      protectedRule <- getRule rn+--      case protectedRule of+--         Just pr -> case _rRuleFunc r of+--            RuleRule paramRule -> paramRule pr+--            _ -> return $ BoolResp True+--         Nothing -> return $ BoolResp True++-- | A rule will be always legal+legal :: RuleFunc+legal =  return $ Meta (\_ -> return $ BoolResp True)++-- | A rule will be always illegal+illegal :: RuleFunc+illegal = return $ Meta (\_ -> return $ BoolResp False)++-- | active metarules are automatically used to evaluate a given rule+--checkWithMetarules :: Rule -> Nomex (Event (Message ForAgainst)+--checkWithMetarules rule = do+--    rs <- getActiveRules+--    (metas :: [Rule -> Nomex BoolResp]) <- mapMaybeM maybeMetaRule rs+--    let (evals :: [Nomex BoolResp]) = map (\meta -> meta rule) metas+--    foldr (&&*) true evals+++maybeMetaRule :: Rule -> Nomex (Maybe (Rule -> Nomex BoolResp))+maybeMetaRule Rule {_rRuleFunc = rule} = do+   meta <- rule+   case meta of+      (Meta m) -> return $ Just m+      _ -> return Nothing+++-- | activate or reject a rule+activateOrReject :: Rule -> Bool -> Nomex ()+activateOrReject r b = if b then activateRule_ (_rNumber r) else rejectRule_ (_rNumber r)+++-- | Player p cannot propose anymore rules+noPlayPlayer :: PlayerNumber -> RuleFunc+noPlayPlayer p = return $ Meta $ \r -> return $ BoolResp $ (_rProposedBy r) /= p++-- | a rule can autodelete itself (generaly after having performed some actions)+autoDelete :: Nomex ()+autoDelete = getSelfRuleNumber >>= suppressRule_++-- | All rules from player p are erased:+eraseAllRules :: PlayerNumber -> Nomex Bool+eraseAllRules p = do+    rs <- getRules+    let myrs = filter ((== p) . getL rProposedBy) rs+    res <- mapM (suppressRule . _rNumber) myrs+    return $ and res+++-- | allows a rule to retrieve its own number (for auto-deleting for example)
+getSelfRuleNumber :: Nomex RuleNumber
+getSelfRuleNumber = SelfRuleNumber
+
+getSelfRule :: Nomex Rule
+getSelfRule  = do
+   srn <- getSelfRuleNumber
+   rs:[] <- getRulesByNumbers [srn]
+   return rs++-- | a default rule
+defaultRule = Rule  {
+    _rNumber       = 1,
+    _rName         = "",
+    _rDescription  = "",
+    _rProposedBy   = 0,
+    _rRuleCode     = "",
+    _rRuleFunc     = return Void,
+    _rStatus       = Pending,
+    _rAssessedBy   = Nothing}++mapMaybeM :: (Monad m) => (a -> m (Maybe b)) -> [a] -> m [b]
+mapMaybeM f = liftM catMaybes . mapM f
+
− src/Language/Nomyx/Test.hs 
@@ -1,297 +0,0 @@-{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable, NamedFieldPuns, GADTs#-}--module Language.Nomyx.Test where--import Language.Nomyx.Rule-import Language.Nomyx.Expression-import Language.Nomyx.Evaluation-import Language.Nomyx.Utils-import Language.Nomyx.Vote-import Control.Monad.State-import Data.Typeable-import Data.Lens-import Language.Nomyx.Definition--date1 = parse822Time "Tue, 02 Sep 1997 09:00:00 -0400"-date2 = parse822Time "Tue, 02 Sep 1997 10:00:00 -0400"-date3 = parse822Time "Tue, 02 Sep 1997 11:00:00 -0400"--testGame = Game { _gameName      = "test",-                  _gameDesc      = GameDesc "test" "test",-                  _rules         = [],-                  _players       = [PlayerInfo 1 "coco"],-                  _variables     = [],-                  _events        = [],-                  _outputs       = [],-                  _victory       = [],-                  _logs          = [],-                  _currentTime   = date1}--testRule = Rule  { _rNumber       = 0,-                   _rName         = "test",-                   _rDescription  = "test",-                   _rProposedBy   = 0,-                   _rRuleCode     = "",-                   _rRuleFunc     = return Void,-                   _rStatus       = Pending,-                   _rAssessedBy   = Nothing}--evalRuleFunc f = evalState (runEvalError 0 $ evalExp f 0) testGame-execRuleFuncEvent f e d = execState (runEvalError 0 $ evalExp f 0 >> (triggerEvent_ e d)) testGame-execRuleFuncGame f g = execState (runEvalError 0 $ void $ evalExp f 0) g-execRuleFuncEventGame f e d g = execState (runEvalError 0 $ evalExp f 0 >> (triggerEvent_ e d)) g-execRuleFunc f = execRuleFuncGame f testGame--tests = [("test var 1", testVarEx1),-         ("test var 2", testVarEx2),-         ("test var 3", testVarEx3),-         ("test var 4", testVarEx4),-         ("test var 5", testVarEx5),-         ("test single input", testSingleInputEx),-         ("test multiple input", testMultipleInputsEx),-         ("test input string", testInputStringEx),-         ("test send messsage", testSendMessageEx),-         ("test send message 2", testSendMessageEx2),-         ("test user input write", testUserInputWriteEx),-         ("test activate rule", testActivateRuleEx),-         ("test auto activate", testAutoActivateEx),-         --("test meta rules vote", testApplicationMetaRuleEx),-         ("test time event", testTimeEventEx),-         ("test time event 2", testTimeEventEx2),-         ("test assess on vote complete 1", testVoteAssessOnVoteComplete1),-         ("test assess on vote complete 2", testVoteAssessOnVoteComplete2),-         ("test assess on every vote 1", testVoteAssessOnEveryVote1),-         ("test assess on every vote 2", testVoteAssessOnEveryVote2),-         ("test assess on every vote 3", testVoteAssessOnEveryVote3),-         ("test assess on every vote 4", testVoteAssessOnEveryVote4),-         ("test majority with", testVoteMajorityWith),-         ("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),-         ("test assess on time limit 4", testVoteAssessOnTimeLimit4),-         ("test assess on time limit 5", testVoteAssessOnTimeLimit5)]--allTests = and $ map snd tests----Test variable creation-testVar1 :: RuleFunc-testVar1 = voidRule $ do-   NewVar "toto" (1::Integer)-   return ()--testVarEx1 = (variables ^$ execRuleFunc testVar1) == [(Var 0 "toto" (1::Integer))]----Test variable deleting-testVar2 :: RuleFunc-testVar2 = voidRule $ do-   var <- newVar_ "toto" (1::Int)-   delVar var-   return ()--testVarEx2 = _variables (execRuleFunc testVar2) == []----Test variable reading-testVar3 :: RuleFunc-testVar3 = voidRule $ do-   var <- newVar_ "toto" (1::Int)-   a <- readVar var-   case a of-      Just (1::Int) -> newOutput_ "ok" 1-      _ -> newOutput_ "nok" 1--testVarEx3 = isOutput "ok" (execRuleFunc testVar3)----Test variable writing-testVar4 :: RuleFunc-testVar4 = voidRule $ do-   var <- newVar_ "toto" (1::Int)-   writeVar var (2::Int)-   a <- readVar var-   case a of-      Just (2::Int) -> newOutput_ "ok" 1-      _ -> newOutput_ "nok" 1--testVarEx4 = isOutput "ok" (execRuleFunc testVar4)----Test variable writing-testVar5 :: RuleFunc-testVar5 = voidRule $ do-   var <- newVar_ "toto" ([]::[Int])-   writeVar var ([1]::[Int])-   a <- readVar var-   case a of-      Just (a::[Int]) -> do-         writeVar var (2:a)-         return ()-      Nothing -> newOutput_ "nok" 1--testVarEx5 = _variables (execRuleFunc testVar5) == [(Var 0 "toto" ([2,1]::[Int]))]--data Choice = Holland | Sarkozy deriving (Enum, Typeable, Show, Eq, Bounded)---- Test input-testSingleInput :: RuleFunc-testSingleInput = voidRule $ do-    onInputRadioEnum_ "Vote for Holland or Sarkozy" Holland h 1 where-        h a = newOutput_ ("voted for " ++ (show a)) 1--testSingleInputEx = isOutput "voted for Holland" g where-   g = execRuleFuncEvent testSingleInput (inputRadioEnum 1 "Vote for Holland or Sarkozy" Holland) (InputData (RadioData Holland))--testMultipleInputs :: RuleFunc-testMultipleInputs = voidRule $ do-    onInputCheckbox_ "Vote for Holland and Sarkozy" [(Holland, "Holland"), (Sarkozy, "Sarkozy")] h 1 where-        h a = newOutput_ ("voted for " ++ (show a)) 1--testMultipleInputsEx = isOutput "voted for [Holland,Sarkozy]" g where-   g = execRuleFuncEvent testMultipleInputs (inputCheckbox 1 "Vote for Holland and Sarkozy" [(Holland, "Holland"), (Sarkozy, "Sarkozy")]) (InputData (CheckboxData [Holland, Sarkozy]))---testInputString :: RuleFunc-testInputString = voidRule $ do-    onInputText_ "Enter a number:" h 1 where-        h a = newOutput_ ("You entered: " ++ a) 1--testInputStringEx = isOutput "You entered: 1" g where-   g = execRuleFuncEvent testInputString (inputText 1 "Enter a number:") (InputData (TextData "1"))---- Test message-testSendMessage :: RuleFunc-testSendMessage = voidRule $ do-    let msg = Message "msg" :: Event(Message String)-    onEvent_ msg f-    sendMessage msg "toto" where-        f (MessageData a :: EventData(Message String)) = newOutput_ a 1--testSendMessageEx = isOutput "toto" (execRuleFunc testSendMessage)--testSendMessage2 :: RuleFunc-testSendMessage2 = voidRule $ do-    onEvent_ (Message "msg":: Event(Message ())) $ const $ newOutput_ "Received" 1-    sendMessage_ (Message "msg")---testSendMessageEx2 = isOutput "Received" (execRuleFunc testSendMessage2)--data Choice2 = Me | You deriving (Enum, Typeable, Show, Eq, Bounded)---- Test user input + variable read/write-testUserInputWrite :: RuleFunc-testUserInputWrite = voidRule $ do-    newVar_ "vote" (Nothing::Maybe Choice2)-    onEvent_ (Message "voted" :: Event (Message ())) h2-    onEvent_ (InputEv (Input 1 "Vote for" (Radio [(Me, "Me"), (You, "You")]))) h1 where-        h1 (InputData (RadioData a) :: EventData (Input Choice2)) = do-            writeVar (V "vote") (Just a)-            SendMessage (Message "voted") ()-        h1 _ = undefined-        h2 (MessageData _) = do-            a <- readVar (V "vote")-            case a of-                Just (Just Me) -> newOutput_ "voted Me" 1-                _ -> newOutput_ "problem" 1-        h2 _ = undefined--testUserInputWriteEx = isOutput "voted Me" g where-   g = execRuleFuncEvent testUserInputWrite (InputEv (Input 1 "Vote for" (Radio [(Me, "Me"), (You, "You")]))) (InputData (RadioData Me))---- Test rule activation-testActivateRule :: RuleFunc-testActivateRule = voidRule $ do-    a <- GetRules-    if (_rStatus (head a) == Pending) then do-        ActivateRule $ _rNumber (head a)-        return ()-        else return ()---testActivateRuleEx = _rStatus (head $ _rules (execRuleFuncGame testActivateRule testGame {_rules=[testRule]}))  == Active--testAutoActivateEx = _rStatus (head $ _rules (execRuleFuncEventGame autoActivate (RuleEv Proposed) (RuleData testRule) (testGame {_rules=[testRule]})))  == Active----Time tests--testTimeEvent :: RuleFunc-testTimeEvent = voidRule $ do-    onEvent_ (Time date1) f where-        f _ = outputAll $ show date1--testTimeEventEx = isOutput (show date1) g where-   g = execRuleFuncEvent testTimeEvent (Time date1) (TimeData date1)--testTimeEvent2 :: Nomex ()-testTimeEvent2 = schedule' [date1, date2] (outputAll . show)--testTimeEventEx2 = isOutput (show date1) g && isOutput (show date2) g where-    g = flip execState testGame (runEvalError 0 $ evalExp testTimeEvent2 0 >> void gameEvs)-    gameEvs = do-        evTriggerTime date1-        evTriggerTime date2----- Test votes--voteGameActions :: Int -> Int -> Int  -> Bool -> Evaluate () -> Game-voteGameActions positives negatives total timeEvent actions = flip execState testGame {_players = []} $ runEvalError 0 $ do-    mapM_ (\x -> addPlayer (PlayerInfo x $ "coco " ++ (show x))) [1..total]-    actions-    evProposeRule testRule-    evs <- getChoiceEvents-    let pos = take positives evs-    let neg = take negatives $ drop positives evs-    mapM_ (\x -> triggerInput x (URadioData $ fromEnum For)) pos-    mapM_ (\x -> triggerInput x (URadioData $ fromEnum Against)) neg-    when timeEvent $ void $ evTriggerTime date2--voteGame' :: Int -> Int -> Int -> Bool -> RuleFunc -> Game-voteGame' positives negatives notVoted timeEvent rf  = voteGameActions positives negatives notVoted timeEvent $ do-   let rule = testRule {_rName = "testRule", _rRuleFunc = rf, _rNumber = 1, _rStatus = Pending}-   evAddRule rule-   evActivateRule (_rNumber rule) 0-   return ()--voteGame :: Int -> Int -> Int -> RuleFunc -> Game-voteGame positives negatives notVoted rf = voteGame' positives negatives notVoted True rf--voteGameTimed :: Int -> Int -> Int -> RuleFunc -> Game-voteGameTimed positives negatives notVoted rf = voteGame' positives negatives notVoted True rf---- Test application meta rule---unanimityRule = testRule {_rName = "unanimityRule", _rRuleFunc = return $ Meta $ voteWith unanimity $ assessWhenEverybodyVoted, _rNumber = 1, _rStatus = Active}---applicationMetaRuleRule = testRule {_rName = "onRuleProposedUseMetaRules", _rRuleFunc = onRuleProposed checkWithMetarules, _rNumber = 2, _rStatus = Active}---testApplicationMetaRuleVote :: Game---testApplicationMetaRuleVote = voteGameActions 2 0 2 False $ do---    evAddRule unanimityRule---    evActivateRule (_rNumber unanimityRule) 0---    evAddRule applicationMetaRuleRule---    evActivateRule (_rNumber applicationMetaRuleRule) 0---    return ()----testApplicationMetaRuleEx = (_rStatus $ head $ _rules testApplicationMetaRuleVote) == Active---- 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--testVoteRule s g = (_rStatus $ head $ _rules g) == s--isOutput :: String -> Game -> Bool-isOutput s g = any (\(Output _ _ _ mys SActive) -> mys == s) (_outputs g)--
− src/Language/Nomyx/Utils.hs 
@@ -1,62 +0,0 @@-
-
-
-module Language.Nomyx.Utils where
---import Data.Time-import Data.Typeable (cast, Typeable)-import Debug.Trace.Helpers (traceM)-import Data.Maybe (fromJust, catMaybes)-import System.Locale (rfc822DateFormat, defaultTimeLocale)-import Control.Monad.State-import Control.Monad.Identity-import Debug.Trace (trace)---- | durations-oneWeek, oneDay, oneHour, oneMinute :: NominalDiffTime
-oneWeek = 7 * oneDay-oneDay = 24 * oneHour-oneHour = 60 * oneMinute-oneMinute = 60-
--- | an equality that tests also the types.
-(===) :: (Typeable a, Typeable b, Eq b) => a -> b -> Bool
-(===) x y = cast x == Just y
-
--- | Replaces all instances of a value in a list by another value.
-replaceWith :: (a -> Bool)   -- ^ Value to search
-        -> a   -- ^ Value to replace it with
-        -> [a] -- ^ Input list
-        -> [a] -- ^ Output list
-replaceWith f y = map (\z -> if f z then y else z)
--tracePN :: (Monad m ) => Int -> String -> m ()-tracePN pn s = traceM $ "Player " ++ (show pn) ++ " " ++ s--traceData :: (Show a) => String -> a -> a-traceData s a = trace (s ++ " " ++ (show a)) a--mapMaybeM :: (Monad m) => (a -> m (Maybe b)) -> [a] -> m [b]
-mapMaybeM f = liftM catMaybes . mapM f
-
-parse822Time :: String -> UTCTime
-parse822Time = zonedTimeToUTC
-              . fromJust
-              . parseTime defaultTimeLocale rfc822DateFormat
-
-sndMaybe :: (a, Maybe b) -> Maybe (a,b)
-sndMaybe (a, Just b) = Just (a,b)
-sndMaybe (_, Nothing) = Nothing--mapStateIO :: Show s => State s a -> StateT s IO a-mapStateIO = mapStateT $ return . runIdentity--getFreeNumber :: (Eq a, Num a, Enum a) => [a] -> a-getFreeNumber l = head [a| a <- [1..], not $ a `elem` l]---sel :: [a]   -- ^ List of indices to select-    -> [Int] -- ^ List of elements-    -> [a]   -- ^ List composed of elements selected from original set by indices provided-sel xs is = map (\i -> xs!!i) is
+ src/Language/Nomyx/Variables.hs view
@@ -0,0 +1,205 @@+{-# LANGUAGE DeriveDataTypeable, GADTs, ScopedTypeVariables #-}
+
+-- | All the building blocks to allow rules to build variables.
+module Language.Nomyx.Variables where+--   V(..),+--   VEvent(..),
+--   MsgVar(..),
+--   msgVar,+--   newMsgVar, newMsgVar_, newMsgVar',
+--   writeMsgVar, writeMsgVar_,
+--   readMsgVar, readMsgVar_,+--   modifyMsgVar,
+--   delMsgVar,
+--   onMsgVarEvent, onMsgVarChange,
+--   getMsgVarMessage,
+--   getMsgVarData, getMsgVarData_,+--   getMsgVarName,
+--   ArrayVar,
+--   newArrayVar, newArrayVar_, newArrayVar',
+--   cleanOnFull,
+--   isFullArrayVar_,   
+--   putArrayVar, putArrayVar_+   
+
+import Language.Nomyx.Expression+import Language.Nomyx.Events
+import Data.Typeable
+import Control.Monad.State
+import Data.Maybe
+import qualified Data.Map as M
+import Data.Map hiding (map, filter, insert, mapMaybe, null)
+
+
+-- * Variables
+-- | variable creation
+newVar :: (Typeable a, Show a, Eq a) => VarName -> a -> Nomex (Maybe (V a))
+newVar = NewVar
+
+newVar_ :: (Typeable a, Show a, Eq a) => VarName -> a -> Nomex (V a)
+newVar_ s a = partial "newVar_: Variable existing" (newVar s a)
+
+-- | variable reading
+readVar :: (Typeable a, Show a, Eq a) => (V a) -> Nomex (Maybe a)
+readVar = ReadVar
+
+readVar_ :: forall a. (Typeable a, Show a, Eq a) => (V a) -> Nomex a
+readVar_ v@(V a) = partial ("readVar_: Variable \"" ++ a ++ "\" with type \"" ++ (show $ typeOf v) ++ "\" not existing") (readVar v)
+
+-- | variable writing
+writeVar :: (Typeable a, Show a, Eq a) => (V a) -> a -> Nomex Bool
+writeVar = WriteVar
+
+writeVar_ :: (Typeable a, Show a, Eq a) => (V a) -> a -> Nomex ()
+writeVar_ var val = void $ writeVar var val
+
+-- | modify a variable using the provided function
+modifyVar :: (Typeable a, Show a, Eq a) => (V a) -> (a -> a) -> Nomex ()
+modifyVar v f = writeVar_ v . f =<< readVar_ v
+
+-- | delete variable
+delVar :: (V a) -> Nomex Bool
+delVar = DelVar
+
+delVar_ :: (V a) -> Nomex ()
+delVar_ v = void $ delVar v
+
+-- * Message Variable
+-- | a MsgVar is a variable with a message attached, allowing to trigger registered functions anytime the var if modified
+data VEvent a = VUpdated a | VDeleted deriving (Typeable, Show, Eq)
+data MsgVar a = MsgVar {message :: (Msg (VEvent a)), variable :: (V a) }
+
+msgVar :: String -> MsgVar a
+msgVar a = MsgVar (Message a) (V a)
+
+newMsgVar :: (Typeable a, Show a, Eq a) => VarName -> a -> Nomex (Maybe (MsgVar a))
+newMsgVar name a = do
+    mv <- newVar name a
+    return $ mv >>= Just . MsgVar (Message name)
+
+newMsgVar_ :: (Typeable a, Show a, Eq a) => VarName -> a -> Nomex (MsgVar a)
+newMsgVar_ name a = partial "newMsgVar_: Variable existing" (newMsgVar name a)
+
+
+newMsgVar' :: (Typeable a, Show a, Eq a) => VarName -> a -> (VEvent a -> Nomex()) -> Nomex (Maybe (MsgVar a))
+newMsgVar' name a f = do
+    mv <- newMsgVar name a
+    case mv of
+       Just (MsgVar m _) -> do
+          onMessage m $ f . messageData
+          return mv
+       Nothing -> return Nothing
+
+writeMsgVar :: (Typeable a, Show a, Eq a) => MsgVar a -> a -> Nomex Bool
+writeMsgVar (MsgVar m v) a = do
+   r <- writeVar v a
+   sendMessage m (VUpdated a)
+   return r
+
+writeMsgVar_ :: (Typeable a, Show a, Eq a) => MsgVar a -> a -> Nomex ()
+writeMsgVar_ mv a = void $ writeMsgVar mv a
+
+readMsgVar :: (Typeable a, Show a, Eq a) => MsgVar a -> Nomex (Maybe a)
+readMsgVar (MsgVar _ v) = readVar v
+
+readMsgVar_ :: (Typeable a, Show a, Eq a) => MsgVar a -> Nomex a
+readMsgVar_ mv = partial "readMsgVar_: variable not existing" (readMsgVar mv)
+
+modifyMsgVar :: (Typeable a, Show a, Eq a) => MsgVar a -> (a -> a) -> Nomex ()
+modifyMsgVar mv f = writeMsgVar_ mv . f =<< readMsgVar_ mv
+
+delMsgVar :: (Typeable a, Show a, Eq a) => MsgVar a -> Nomex Bool
+delMsgVar (MsgVar m v) = do
+   sendMessage m VDeleted
+   delAllEvents m
+   delVar v
+
+onMsgVarChange :: (Typeable a, Show a, Eq a) => MsgVar a -> (VEvent a -> Nomex()) -> Nomex ()
+onMsgVarChange mv f = do
+   m <- getMsgVarMessage mv
+   onMessage m $ \(MessageData v) -> f v
+
+onMsgVarEvent :: (Typeable a, Show a, Eq a)
+               => MsgVar a
+               -> (a -> Nomex b)
+               -> (a -> b -> Nomex())
+               -> (b -> Nomex())
+               -> Nomex ()
+onMsgVarEvent mv create update delete = do
+   val <- readMsgVar_ mv
+   c <- create val
+   onMsgVarChange mv $ f c where
+      f c' (VUpdated v) = update v c'
+      f c' VDeleted     = delete c'
+
+-- | get the messsage triggered when the array is filled
+getMsgVarMessage :: (Typeable a, Show a, Eq a) => (MsgVar a) -> Nomex (Msg (VEvent a))
+getMsgVarMessage (MsgVar m _) = return m
+
+-- | get the association array
+getMsgVarData :: (Typeable a, Show a, Eq a) => (MsgVar a) -> Nomex (Maybe a)
+getMsgVarData (MsgVar _ v) = readVar v
+
+getMsgVarData_ :: (Typeable a, Show a, Eq a) => (MsgVar a) -> Nomex a
+getMsgVarData_ (MsgVar _ v) = readVar_ v
+
+getMsgVarName :: (Typeable a, Show a, Eq a) => (MsgVar a) -> String
+getMsgVarName (MsgVar _ (V varName)) = varName
+
+    
+-- * Variable arrays
+-- | ArrayVar is an indexed array with a signal attached triggered at every change.
+-- | each indexed elements starts empty (value=Nothing).
+type ArrayVar i a = MsgVar [(i, Maybe a)]
+
+-- | initialize an empty ArrayVar
+newArrayVar :: (Typeable a, Show a, Eq a, Typeable i, Show i, Eq i) => VarName -> [i] -> Nomex (Maybe (ArrayVar i a))
+newArrayVar name l = do
+    let list = map (\i -> (i, Nothing)) l
+    newMsgVar name list
+
+newArrayVar_ :: (Typeable a, Show a, Eq a, Typeable i, Show i, Eq i) => VarName -> [i] -> Nomex (ArrayVar i a)
+newArrayVar_ name l = partial "newArrayVar_: Variable existing" (newArrayVar name l)
+
+-- | initialize an empty ArrayVar, registering a callback that will be triggered at every change
+newArrayVar' :: (Typeable a, Show a, Eq a, Typeable i, Show i, Eq i) => VarName -> [i] -> (VEvent [(i,Maybe a)] -> Nomex ()) -> Nomex (Maybe (ArrayVar i a))
+newArrayVar' name l f = do
+    let list = map (\i -> (i, Nothing)) l
+    newMsgVar' name list f
+
+-- | initialize an empty ArrayVar, registering a callback.
+-- the ArrayVar will be deleted when full
+newArrayVarOnce :: (Ord i, Typeable a, Show a, Eq a, Typeable i, Show i) => VarName -> [i] -> (VEvent [(i, Maybe a)] -> Nomex ()) -> Nomex (Maybe (ArrayVar i a))
+newArrayVarOnce name l f = do
+   mv <- newArrayVar' name l f
+   when (isJust mv) $ cleanOnFull $ fromJust mv
+   return mv
+
+cleanOnFull :: (Typeable a, Show a, Eq a, Ord i, Typeable i, Show i) => (ArrayVar i a) -> Nomex ()
+cleanOnFull ar = do
+   m <- getMsgVarMessage ar 
+   onMessage m $ \_ -> do
+      full <- (isFullArrayVar_ ar)
+      when full $ void $ delMsgVar ar
+      return ()
+   return ()
+
+isFullArrayVar_ :: (Ord i, Typeable a, Show a, Eq a, Typeable i, Show i) => (ArrayVar i a) -> Nomex Bool
+isFullArrayVar_ av = do
+   md <- getMsgVarData av
+   return $ and $ map isJust $ map snd $ fromJust md
+       
+   
+-- | store one value and the given index. If this is the last filled element, the registered callbacks are triggered.
+putArrayVar :: (Ord i, Typeable a, Show a, Eq a, Typeable i, Show i) => (ArrayVar i a) -> i -> a -> Nomex Bool
+putArrayVar mv i a = do
+    ma <- readMsgVar mv
+    case ma of
+       Just ar -> do
+          let ar2 = M.insert i (Just a) (fromList ar)
+          writeMsgVar mv (toList ar2)
+       Nothing -> return False
+
+putArrayVar_ :: (Ord i, Typeable a, Show a, Eq a, Typeable i, Show i) => (ArrayVar i a) -> i -> a -> Nomex ()
+putArrayVar_ mv i a = void $ putArrayVar mv i a       
+
src/Language/Nomyx/Vote.hs view
@@ -6,16 +6,21 @@  import Prelude hiding (foldr)
 import Language.Nomyx.Expression
-import Language.Nomyx.Definition-import Language.Nomyx.Rule
+import Language.Nomyx.Events+import Language.Nomyx.Variables+import Language.Nomyx.Outputs+import Language.Nomyx.Inputs+import Language.Nomyx.Players+import Language.Nomyx.Rules
 import Data.Typeable
 import Control.Monad.State hiding (forM_)
 import Data.Maybe import Data.Time hiding (getCurrentTime)
 import Control.Arrow
 import Control.Applicative
-import Language.Nomyx.Utils+--import Language.Nomyx.Utils import Data.List+import Data.Function import qualified Data.Map as M import Control.Monad.Error (MonadError(..)) @@ -25,10 +30,10 @@  class (Eq (Alts a), Show (Alts a), Ord (Alts a), Typeable a) => Votable a where    data Alts a-   alts :: [Alts a]-   quota :: Alts a -> Int -> Int -> Int+   alts :: [Alts a]                                -- The alternatives+   quota :: Alts a -> Int -> Int -> Int            -- "quota alts q total" gives the quota to reach for each alternatives    name :: a -> String-   exclusiveWinner :: a ->  Maybe (Alts a, Alts a)+   exclusiveWinner :: a ->  Maybe (Alts a, Alts a) --The Votable as only two alternatives, one excluding the other    exclusiveWinner _ = Nothing  type ForAgainst = Alts Rule
@@ -71,7 +76,7 @@     --set the assessors     evalStateT assessors voteData     --display the vote-    mapM (\n -> displayVoteVar n ("Votes for " ++ toVoteName ++ ":") voteVar) pns+    displayVoteVar Nothing ("On-going vote for " ++ toVoteName ++ ":") voteVar     displayVoteResult toVoteName voteData     --clean the vote at the end     cleanVote voteData@@ -151,6 +156,27 @@ -- | assess the vote results according to a necessary number of positive votes
 numberVotes :: (Votable a) => Int -> VoteStats a -> [Alts a]
 numberVotes i vs = voteQuota i vs
++-- | the winners are the x vote alternatives with the more votes
+firstXBest :: forall a. (Votable a) => Int -> VoteStats a -> [Alts a]
+firstXBest x votes = map fst $ takeInGroups x $ sortedVotesWithExAequoGroups where+   voted (Just a, n) = Just (a, n)+   voted (Nothing, _) = Nothing+   sortedVotesWithExAequoGroups :: [[(Alts a, Int)]]+   sortedVotesWithExAequoGroups = (groupBy ((==) `on` snd)) $ sortWith snd $ catMaybes $ map voted $ M.assocs (voteCounts votes)++--take n elements from the first lists, but do not break groups+takeInGroups :: Int -> [[a]] -> [a]+takeInGroups 0 _ = []+takeInGroups n grps = if grpsSize <= n then (head grps) ++ takeInGroups (n - grpsSize) (tail grps) else (head grps) where+   grpsSize = length $ head grps++-- | the winner is the vote alternative with the more votes
+firstBest :: (Votable a) => VoteStats a -> [Alts a]
+firstBest = firstXBest 1++sortWith :: Ord b => (a -> b) -> [a] -> [a]+sortWith f = sortBy (\x y -> compare (f x) (f y)) 
 -- | return the vote alternatives that are above threshold
 voteQuota :: forall a. (Votable a) => Int -> VoteStats a -> [Alts a]
@@ -158,6 +184,7 @@    Nothing -> catMaybes $ M.keys $ M.filter (>= q) (voteCounts votes)    Just a -> maybeToList $ exclusiveVoteQuota q votes a +-- | in case of exclusive winner exclusiveVoteQuota :: (Votable a) => Int -> VoteStats a -> (Alts a, Alts a) -> Maybe (Alts a) exclusiveVoteQuota q votes (for, against)    | M.findWithDefault 0 (Just for) vs     >= q                   = Just for@@ -188,10 +215,8 @@ counts as = map (head &&& length) (group $ sort as)  -displayVoteVar :: (Votable a) => PlayerNumber -> String -> ArrayVar PlayerNumber (Alts a) -> Nomex ()-displayVoteVar pn title mv = do-   sp <- showPlayer-   displayVar pn mv (showVotes title sp)+displayVoteVar :: (Votable a) => (Maybe PlayerNumber) -> String -> ArrayVar PlayerNumber (Alts a) -> Nomex ()+displayVoteVar mpn title mv = displayVar mpn mv (showOnGoingVote title)   showChoice :: (Votable a) => Maybe (Alts a) -> String@@ -199,22 +224,31 @@ showChoice Nothing  = "Not Voted"  showChoices :: (Votable a) => [(Alts a)] -> String+showChoices [] = "no result" showChoices cs = concat $ intersperse ", " $ map show cs -showVotes :: (Votable a) => String -> (PlayerNumber -> String) -> [(PlayerNumber, Maybe (Alts a))] -> String-showVotes title showPlayer l = title ++ "\n" ++-                     concatMap (\(i,a) -> (showPlayer i) ++ "\t" ++ (showChoice a) ++ "\n") l+showOnGoingVote :: (Votable a) => String -> [(PlayerNumber, Maybe (Alts a))] -> Nomex String+showOnGoingVote title listVotes = do+   list <- mapM showVote listVotes+   return $ title ++ "\n" ++ concatMap (\(name, vote) -> name ++ "\t" ++ vote ++ "\n") list -showVotes' :: (Votable a) => (PlayerNumber -> String) -> [(PlayerNumber, Maybe (Alts a))] -> String-showVotes' showPlayer l = concat $ intersperse ", " $ map (\(i,a) -> (showPlayer i) ++ ": " ++ (showChoice a)) voted where-   voted = filter (\(_, r) -> isJust r) l+showFinishedVote :: (Votable a) =>  [(PlayerNumber, Maybe (Alts a))] -> Nomex String+showFinishedVote l = do+   let voted = filter (\(_, r) -> isJust r) l+   votes <- mapM showVote voted+   return $ concat $ intersperse ", " $ map (\(name, vote) -> name ++ ": " ++ vote) votes++showVote :: (Votable a) => (PlayerNumber, Maybe (Alts a)) -> Nomex (String, String)+showVote (pn, v) = do+   name <- showPlayer pn+   return (name, showChoice v)                                               
 displayVoteResult :: (Votable a) => String -> VoteData a -> Nomex () displayVoteResult toVoteName (VoteData msgEnd voteVar _ _) = onMessage msgEnd $ \(MessageData result) -> do
    vs <- getMsgVarData_ voteVar-   sp <- showPlayer-   outputAll $ "Vote result for " ++ toVoteName ++ ": " ++ (showChoices result) ++-               " (" ++ showVotes' sp vs ++ ")"+   votes <- showFinishedVote vs+   outputAll' $ "Vote result for " ++ toVoteName ++ ": " ++ (showChoices result) +++               " (" ++ votes ++ ")"  -- | any new rule will be activate if the rule in parameter returns True
 onRuleProposed :: (Rule -> Nomex (Msg [ForAgainst]) ) -> RuleFunc
@@ -222,6 +256,8 @@     resp <- f rule     onMessageOnce resp $ (activateOrReject rule) . (== [For]) . messageData ++ -- * Referendum & elections  data Referendum = Referendum String deriving (Typeable)@@ -237,10 +273,10 @@    msg <- voteWith_ (majority `withQuorum` 2) (assessOnEveryVote >> assessOnTimeDelay oneDay) (Referendum name)    onMessageOnce msg resolution where       resolution (MessageData [Yes]) = do-            outputAll "Positive result of referendum"+            outputAll' "Positive result of referendum"             action-      resolution (MessageData [No]) = outputAll "Negative result of referendum"-      resolution (MessageData [])   = outputAll "No result for referendum"+      resolution (MessageData [No]) = outputAll' "Negative result of referendum"+      resolution (MessageData [])   = outputAll' "No result for referendum"       resolution (MessageData _)    = throwError "Impossible result for referendum"  @@ -262,10 +298,10 @@  elections :: String -> [PlayerInfo] -> (PlayerNumber -> Nomex()) -> Nomex () elections name pns action = do-   msg <- voteWith majority (assessWhenEverybodyVoted {-assessOnEveryVotes >> assessOnTimeDelay oneDay-}) (Election name) (Candidate <$> pns)+   msg <- voteWith majority (assessOnTimeDelay oneDay) (Election name) (Candidate <$> pns)    onMessageOnce msg resolution where       resolution (MessageData [Candidate pi]) = do-         outputAll $ "Result of elections: player(s) " ++ (show $ _playerName pi) ++ " won!"+         outputAll' $ "Result of elections: player(s) " ++ (show $ _playerName pi) ++ " won!"          action $ _playerNumber pi-      resolution (MessageData []) = outputAll $ "Result of elections: nobody won!"+      resolution (MessageData []) = outputAll' "Result of elections: nobody won!"       resolution (MessageData _)  = throwError "Impossible result for elections"