Nomyx-Language (empty) → 0.2.0

raw patch · 13 files changed

+2060/−0 lines, 13 filesdep +Booleandep +DebugTraceHelpersdep +basesetup-changed

Dependencies added: Boolean, DebugTraceHelpers, base, containers, data-lens, data-lens-fd, data-lens-template, ghc, hint-server, hslogger, mtl, old-locale, safe, safecopy, stm, template-haskell, time, time-recurrence

Files

• AUTHORS +1/−0
• LICENSE +27/−0
• Nomyx-Language.cabal +42/−0
• README +23/−0
• Setup.lhs +6/−0
• src/Language/Nomyx.hs +15/−0
• src/Language/Nomyx/Definition.hs +469/−0
• src/Language/Nomyx/Evaluation.hs +281/−0
• src/Language/Nomyx/Examples.hs +139/−0
• src/Language/Nomyx/Expression.hs +320/−0
• src/Language/Nomyx/Game.hs +213/−0
• src/Language/Nomyx/Rule.hs +252/−0
• src/Language/Nomyx/Test.hs +272/−0

@@ -0,0 +1,1 @@+Corentin Dupont <corentin.dupont@gmail.com>

@@ -0,0 +1,27 @@+Copyright 2012, Corentin Dupont. All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice,+   this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of its contributors may be+   used to endorse or promote products derived from this software without+   specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE+LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR+CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF+SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS+INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN+CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)+ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,42 @@+name: Nomyx-Language+version: 0.2.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+license: BSD3+license-file: LICENSE+copyright: 2012 Corentin Dupont+maintainer: Corentin Dupont+stability: Experimental+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+author: Corentin Dupont+data-files: src/Language/Nomyx/Definition.hs+            src/Language/Nomyx/Examples.hs src/Language/Nomyx/Expression.hs+            src/Language/Nomyx/Rule.hs src/Language/Nomyx/Test.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+    exposed-modules: Language.Nomyx+                     Language.Nomyx.Expression +                     Language.Nomyx.Definition+                     Language.Nomyx.Evaluation +                     Language.Nomyx.Examples+                     Language.Nomyx.Rule +                     Language.Nomyx.Test+                     Language.Nomyx.Game+                     Paths_Nomyx_Language+    exposed: True+    buildable: True+    hs-source-dirs: src+    ghc-options: -W+ 

@@ -0,0 +1,23 @@++== Introduction ==++This library is defining the language to express rules in Nomic.++=== Installation ===++This libary is used by the package Nomyx, it should be installed through it.++=== Documentation ===++The library cames with haddock documentation you can build+(see above). Check examples/Examples.hs to see a list of example rules. +Simply copy-paste those rules (the function name or the code) in the field "code"+on Nomyx web gui and see what happens!++=== Contact  ===++Bug-reports, questions, suggestions and patches are all welcome.++To get a copy of the git repository:+git clone git://github.com/cdupont/Nomic.git+

@@ -0,0 +1,6 @@+#!/usr/bin/runhaskell +> module Main where+> import Distribution.Simple+> main :: IO ()+> main = defaultMain+

@@ -0,0 +1,15 @@++module Language.Nomyx (+   module Language.Nomyx.Expression,+   module Language.Nomyx.Definition,+   module Language.Nomyx.Rule,+   module Language.Nomyx.Examples,+   module Language.Nomyx.Evaluation)  where++import Language.Nomyx.Expression+import Language.Nomyx.Definition+import Language.Nomyx.Rule+import Language.Nomyx.Examples+import Language.Nomyx.Evaluation++

@@ -0,0 +1,469 @@+{-# 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 System.Locale (defaultTimeLocale, rfc822DateFormat)
+import Data.Time.Recurrence hiding (filter)
+import Safe
+import Data.Lens
+import Control.Applicative
+import Data.Boolean+import Control.Monad.Error+
+-- * 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 = do
+    mv <- NewVar s a
+    case mv of
+        Just var -> return var
+        Nothing -> throwError "newVar_: Variable existing"
+
+-- | 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) = do
+    ma <- ReadVar v
+    case ma of
+        Just (val:: a) -> return val
+        Nothing -> throwError $ "readVar_: Variable \"" ++ a ++ "\" with type \"" ++ (show $ typeOf v) ++ "\" not existing"
+
+-- | 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 = do
+    ma <- WriteVar var val
+    case ma of
+       True -> return ()
+       False -> throwError "writeVar_: Variable not existing"
+
+-- | 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 = DelVar v >> return ()
+
+-- * Variable arrays
+-- | ArrayVar is an indexed array with a signal attached to warn when the array is filled.
+--each indexed elements starts empty (value=Nothing), and when the array is full, the signal is triggered.
+--This is useful to wait for a serie of events to happen, and trigger a computation on the collected results.
+data ArrayVar i a = ArrayVar (Event (Message [(i, Maybe a)])) (V (Map i (Maybe a)))
+
+-- | initialize an empty ArrayVar
+newArrayVar :: (Ord i, Typeable a, Show a, Eq a, Typeable i, Show i) => VarName -> [i] -> Nomex (ArrayVar i a)
+newArrayVar name l = do
+    let list = map (\i -> (i, Nothing)) l
+    v <- newVar_ name (fromList list)
+    return $ ArrayVar (Message name) v
+
+-- | initialize an empty ArrayVar, registering a callback that will be triggered when the array is filled
+newArrayVar' :: (Ord i, Typeable a, Show a, Eq a, Typeable i, Show i) => VarName -> [i] -> ([(i,Maybe a)] -> Nomex ()) -> Nomex (ArrayVar i a)
+newArrayVar' name l f = do
+    av@(ArrayVar m _) <- newArrayVar name l
+    onMessage m $ f . messageData
+    return av
+
+-- | initialize an empty ArrayVar, registering a callback.
+--the callback will be triggered when the array is filled, and then the ArrayVar will be deleted
+newArrayVarOnce :: (Ord i, Typeable a, Show a, Eq a, Typeable i, Show i) => VarName -> [i] -> ([(i, Maybe a)] -> Nomex ()) -> Nomex (ArrayVar i a)
+newArrayVarOnce name l f = do
+   av@(ArrayVar m _) <- newArrayVar name l
+   onMessage m $ \a -> do
+      f $ messageData a
+      full <- (isFullArrayVar av)
+      when full $ delArrayVar av
+   return av where
+
+
+isFullArrayVar :: (Ord i, Typeable a, Show a, Eq a, Typeable i, Show i) => (ArrayVar i a) -> Nomex (Bool)
+isFullArrayVar av = do
+   d <- getArrayVarData av
+   let full = and $ map isJust $ map snd d
+   return full
+   
+-- | 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 ()
+putArrayVar (ArrayVar m v) i a = do
+    ar <- readVar_ v
+    let ar2 = M.insert i (Just a) ar
+    writeVar_ v ar2
+    sendMessage m (toList ar2)
+
+-- | get the messsage triggered when the array is filled
+getArrayVarMessage :: (Ord i, Typeable a, Show a, Eq a, Typeable i, Show i) => (ArrayVar i a) -> Nomex (Event (Message [(i, Maybe a)]))
+getArrayVarMessage (ArrayVar m _) = return m
+
+-- | get the association array
+getArrayVarData :: (Ord i, Typeable a, Show a, Eq a, Typeable i, Show i) => (ArrayVar i a) -> Nomex ([(i, Maybe a)])
+getArrayVarData (ArrayVar _ v) = toList <$> (readVar_ v)
+
+-- | get the association array with only the filled values
+getArrayVarData' :: (Ord i, Typeable a, Show a, Eq a, Typeable i, Show i) => (ArrayVar i a) -> Nomex ([(i, a)])
+getArrayVarData' v = catMaybes . map sndMaybe <$> (getArrayVarData v)
+
+delArrayVar :: (Ord i, Typeable a, Show a, Eq a, Typeable i, Show i) => (ArrayVar i a) -> Nomex ()
+delArrayVar (ArrayVar m v) = delAllEvents m >> delVar_ v
+
+-- * 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) => Event (Message a) -> a -> Nomex ()
+sendMessage = SendMessage
+
+sendMessage_ :: Event (Message ()) -> Nomex ()
+sendMessage_ m = SendMessage m ()
+
+-- | subscribe on a message 
+onMessage :: (Typeable m, Show m) => Event (Message m) -> ((EventData (Message m)) -> Nomex ()) -> Nomex ()
+onMessage m f = onEvent_ m f
+
+onMessageOnce :: (Typeable m, Show m) => Event (Message m) -> ((EventData (Message 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 -> RuleNumber -> String -> Nomex ()
+addRuleParams_ name func code number desc = addRule_ $ defaultRule {_rName = name, _rRuleFunc = func, _rRuleCode = code, _rNumber = number, _rDescription = desc}
+
+--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
+
+inputChoice :: (Eq c, Show c) => PlayerNumber -> String -> [c] -> c -> Event (InputChoice c)
+inputChoice = InputChoice
+
+inputChoiceHead :: (Eq c, Show c) => PlayerNumber -> String -> [c] -> Event (InputChoice c)
+inputChoiceHead pn title choices = inputChoice pn title choices (head choices)
+
+inputChoiceEnum :: forall c. (Enum c, Bounded c, Typeable c, Eq c,  Show c) => PlayerNumber -> String -> c -> Event (InputChoice c)
+inputChoiceEnum pn title defaultChoice = inputChoice pn title (enumFrom (minBound::c)) defaultChoice
+
+inputString :: PlayerNumber -> String -> Event InputString
+inputString = InputString
+
+-- | triggers a choice input to the user. The result will be sent to the callback
+onInputChoice :: (Typeable a, Eq a,  Show a) => String -> [a] -> (EventNumber -> a -> Nomex ()) -> PlayerNumber -> Nomex EventNumber
+onInputChoice title choices handler pn = onEvent (inputChoiceHead pn title choices) (\(en, a) -> handler en (inputChoiceData a))
+
+-- | the same, disregard the event number
+onInputChoice_ :: (Typeable a, Eq a, Show a) => String -> [a] -> (a -> Nomex ()) -> PlayerNumber -> Nomex ()
+onInputChoice_ title choices handler pn = onEvent_ (inputChoiceHead pn title choices) (handler . inputChoiceData)
+
+-- | the same, suppress the event after first trigger
+onInputChoiceOnce :: (Typeable a, Eq a, Show a) => String -> [a] -> (a -> Nomex ()) -> PlayerNumber -> Nomex EventNumber
+onInputChoiceOnce title choices handler pn = onEventOnce (inputChoiceHead pn title choices) (handler . inputChoiceData)
+
+-- | the same, disregard the event number
+onInputChoiceOnce_ :: (Typeable a, Eq a, Show a) => String -> [a] -> (a -> Nomex ()) -> PlayerNumber -> Nomex ()
+onInputChoiceOnce_ title choices handler pn = onEventOnce_ (inputChoiceHead pn title choices) (handler . inputChoiceData)
+
+-- | triggers a choice input to the user, using an enumerate as input
+onInputChoiceEnum :: forall a. (Enum a, Bounded a, Typeable a, Eq a,  Show a) => String -> a -> (EventNumber -> a -> Nomex ()) -> PlayerNumber -> Nomex EventNumber
+onInputChoiceEnum title defaultChoice handler pn = onEvent (inputChoiceEnum pn title defaultChoice) (\(en, a) -> handler en (inputChoiceData a))
+
+-- | the same, disregard the event number
+onInputChoiceEnum_ :: forall a. (Enum a, Bounded a, Typeable a, Eq a,  Show a) => String -> a -> (a -> Nomex ()) -> PlayerNumber -> Nomex ()
+onInputChoiceEnum_ title defaultChoice handler pn = onEvent_ (inputChoiceEnum pn title defaultChoice) (handler . inputChoiceData)
+
+-- | the same, suppress the event after first trigger
+onInputChoiceEnumOnce_ :: forall a. (Enum a, Bounded a, Typeable a, Eq a,  Show a) => String -> a -> (a -> Nomex ()) -> PlayerNumber -> Nomex ()
+onInputChoiceEnumOnce_ title defaultChoice handler pn = onEventOnce_ (inputChoiceEnum pn title defaultChoice) (handler . inputChoiceData)
+
+
+-- | triggers a string input to the user. The result will be sent to the callback
+onInputString :: String -> (EventNumber -> String -> Nomex ()) -> PlayerNumber -> Nomex EventNumber
+onInputString title handler pn = onEvent (inputString pn title) (\(en, a) -> handler en (inputStringData a))
+
+-- | asks the player pn to answer a question, and feed the callback with this data.
+onInputString_ :: String -> (String -> Nomex ()) -> PlayerNumber -> Nomex ()
+onInputString_ title handler pn = onEvent_ (inputString pn title) (handler . inputStringData)
+
+-- | asks the player pn to answer a question, and feed the callback with this data.
+onInputStringOnce_ :: String -> (String -> Nomex ()) -> PlayerNumber -> Nomex ()
+onInputStringOnce_ title handler pn = onEventOnce_ (inputString pn title) (handler . inputStringData)
+
+-- * Victory, 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
+++
+-- * Victory, output, 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]
+
+-- | outputs a message to one player
+output :: String -> PlayerNumber -> Nomex ()
+output s pn = Output pn s
+
+outputAll :: String -> Nomex ()
+outputAll s = getPlayers >>= mapM_ ((output s) . _playerNumber)
+
+getCurrentTime :: Nomex UTCTime
+getCurrentTime = CurrentTime
+
+-- | allows a rule to retrieve its self 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
+
+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
+
+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 -> (Event (Message Bool)) -> Nomex (Event (Message 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 :: (Event (Message Bool)) -> (Event (Message Bool)) -> Nomex (Event (Message 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 ((_, Just a):(_, Just b):[]) = sendMessage m $ a && b+        f _ _ = return ()+
+
+-- | a default rule
+defaultRule = Rule  {
+    _rNumber       = 1,
+    _rName         = "",
+    _rDescription  = "",
+    _rProposedBy   = 0,
+    _rRuleCode     = "",
+    _rRuleFunc     = return Void,
+    _rStatus       = Pending,
+    _rAssessedBy   = Nothing}

@@ -0,0 +1,281 @@+{-# LANGUAGE FlexibleInstances, NoMonomorphismRestriction, GADTs, NamedFieldPuns, ScopedTypeVariables, DoAndIfThenElse #-}++module Language.Nomyx.Evaluation where++import Prelude hiding ((.))+import Language.Nomyx.Expression+import Control.Monad+import Data.Maybe+import Control.Monad.State.Lazy+import Data.List+import Data.Typeable+import Data.Function hiding ((.))+import Data.Time+import Debug.Trace+import Data.Lens+import Control.Category+import Control.Monad.Error (ErrorT(..))+import Control.Monad.Error.Class (MonadError(..))+import Language.Nomyx.Definition (outputAll)++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) rn = do+   vars <- access variables+   let newVars = replaceWith ((== name) . getL vName) (Var rn name val) vars+   case find (\(Var _ myName _) -> myName == name) vars of+      Nothing -> return False+      Just _ -> do+         variables ~= newVars+         return True++evalExp (OnEvent event handler) rn = do+   evs <- access events+   let en = getFreeNumber (map _eventNumber evs)+   events %= ((EH en rn event handler) : )+   return en++evalExp (DelEvent en) rn = do+   evs <- access events+   case find ((== en) . getL eventNumber) evs of+      Nothing -> return False+      Just eh -> do+         if ((ruleNumber ^$) eh == rn) then do+            events %= filter ((/= en) . getL eventNumber)+            return True+         else return False++evalExp (SendMessage (Message id) myData) _ = do+   triggerEvent (Message id) (MessageData myData)+   return ()++evalExp (DelAllEvents e)      _  = void $ events %= filter (\EH {event} -> not $ event === e)+evalExp (Output pn string)    _  = outputS pn string >> return ()+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 (DelRule del)         _  = evDelRule del+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)+   return ()+++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 ()+triggerEvent e dat = do+   evs <- access events+   let filtered = filter (\(EH {event}) -> e === event) evs+   mapM_ f filtered where+       f (EH {_ruleNumber, _eventNumber, handler}) = case cast handler of+           Just castedH -> do+               let (exp :: Nomex ()) = castedH (_eventNumber, dat)+               evalExp (exp `catchError` errorHandler) _ruleNumber+           Nothing -> outputS 1 ("failed " ++ (show $ typeOf handler))++errorHandler :: String -> Nomex ()+errorHandler s = outputAll $ "Error: " ++ s++triggerChoice :: Int -> Int -> Evaluate ()+triggerChoice myEventNumber choiceIndex = do+   evs <- access events+   let filtered = filter ((== myEventNumber) . getL eventNumber) evs+   mapM_ (execChoiceHandler myEventNumber choiceIndex) filtered++execChoiceHandler :: EventNumber -> Int -> EventHandler -> Evaluate ()+execChoiceHandler eventNumber choiceIndex (EH _ _ (InputChoice ruleNumber _ cs _) handler) = evalExp (handler (eventNumber, InputChoiceData (cs!!choiceIndex))) ruleNumber+execChoiceHandler _ _ _ = return ()+++--execute all the handlers of the specified event with the given data+findEvent :: EventNumber -> [EventHandler] -> Maybe (EventHandler)+findEvent en evs = find ((== en) . getL eventNumber) evs+++findChoice :: (Eq a, Read a) => String -> Event (InputChoice a) -> a+findChoice s (InputChoice _ _ choices _) = fromJust $ find (== (read s)) choices++outputS :: PlayerNumber -> String -> Evaluate ()+outputS pn s = void $ outputs %= ((pn, s) : )++getFreeNumber :: (Eq a, Num a, Enum a) => [a] -> a+getFreeNumber l = head [a| a <- [1..], not $ a `elem` l]+++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 ((== rn) . getL rNumber) 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 ((== rn) . getL rNumber) 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++evDelRule :: RuleNumber -> Evaluate Bool+evDelRule del = do+   rs <- access rules+   case find ((== del) . getL rNumber) rs of+      Nothing -> return False+      Just r -> do+         let newRules = filter ((/= del) . getL rNumber) rs+         rules ~= newRules+         delVarsRule del+         delEventsRule del+         triggerEvent (RuleEv Deleted) (RuleData r)+         return True++--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++evInputChoice :: (Eq d, Show d, Typeable d, Read d) => Event(InputChoice d) -> d -> Evaluate ()+evInputChoice ic d = triggerEvent ic (InputChoiceData d)++evTriggerTime :: UTCTime -> Evaluate ()+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 = void $ events %= filter ((/= rn) . getL ruleNumber)++traceState :: String -> State s String+traceState x = state (\s -> trace ("trace: " ++ x) (x, 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 $ outputs %= ((pn, "Error: " ++ e) : )

@@ -0,0 +1,139 @@+{-# LANGUAGE TupleSections, GADTs #-}++-- | 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.+--Don't hesitate to get inspiration from there and create your own rules!+module Language.Nomyx.Examples(nothing, helloWorld, accounts, createBankAccount, winXEcuPerDay, winXEcuOnRuleAccepted, moneyTransfer,+    delRule, voteWithMajority, king, makeKing, monarchy, revolution, victoryXRules, victoryXEcu, displayTime, noGroupVictory, iWin,+    returnToDemocracy, banPlayer, 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 Data.Function+import Data.Time.Clock hiding (getCurrentTime)+import Data.Time.Recurrence hiding (filter)+import Control.Arrow+import Data.List+import Control.Monad++-- | A rule that does nothing+nothing :: RuleFunc+nothing = return Void++-- | A rule that says hello to all players+helloWorld :: RuleFunc+helloWorld = voidRule $ outputAll "hello, world!"++-- | account variable name and type+accounts :: V [(PlayerNumber, Int)]+accounts = V "Accounts"++-- | Create a bank account for each players+createBankAccount :: RuleFunc+createBankAccount = voidRule $ createValueForEachPlayer_ accounts++-- | 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+winXEcuPerDay x = voidRule $ schedule_ (recur daily) $ modifyAllValues accounts (+x)++-- | a player wins X Ecu if a rule proposed is accepted+winXEcuOnRuleAccepted :: Int -> RuleFunc+winXEcuOnRuleAccepted x = voidRule $ onEvent_ (RuleEv Activated) $ \(RuleData rule) -> modifyValueOfPlayer (_rProposedBy rule) accounts (+x)++-- | a player can transfer money to another player+-- it does not accept new players or check if balance is positive, to keep the example simple+moneyTransfer :: RuleFunc+moneyTransfer = voidRule $ do+    pls <- getAllPlayerNumbers+    when (length pls >= 2) $ forEachPlayer_ (selPlayer pls) where+       selPlayer pls src = onInputChoice_ "Transfer money to player: " (delete src $ sort pls) (selAmount src) src+       selAmount src dst = onInputStringOnce_ ("Select Amount to transfert to player: " ++ show dst) (transfer src dst) src+       transfer src dst amount = do+           modifyValueOfPlayer dst accounts (\a -> a + (read amount))+           modifyValueOfPlayer src accounts (\a -> a - (read amount))+           output ("You gave " ++ amount ++ " to " ++ show dst) src+           output (show src ++ " gaved you " ++ amount ++ " Ecus") dst+++-- | delete a rule+delRule :: RuleNumber -> RuleFunc+delRule rn = voidRule $ suppressRule rn >> autoDelete++-- | player pn is the king: we create a variable King to identify him,+-- and we prefix his name with "King"+makeKing :: PlayerNumber -> RuleFunc+makeKing pn = voidRule $ do+   voidRule $ newVar_ "King" pn+   modifyPlayerName pn ("King " ++)++king :: V PlayerNumber+king = V "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+    onInputChoiceEnumOnce_ ("Your Royal Highness, do you accept rule " ++ (show $ _rNumber rule) ++ "?") True (activateOrReject rule) k+++-- | Revolution! Hail to the king!+-- This rule suppresses the democracy (usually rules 1 and 2), installs the king and activates monarchy.+revolution :: PlayerNumber -> RuleFunc+revolution player = voidRule $ do+    suppressRule 1+    makeKing player+    addRuleParams_ "Monarchy" monarchy "monarchy" 1 "Monarchy: only the king can vote on new rules"+    activateRule_ 1+    --autoDelete++-- | set the victory for players having more than X accepted rules+victoryXRules :: Int -> RuleFunc+victoryXRules x = voidRule $ onEvent_ (RuleEv Activated) $ \_ -> do+    rs <- getActiveRules+    let counts = map (_rProposedBy . head &&& length) $ groupBy ((==) `on` _rProposedBy) rs+    let victorious = map fst $ filter ((>= x) . snd) counts+    when (length victorious /= 0) $ setVictory victorious++victoryXEcu :: Int -> RuleFunc+victoryXEcu x = voidRule $ onEvent_ (RuleEv Activated) $ \_ -> do+    as <- readVar_ accounts+    let victorious = map fst $ filter ((>= x) . snd) as+    if (length victorious /= 0) then setVictory victorious else return ()++-- | will display the time to all players in 5 seconds+displayTime :: RuleFunc+displayTime = voidRule $ do+    t <- getCurrentTime+    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:+-- a coalition of players could simply force a "victory" rule and win the game.+noGroupVictory ::  RuleFunc+noGroupVictory = voidRule $ onEvent_ Victory $ \(VictoryData ps) -> when (length ps >1) $ setVictory []++-- | Rule that state that you win. Good luck on having this accepted by other players ;)+iWin :: RuleFunc+iWin = voidRule $ getSelfProposedByPlayer >>= giveVictory+++-- | a majority vote,+voteWithMajority :: RuleFunc+voteWithMajority = onRuleProposed $ voteWith (majority `withQuorum` 2) $ assessOnEveryVotes >> assessOnTimeDelay oneDay++-- | Change unanimity vote (usually rule 1) to absolute majority (half participants plus one)+returnToDemocracy :: RuleFunc+returnToDemocracy = voidRule $ do+   suppressRule 1+   addRuleParams_ "vote with majority" voteWithMajority "voteTimeLimit" 1 "meta-rule: return true if a majority of players vote positively for a new rule"+   activateRule_ 1+   autoDelete++-- | kick a player and prevent him from returning+banPlayer :: PlayerNumber -> RuleFunc+banPlayer pn = voidRule $ do+   delPlayer pn+   onEvent_ (Player Arrive) $ \(PlayerData _) -> void $ delPlayer pn+

@@ -0,0 +1,320 @@+
+{-# LANGUAGE NoMonomorphismRestriction, FlexibleInstances, GADTs,
+    UndecidableInstances, DeriveDataTypeable, FlexibleContexts,
+    GeneralizedNewtypeDeriving, MultiParamTypeClasses, TypeFamilies,
+    TypeSynonymInstances, TemplateHaskell, ExistentialQuantification,
+    TypeFamilies, ScopedTypeVariables, StandaloneDeriving, NamedFieldPuns,
+    EmptyDataDecls, QuasiQuotes #-}
+
+-- | This module containt the type definitions necessary to build a Nomic rule. 
+module Language.Nomyx.Expression where
+
+import Data.Typeable
+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 Debug.Trace.Helpers (traceM)+import Control.Monad.Error+
+type PlayerNumber = Int
+type PlayerName = String
+type RuleNumber = Int
+type RuleName = String+type RuleDesc = String
+type RuleText = String
+type RuleCode = String
+type EventNumber = Int
+type EventName = String
+type VarName = String
+type GameName = String
+type Code = String
+
+-- * 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.
+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
+   --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 ()
+   --Rules management
+   ProposeRule  ::                               Rule              -> Nomex Bool
+   ActivateRule ::                               RuleNumber        -> Nomex Bool
+   RejectRule   ::                               RuleNumber        -> Nomex Bool
+   AddRule      ::                               Rule              -> Nomex Bool
+   DelRule      ::                               RuleNumber        -> Nomex Bool
+   ModifyRule   ::                               RuleNumber        -> Rule           -> Nomex Bool
+   GetRules     ::                               Nomex [Rule]
+   --Players management+   GetPlayers   ::                               Nomex [PlayerInfo]+   SetPlayerName::                               PlayerNumber      -> PlayerName     -> Nomex Bool+   DelPlayer    ::                               PlayerNumber      -> Nomex Bool+   --Mileacenous+   SetVictory   ::                               [PlayerNumber]    -> Nomex ()
+   Output       ::                               PlayerNumber      -> String         -> 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
+   deriving (Typeable)
++     
+instance Monad Nomex where
+   return = Return
+   (>>=) = Bind
+   
+instance Functor Nomex where
+   fmap f e = Bind e $ Return . f
+
+instance Applicative Nomex where
+   pure = Return
+   f <*> a = do
+      f' <- f
+      a' <- a
+      return $ f' a'
++instance MonadError String Nomex where+   throwError = ThrowError+   catchError = CatchError++instance Show a => Show (Nomex a) where
+   show _ = "Nomex" -- ++ (show a)
+++++
+-- * Variables
+
+-- | 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 :: Int,
+              _vName :: String,
+              vData :: a}
+
+instance Show Var where
+    show (Var a b c) = (show a) ++ " " ++ (show b) ++ " " ++ (show c)
+
+instance Eq Var where
+    Var a b c == Var d e f = (a,b,c) === (d,e,f)
+
+type Output = (PlayerNumber, String)
+
+
+-- * Events
+
+-- | events types
+data Player = Arrive | Leave deriving (Typeable, Show, Eq)
+data RuleEvent = Proposed | Activated | Rejected | Added | Modified | Deleted deriving (Typeable, Show, Eq)
+data Time           deriving Typeable
+data EvRule         deriving Typeable
+data Message m      deriving Typeable
+data InputChoice c  deriving Typeable
+data InputString    deriving Typeable
+data Victory        deriving Typeable
+
+-- | events names
+data Event a where
+    Player      :: Player ->                 Event Player
+    RuleEv      :: RuleEvent ->              Event RuleEvent
+    Time        :: UTCTime ->                Event Time
+    Message     :: String ->                 Event (Message m)
+    InputChoice :: (Eq c, Show c) => PlayerNumber -> String -> [c] -> c -> Event (InputChoice c)
+    InputString :: PlayerNumber -> String -> Event InputString
+    Victory     ::                           Event Victory
+
+-- | data associated with each events
+data EventData a where
+    PlayerData      :: {playerData :: PlayerInfo}         -> EventData Player
+    RuleData        :: {ruleData :: Rule}                 -> EventData RuleEvent
+    TimeData        :: {timeData :: UTCTime}              -> EventData Time
+    MessageData     :: (Show m) => {messageData :: m}     -> EventData (Message m)
+    InputChoiceData :: (Show c) => {inputChoiceData :: c} -> EventData (InputChoice c)
+    InputStringData :: {inputStringData :: String}        -> EventData InputString
+    VictoryData     :: {victoryData :: [PlayerInfo]}      -> EventData Victory
+
+deriving instance             Typeable1 EventData
+deriving instance             Typeable1 Event
+deriving instance (Show a) => Show      (Event a)
+deriving instance (Show a) => Show      (EventData a)+deriving instance (Show a) => Show      (Message a)
+deriving instance (Show a) => Show      (InputChoice a)+deriving instance             Show      Time
+deriving instance             Show      InputString
+deriving instance             Show      Victory
+deriving instance             Eq        Time
+deriving instance             Eq        Victory
+deriving instance             Eq        EvRule
+deriving instance             Eq        (InputChoice a)
+deriving instance             Eq        InputString
+deriving instance             Eq        (Message m)
+deriving instance (Eq e) =>   Eq        (Event e)
+
++data EventHandler where
+    EH :: (Typeable e, Show e, Eq e) =>
+        {_eventNumber :: EventNumber,
+         _ruleNumber  :: RuleNumber,
+         event       :: Event e,
+         handler     :: (EventNumber, EventData e) -> Nomex ()} -> 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
+
+-- * Rule
+
+-- | Type of a rule function.+type RuleFunc = Nomex RuleResp++-- | Return type of a rule function.+-- it can be either nothing or another rule.
+data RuleResp =
+      Void
+    | Meta (Rule -> Nomex BoolResp)
+    deriving (Typeable)+--An extended type for booleans supporting immediate or delayed response (through a message)
+data BoolResp = BoolResp Bool
+              | MsgResp (Event (Message Bool))
++
+instance Show RuleResp where
+   show _ = "RuleResp"
+  
+-- | An informationnal structure about a rule
+data Rule = Rule { _rNumber       :: RuleNumber,       -- number of the rule (must be unique) TO CHECK
+                   _rName         :: RuleName,         -- short name of the rule 
+                   _rDescription  :: String,           -- description of the rule
+                   _rProposedBy   :: PlayerNumber,     -- player proposing the rule
+                   _rRuleCode     :: Code,             -- code of the rule as a string
+                   _rRuleFunc     :: RuleFunc,         -- function representing the rule (interpreted from rRuleCode)
+                   _rStatus       :: RuleStatus,       -- status of the rule
+                   _rAssessedBy   :: Maybe RuleNumber} -- which rule accepted or rejected this rule
+                   deriving (Typeable, Show)
+
+instance Eq Rule where
+    (Rule {_rNumber=r1}) == (Rule {_rNumber=r2}) = r1 == r2
+
+instance Ord Rule where
+     (Rule {_rNumber=r1}) <= (Rule {_rNumber=r2}) = r1 <= r2
+
+-- | the status of a rule.
+data RuleStatus = Active      -- Active rules forms the current Constitution
+                | 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
+data PlayerInfo = PlayerInfo { _playerNumber :: PlayerNumber,
+                               _playerName   :: String}
+                               deriving (Eq, Typeable, Show)
+
+-- * Game
+           
+-- | The state of the game:
+data Game = Game { _gameName      :: GameName,
+                   _gameDesc      :: GameDesc,
+                   _rules         :: [Rule],
+                   _players       :: [PlayerInfo],
+                   _variables     :: [Var],
+                   _events        :: [EventHandler],
+                   _outputs       :: [Output],
+                   _victory       :: [PlayerNumber],
+                   _currentTime   :: UTCTime+                 }
+                   deriving (Typeable)
+                   
+data GameDesc = GameDesc { _desc :: String, _agora :: String} deriving (Eq, Show, Read, Ord)
+
+--instance Show Game where
+--    show (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"
+
+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;+     a1 <- reset readPrec;+     Punc "," <- lexP;+     Ident "_gameDesc" <- lexP;+     Punc "=" <- lexP;+     a2 <- reset readPrec;+     Punc "," <- lexP;+     Ident "_currentTime" <- lexP;+     Punc "=" <- lexP;+     a3 <- reset readPrec;+     Punc "}" <- lexP;+     return $ Game a1 a2 [] [] [] [] [] [] a3+  readList = readListDefault+  readListPrec = readListPrecDefault+
+instance Show Game where+   showsPrec p(Game b1 b2 _ _ _ _ _ _ b3) = showParen (p >= 11) $+      showString "Game {" .+      showString "_gameName = " .+      showsPrec 0 b1 .+      showString ", " .+      showString "_gameDesc = " .+      showsPrec 0 b2 .+      showString ", " .+      showString "_currentTime = " .+      showsPrec 0 b3 .+      showString "}"+   showList = showList__ (showsPrec 0)+
+-- | 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 ) => PlayerNumber -> String -> m ()+tracePN pn s = traceM $ "Player " ++ (show pn) ++ " " ++ s+    
+$( makeLenses [''Game, ''GameDesc, ''Rule, ''PlayerInfo, ''EventHandler, ''Var] )
+

@@ -0,0 +1,213 @@+{-# LANGUAGE StandaloneDeriving, GADTs, DeriveDataTypeable,+    FlexibleContexts, GeneralizedNewtypeDeriving,+    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', outputAll, getLoggedGame, tracePN, getTimes, activeRules, pendingRules, rejectedRules)  where++import Prelude hiding (catch)+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+import Control.Monad.Identity++data TimedEvent = TimedEvent UTCTime GameEvent deriving (Show, Read, Eq, Ord)++data GameEvent = GameSettings      GameName GameDesc UTCTime+               | JoinGame          PlayerNumber PlayerName+               | LeaveGame         PlayerNumber+               | ProposeRuleEv     PlayerNumber SubmitRule+               | InputChoiceResult PlayerNumber EventNumber Int+               | InputStringResult PlayerNumber String String+               | OutputPlayer      PlayerNumber String+               | TimeEvent         UTCTime+               | SystemAddRule     SubmitRule+                 deriving (Show, Read, Eq, Ord)++--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       = [],+    _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 (InputChoiceResult pn en ci) _     = mapStateIO $ inputChoiceResult en ci pn+enactEvent (InputStringResult pn ti res) _    = mapStateIO $ inputStringResult (InputString pn ti) res pn+enactEvent (OutputPlayer pn s) _              = mapStateIO $ outputPlayer s pn+enactEvent (TimeEvent t) _                    = mapStateIO $ runEvalError 0 $ evTriggerTime t+enactEvent (SystemAddRule r) (Just inter)     = systemAddRule r inter+enactEvent (ProposeRuleEv _ _) Nothing        = error "ProposeRuleEv: interpreter function needed"+enactEvent (SystemAddRule _) Nothing          = error "SystemAddRule: interpreter function needed"++enactTimedEvent :: Maybe (RuleCode -> IO RuleFunc) -> TimedEvent -> StateT Game IO ()+enactTimedEvent inter (TimedEvent t ge) = do+   currentTime ~= t+   enactEvent ge inter+++update :: GameEvent -> StateT LoggedGame IO ()+update ge = update' Nothing ge++update' :: Maybe (RuleCode -> IO RuleFunc) -> GameEvent -> StateT LoggedGame IO ()+update' inter ge = do+   --t <- lift $ T.getCurrentTime+   t <- access $ game >>> currentTime+   let te = TimedEvent t ge+   gameLog %= \gl -> gl ++ [te]+   evalTimedEvent te inter --`liftCatchIO` commandExceptionHandler'++evalTimedEvent :: TimedEvent -> Maybe (RuleCode -> IO RuleFunc) -> StateT LoggedGame IO ()+evalTimedEvent (TimedEvent _ e) inter = focus game $ do+   enactEvent e inter+   lg <- get+   lift $ evaluate lg+   return ()++getLoggedGame :: Game -> (RuleCode -> IO RuleFunc) -> [TimedEvent] -> IO LoggedGame+getLoggedGame g mInter tes = do+   let a = mapM_ (enactTimedEvent (Just mInter)) tes+   g' <- execStateT a g+   return $ LoggedGame g' tes+++-- | 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"+++outputPlayer :: String -> PlayerNumber -> State Game ()+outputPlayer s pn = void $ outputs %= ((pn, s) : )++outputAll :: String -> StateT LoggedGame IO ()
+outputAll s = do+   pls <- access (game >>> players)+   mapM_ (update . ((flip OutputPlayer) s)) (map _playerNumber pls)++inputChoiceResult :: EventNumber -> Int -> PlayerNumber -> State Game ()+inputChoiceResult eventNumber choiceIndex pn = do+   tracePN pn $ "input choice result: Event " ++ (show eventNumber) ++ ", choice " ++  (show choiceIndex)+   runEvalError pn $ triggerChoice eventNumber choiceIndex++-- TODO maybe homogeneise both inputs event+inputStringResult :: Event InputString -> String -> PlayerNumber -> State Game ()+inputStringResult event input pn = do+   tracePN pn $ "input String result: input " ++ input+   runEvalError pn $ triggerEvent event (InputStringData input)+++getTimes :: EventHandler -> Maybe UTCTime+getTimes (EH _ _ (Time t) _) = Just t+getTimes _ = Nothing+++-- | An 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)+++--accessors++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)++mapStateIO :: Show s => State s a -> StateT s IO a+mapStateIO = mapStateT $ return . runIdentity++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+   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)

@@ -0,0 +1,252 @@+{-# LANGUAGE DeriveDataTypeable, GADTs, ScopedTypeVariables, TupleSections, FlexibleInstances#-}
+
+-- | Basic rules examples.
+module Language.Nomyx.Rule where
++import Prelude hiding (foldr)
+import Language.Nomyx.Expression
+import Language.Nomyx.Definition
+import Data.Typeable
+import Control.Monad.State hiding (forM_)
+import Data.Maybe
+import Data.Time hiding (getCurrentTime)
+import Control.Arrow
+import Control.Applicative
+import Data.Lens
+import Data.Foldable hiding (and, mapM_)
+import Data.Boolean+
+-- | 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 BoolResp
+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
+
+
+-- | any new rule will be activate if the rule in parameter returns True
+onRuleProposed :: (Rule -> Nomex BoolResp) -> RuleFunc
+onRuleProposed r = voidRule $ onEvent_ (RuleEv Proposed) $ \(RuleData rule) -> do
+    resp <- r rule
+    case resp of
+        BoolResp b -> activateOrReject rule b
+        MsgResp m -> onMessageOnce m $ (activateOrReject rule) . messageData
+
+
+
+data ForAgainst = For | Against deriving (Typeable, Enum, Show, Eq, Bounded, Read)
+type Vote = (PlayerNumber, Maybe ForAgainst)
+type CountVotes = [Vote] -> Maybe Bool
+data VoteData = VoteData { msgEnd :: Event (Message Bool),
+                           voteVar :: ArrayVar PlayerNumber ForAgainst,
+                           inputNumbers :: [EventNumber],
+                           assessFunction :: CountVotes}
+type Assessor a = StateT VoteData Nomex a
+
+-- | Performs a vote for a rule on all players. The provided function is used to count the votes.
+-- the assessors allows to configure how and when the vote will be assessed. The assessors can be chained.
+voteWith :: CountVotes -> Assessor () -> Rule -> Nomex BoolResp 
+voteWith assessFunction assessors rule = do
+    pns <- getAllPlayerNumbers
+    let rn = show $ _rNumber rule
+    let msgEnd = Message ("Result of votes for " ++ rn) :: Event(Message Bool)
+    --create an array variable to store the votes.
+    voteVar <- newArrayVar ("Votes for rule " ++ rn) pns
+    let askPlayer pn = onInputChoiceOnce ("Vote for rule " ++ rn) [For, Against] (putArrayVar voteVar pn) pn
+    inputs <- mapM askPlayer pns
+    let voteData = VoteData msgEnd voteVar inputs assessFunction
+    evalStateT assessors voteData
+    cleanVote voteData
+    return $ MsgResp msgEnd
+
+-- | assess the vote on every new vote with the assess function, and as soon as the vote has an issue (positive of negative), sends a signal
+assessOnEveryVotes :: Assessor ()
+assessOnEveryVotes = do
+   (VoteData msgEnd voteVar _ assess) <- get
+   lift $ do
+      msgVotes <- getArrayVarMessage voteVar
+      onMessage msgVotes $ \(MessageData votes) -> maybeWhen (assess votes) $ sendMessage msgEnd
+
+
+-- | assess the vote with the assess function when time is reached, and sends a signal with the issue (positive of negative)
+--
+assessOnTimeLimit ::  UTCTime -> Assessor ()
+assessOnTimeLimit time = do
+   (VoteData msgEnd voteVar _ assess) <- get
+   lift $ do
+      onEvent_ (Time time) $ \_ -> do
+         votes <- getArrayVarData voteVar
+         let result = assess $ getOnlyVoters $ votes
+         when (result == Nothing) $ outputAll "Vote: Quorum not reached, rule is rejected"
+         sendMessage msgEnd $ fromMaybe False $ result
+
+-- | assess the vote with the assess function when time is elapsed, and sends a signal with the issue (positive of negative)
+assessOnTimeDelay ::  NominalDiffTime -> Assessor ()
+assessOnTimeDelay delay = do
+   t <- addUTCTime delay <$> lift getCurrentTime
+   assessOnTimeLimit t
+
+-- | assess the vote only when every body voted. An error is generated if the assessing function returns Nothing.
+assessWhenEverybodyVoted :: Assessor ()
+assessWhenEverybodyVoted = do
+   (VoteData msgEnd voteVar _ assess) <- get
+   lift $ do
+      msgVotes <- getArrayVarMessage voteVar
+      onMessage msgVotes $ \(MessageData votes) -> when (length (voters votes) == length votes) $
+         sendMessage msgEnd $ fromJust $ assess $ votes
+
+-- | players that did not voted are counted as negative.
+noStatusQuo :: [Vote] -> [Vote]
+noStatusQuo = map noVoteCountAsAgainst where
+   noVoteCountAsAgainst :: Vote -> Vote
+   noVoteCountAsAgainst (a, Nothing) = (a, Just Against)
+   noVoteCountAsAgainst a = a
+
+-- | clean events and variables necessary for the vote
+cleanVote :: VoteData -> Nomex ()
+cleanVote (VoteData msgEnd voteVar inputsNumber _) = onMessage msgEnd$ \_ -> do
+   delAllEvents msgEnd
+   delArrayVar voteVar
+   mapM_ delEvent inputsNumber
+
+assessOnlyVoters :: CountVotes -> CountVotes
+assessOnlyVoters assess vs = assess $ map (second Just) $ voters vs
+
+-- | a quorum is the neccessary number of voters for the validity of the vote
+quorum :: Int -> [Vote] -> Bool
+quorum q vs = (length $ voters vs) >= q
+
+-- | adds a quorum to an assessing function
+withQuorum :: CountVotes -> Int -> CountVotes
+withQuorum assess q vs = if (quorum q vs) then assess vs else Nothing
+
+-- | assess the vote results according to a unanimity (everybody votes for)
+unanimity :: [Vote] -> Maybe Bool
+unanimity votes = voteQuota (length votes) votes
+  
+-- | assess the vote results according to an absolute majority (half voters plus one, no quorum is needed)
+majority :: [Vote] -> Maybe Bool
+majority votes = voteQuota ((length votes) `div` 2 + 1) votes
+
+-- | assess the vote results according to a majority of x (in %)
+majorityWith :: Int -> [Vote] -> Maybe Bool
+majorityWith x votes = voteQuota ((length votes) * x `div` 100 + 1) votes
+
+-- | assess the vote results according to a necessary number of positive votes
+numberPositiveVotes :: Int -> [Vote] -> Maybe Bool
+numberPositiveVotes = voteQuota
+
+-- | helper function for assessement functions
+voteQuota :: Int -> [Vote] -> Maybe Bool
+voteQuota quotaFor votes
+   | nbFor votes >= quotaFor = Just True
+   | nbAgainst votes > (length votes) - quotaFor = Just False
+   | otherwise = Nothing
+   
+-- | get the number of positive votes and negative votes
+nbFor, nbAgainst :: [Vote] -> Int
+nbFor = length . filter ((== Just For) . snd)
+nbAgainst = length . filter ((== Just Against) . snd)
+      
+-- | get only those who voted
+voters :: [(PlayerNumber, Maybe ForAgainst)] -> [(PlayerNumber, ForAgainst)]
+voters vs = catMaybes $ map voter vs where
+    voter (pn, Just fa) = Just (pn, fa)
+    voter (_, Nothing) = Nothing
+
+-- | get only those who voted
+getOnlyVoters :: [(PlayerNumber, Maybe ForAgainst)] -> [(PlayerNumber, Maybe ForAgainst)]
+getOnlyVoters vs = map (second Just) $ voters vs
+
+-- | 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 -> V [(Int, Int)] -> Nomex ()
+createValueForEachPlayer initialValue var = do
+    pns <- getAllPlayerNumbers
+    v <- newVar_ (varName var) $ map (,initialValue::Int) pns
+    forEachPlayer (\_-> return ())
+                  (\p -> modifyVar v ((p, initialValue) : ))
+                  (\p -> modifyVar v $ filter $ (/= p) . fst)
+
+-- | create a value initialized for each players initialized to zero
+--manages players joining and leaving
+createValueForEachPlayer_ :: V [(Int, Int)] -> Nomex ()
+createValueForEachPlayer_ = createValueForEachPlayer 0
+
+modifyValueOfPlayer :: PlayerNumber -> V [(Int, Int)] -> (Int -> Int) -> Nomex ()
+modifyValueOfPlayer pn var f = modifyVar var $ map $ (\(a,b) -> if a == pn then (a, f b) else (a,b))
+
+modifyAllValues :: V [(Int, Int)] -> (Int -> Int) -> Nomex ()
+modifyAllValues var f = modifyVar 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
+
+oneDay :: NominalDiffTime
+oneDay = 60 * 60 * 24
+
+maybeWhen :: Maybe a -> (a -> Nomex ()) -> Nomex ()
+maybeWhen = forM_

@@ -0,0 +1,272 @@+{-# 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.Definition+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       = [],+                  _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 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", testVoteAssessOnEveryVotes1),+         ("test assess on every vote 2", testVoteAssessOnEveryVotes2),+         ("test assess on every vote 3", testVoteAssessOnEveryVotes3),+         ("test assess on every vote 4", testVoteAssessOnEveryVotes4),+         ("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) -> output "ok" 1+      _ -> output "nok" 1++testVarEx3 = _outputs (execRuleFunc testVar3) == [(1,"ok")]++--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) -> output "ok" 1+      _ -> output "nok" 1++testVarEx4 = _outputs (execRuleFunc testVar4) == [(1,"ok")]++--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 -> output "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+    onInputChoiceEnum_ "Vote for Holland or Sarkozy" Holland h 1 where+        h a = output ("voted for " ++ (show a)) 1++testSingleInputEx = (_outputs $ execRuleFuncEvent testSingleInput (inputChoiceEnum 1 "Vote for Holland or Sarkozy" Holland) (InputChoiceData Holland)) == [(1, "voted for Holland")]++testInputString :: RuleFunc+testInputString = voidRule $ do+    onInputString_ "Enter a number:" h 1 where+        h a = output ("You entered: " ++ a) 1++testInputStringEx = (_outputs $ execRuleFuncEvent testInputString (inputString 1 "Enter a number:") (InputStringData "1")) == [(1, "You entered: 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)) = output a 1++testSendMessageEx = _outputs (execRuleFunc testSendMessage) == [(1,"toto")]++testSendMessage2 :: RuleFunc+testSendMessage2 = voidRule $ do+    onEvent_ (Message "msg":: Event(Message ())) $ const $ output "Received" 1+    sendMessage_ (Message "msg")+++testSendMessageEx2 = _outputs (execRuleFunc testSendMessage2) == [(1,"Received")]++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_ (InputChoice 1 "Vote for" [Me, You] Me) h1 where+        h1 (InputChoiceData a :: EventData (InputChoice Choice2)) = do+            writeVar (V "vote") (Just a)+            SendMessage (Message "voted") ()+        h2 (MessageData _) = do+            a <- readVar (V "vote")+            case a of+                Just (Just Me) -> output "voted Me" 1+                _ -> output "problem" 1+        h2 _ = undefined++testUserInputWriteEx = (_outputs $ execRuleFuncEvent testUserInputWrite (InputChoice 1 "Vote for" [Me, You] Me) (InputChoiceData Me)) == [(1,"voted 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 = (_outputs $ execRuleFuncEvent testTimeEvent (Time date1) (TimeData date1)) == [(1,show date1)]++testTimeEvent2 :: Nomex ()+testTimeEvent2 = schedule' [date1, date2] (outputAll . show)++testTimeEventEx2 = (_outputs $ flip execState testGame (runEvalError 0 $ evalExp testTimeEvent2 0 >> gameEvs)) == [(1,show date2), (1,show date1)] where+    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+    mapM_ (\x -> evInputChoice (InputChoice x "Vote for rule 0" [For, Against] For) For) [1..positives]+    mapM_ (\x -> evInputChoice (InputChoice (x+positives) "Vote for rule 0" [For, Against] For) Against) [1..negatives]+    when timeEvent $ 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 = "unanimityRule", _rRuleFunc = rf, _rNumber = 1, _rStatus = Active}+   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+testVoteAssessOnVoteComplete1 = testVoteRule Active  $ voteGame      10 0 10 $ onRuleProposed $ voteWith majority $ assessWhenEverybodyVoted+testVoteAssessOnVoteComplete2 = testVoteRule Pending $ voteGame      9  0 10 $ onRuleProposed $ voteWith majority $ assessWhenEverybodyVoted+testVoteAssessOnEveryVotes1   = testVoteRule Active  $ voteGame      10 0 10 $ onRuleProposed $ voteWith unanimity $ assessOnEveryVotes+testVoteAssessOnEveryVotes2   = testVoteRule Active  $ voteGame      6  0 10 $ onRuleProposed $ voteWith majority $ assessOnEveryVotes+testVoteAssessOnEveryVotes3   = testVoteRule Pending $ voteGame      5  0 10 $ onRuleProposed $ voteWith majority $ assessOnEveryVotes+testVoteAssessOnEveryVotes4   = testVoteRule Reject  $ voteGame      0  5 10 $ onRuleProposed $ voteWith majority $ assessOnEveryVotes+testVoteMajorityWith          = testVoteRule Active  $ voteGame      6  0 10 $ onRuleProposed $ voteWith (majorityWith 50) $ assessOnEveryVotes+testVoteNumberPositiveVotes   = testVoteRule Active  $ voteGame      3  7 10 $ onRuleProposed $ voteWith (numberPositiveVotes 3) $ assessOnEveryVotes+testVoteWithQuorum1           = testVoteRule Active  $ voteGame      7  3 10 $ onRuleProposed $ voteWith (majority `withQuorum` 7) $ assessOnEveryVotes+testVoteWithQuorum2           = testVoteRule Pending $ voteGame      6  0 10 $ onRuleProposed $ voteWith (majority `withQuorum` 7) $ assessOnEveryVotes+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+