packages feed

Nomyx-Language 0.2.0 → 0.2.1

raw patch · 11 files changed

+487/−306 lines, 11 files

Files

Nomyx-Language.cabal view
@@ -1,5 +1,5 @@ name: Nomyx-Language-version: 0.2.0+version: 0.2.1 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)@@ -15,7 +15,8 @@ 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+            src/Language/Nomyx/Rule.hs src/Language/Nomyx/Test.hs +            src/Language/Nomyx/Vote.hs data-dir: "" extra-source-files: AUTHORS README  @@ -31,9 +32,11 @@                      Language.Nomyx.Definition                      Language.Nomyx.Evaluation                       Language.Nomyx.Examples-                     Language.Nomyx.Rule +                     Language.Nomyx.Rule+                     Language.Nomyx.Vote                       Language.Nomyx.Test                      Language.Nomyx.Game+                     Language.Nomyx.Utils                      Paths_Nomyx_Language     exposed: True     buildable: True
src/Language/Nomyx.hs view
@@ -4,12 +4,14 @@    module Language.Nomyx.Definition,    module Language.Nomyx.Rule,    module Language.Nomyx.Examples,-   module Language.Nomyx.Evaluation)  where+   module Language.Nomyx.Evaluation,+   module Language.Nomyx.Vote)  where  import Language.Nomyx.Expression import Language.Nomyx.Definition import Language.Nomyx.Rule import Language.Nomyx.Examples import Language.Nomyx.Evaluation+import Language.Nomyx.Vote
src/Language/Nomyx/Definition.hs view
@@ -11,13 +11,13 @@ 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+import Language.Nomyx.Utils 
 -- * Variables
 -- | variable creation
@@ -66,9 +66,9 @@ 
 -- * 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)))
+-- | 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 (Msg [(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)
@@ -111,7 +111,7 @@     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 :: (Ord i, Typeable a, Show a, Eq a, Typeable i, Show i) => (ArrayVar i a) -> Nomex (Msg [(i, Maybe a)])
 getArrayVarMessage (ArrayVar m _) = return m
 
 -- | get the association array
@@ -161,17 +161,17 @@ 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 :: (Typeable a, Show a, Eq a) => Msg a -> a -> Nomex ()
 sendMessage = SendMessage
 
-sendMessage_ :: Event (Message ()) -> Nomex ()
+sendMessage_ :: Msg () -> Nomex ()
 sendMessage_ m = SendMessage m ()
 
 -- | subscribe on a message 
-onMessage :: (Typeable m, Show m) => Event (Message m) -> ((EventData (Message m)) -> Nomex ()) -> Nomex ()
+onMessage :: (Typeable m, Show m) => Msg m -> (MsgData m -> Nomex ()) -> Nomex ()
 onMessage m f = onEvent_ m f
 
-onMessageOnce :: (Typeable m, Show m) => Event (Message m) -> ((EventData (Message m)) -> Nomex ()) -> Nomex ()
+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
@@ -409,18 +409,8 @@   
 -- * 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 @@ -441,14 +431,14 @@            (BoolResp b') -> andMsgBool b' a' >>= (return . MsgResp)            (MsgResp  b') -> andMsgMsg  a' b' >>= (return . MsgResp) -andMsgBool :: Bool -> (Event (Message Bool)) -> Nomex (Event (Message Bool))+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 :: (Event (Message Bool)) -> (Event (Message Bool)) -> Nomex (Event (Message Bool))+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)
src/Language/Nomyx/Evaluation.hs view
@@ -3,21 +3,22 @@ module Language.Nomyx.Evaluation where  import Prelude hiding ((.))-import Language.Nomyx.Expression+import Language.Nomyx.Utils 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)+import Control.Applicative ((<$>))+import Language.Nomyx.Expression + type Evaluate a = ErrorT String (State Game) a  -- | evaluate an expression.@@ -61,24 +62,19 @@ evalExp (OnEvent event handler) rn = do    evs <- access events    let en = getFreeNumber (map _eventNumber evs)-   events %= ((EH en rn event handler) : )+   events %= ((EH en rn event handler EvActive) : )    return en -evalExp (DelEvent en) rn = do+evalExp (DelEvent en) rn = evDelEvent en rn++evalExp (DelAllEvents e) 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+   let filtered = filter (\EH {event} -> event === e) evs+   --traceM ("DelAllEvents: deleting " ++ show filtered)+   mapM_ (\e -> evDelEvent e rn) (_eventNumber <$> filtered) -evalExp (SendMessage (Message id) myData) _ = do-   triggerEvent (Message id) (MessageData myData)-   return ()+evalExp (SendMessage (Message id) myData) _ = triggerEvent_ (Message id) (MessageData myData) -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@@ -99,48 +95,59 @@    victory ~= ps    pls <- access players    let victorious = filter (\pl -> _playerNumber pl `elem` ps) pls-   triggerEvent Victory (VictoryData victorious)-   return ()+   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 ()+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}) -> 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))+   let filtered = filter (\(EH {event, _evStatus}) -> e === event && _evStatus == EvActive) evs+   case filtered of+      [] -> do+         --traceM $ "triggerEvent: Event not found:" ++ (show e)+         return False+      xs -> do+         mapM_ f xs+         return True 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)) +triggerEvent_ :: (Typeable e, Show e, Eq e) => Event e -> EventData e -> Evaluate ()+triggerEvent_ e ed = void $ triggerEvent e ed+ errorHandler :: String -> Nomex () errorHandler s = outputAll $ "Error: " ++ s -triggerChoice :: Int -> Int -> Evaluate ()-triggerChoice myEventNumber choiceIndex = do+triggerChoice :: EventNumber -> Int -> Evaluate ()+triggerChoice en choiceIndex = do    evs <- access events-   let filtered = filter ((== myEventNumber) . getL eventNumber) evs-   mapM_ (execChoiceHandler myEventNumber choiceIndex) filtered+   let filtered = filter ((== en) . getL eventNumber) evs+   mapM_ (execChoiceHandler en choiceIndex) filtered  execChoiceHandler :: EventNumber -> Int -> EventHandler -> Evaluate ()-execChoiceHandler eventNumber choiceIndex (EH _ _ (InputChoice ruleNumber _ cs _) handler) = evalExp (handler (eventNumber, InputChoiceData (cs!!choiceIndex))) ruleNumber+execChoiceHandler eventNumber choiceIndex (EH _ rn (InputChoice _ _ cs _) handler _) = evalExp (handler (eventNumber, InputChoiceData (cs!!choiceIndex))) rn 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+getChoiceEvents :: Evaluate [EventNumber]+getChoiceEvents = do+   evs <- access events+   return $ map _eventNumber $ filter choiceEvent evs+   where choiceEvent (EH _ _ (InputChoice _ _ _ _) _ _) = True+         choiceEvent _ = False  outputS :: PlayerNumber -> String -> Evaluate () outputS pn s = void $ outputs %= ((pn, s) : )@@ -155,7 +162,7 @@    case find ((== (rNumber ^$ rule)) . getL rNumber) rs of       Nothing -> do          rules %= (rule:)-         triggerEvent (RuleEv Proposed) (RuleData rule)+         triggerEvent_ (RuleEv Proposed) (RuleData rule)          return True       Just _ -> return False @@ -170,7 +177,7 @@          rules ~= newrules          --execute the rule          evalExp (_rRuleFunc r) rn-         triggerEvent (RuleEv Activated) (RuleData r)+         triggerEvent_ (RuleEv Activated) (RuleData r)          return True  evRejectRule :: RuleNumber -> RuleNumber -> Evaluate Bool@@ -181,7 +188,7 @@       Just r -> do          let newrules = replaceWith ((== rn) . getL rNumber) r{_rStatus = Reject, _rAssessedBy = Just by} rs          rules ~= newrules-         triggerEvent (RuleEv Rejected) (RuleData r)+         triggerEvent_ (RuleEv Rejected) (RuleData r)          delVarsRule rn          delEventsRule rn          return True@@ -192,7 +199,7 @@    case find ((== (rNumber ^$ rule)) . getL rNumber) rs of       Nothing -> do          rules %= (rule:)-         triggerEvent (RuleEv Added) (RuleData rule)+         triggerEvent_ (RuleEv Added) (RuleData rule)          return True       Just _ -> return False @@ -206,7 +213,7 @@          rules ~= newRules          delVarsRule del          delEventsRule del-         triggerEvent (RuleEv Deleted) (RuleData r)+         triggerEvent_ (RuleEv Deleted) (RuleData r)          return True  --TODO: clean and execute new rule@@ -218,7 +225,7 @@       Nothing -> return False       Just r ->  do          rules ~= newRules-         triggerEvent (RuleEv Modified) (RuleData r)+         triggerEvent_ (RuleEv Modified) (RuleData r)          return True  addPlayer :: PlayerInfo -> Evaluate Bool@@ -227,7 +234,7 @@    let exists = any (((==) `on` _playerNumber) pi) pls    when (not exists) $ do        players %= (pi:)-       triggerEvent (Player Arrive) (PlayerData pi)+       triggerEvent_ (Player Arrive) (PlayerData pi)    return $ not exists  evDelPlayer :: PlayerNumber -> Evaluate Bool@@ -239,7 +246,7 @@          return False       Just pi -> do          players %= filter ((/= pn) . getL playerNumber)-         triggerEvent (Player Leave) (PlayerData pi)+         triggerEvent_ (Player Leave) (PlayerData pi)          tracePN pn $ "leaving the game: " ++ (_gameName g)          return True @@ -252,10 +259,29 @@          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 ()+evDelEvent :: EventNumber -> RuleNumber -> 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+            EvActive -> do+               --traceM ("DelEvent: deleting event en=" ++ (show en) ++ " rn=" ++ (show rn))+               let newEvents = replaceWith ((== en) . getL eventNumber) eh{_evStatus = EvDeleted} evs+               events ~= newEvents+               return True+            EvDeleted -> do+               --traceM ("DelEvent: Event already deleted! en=" ++ (show en) ++ "rn event=" ++ (show $ _ruleNumber eh) ++ " rn=" ++ (show rn))+               return False++evInputChoice :: (Eq d, Show d, Typeable d, Read d) => Event(InputChoice d) -> d -> Evaluate Bool evInputChoice ic d = triggerEvent ic (InputChoiceData d) -evTriggerTime :: UTCTime -> Evaluate ()+evTriggerTime :: UTCTime -> Evaluate Bool evTriggerTime t = triggerEvent (Time t) (TimeData t)  @@ -266,9 +292,6 @@ --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 ()
src/Language/Nomyx/Examples.hs view
@@ -1,11 +1,14 @@-{-# LANGUAGE TupleSections, GADTs #-}+{-# LANGUAGE TupleSections, GADTs, EmptyDataDecls, TypeFamilies, DeriveDataTypeable,+    ScopedTypeVariables, TypeSynonymInstances #-}  -- | 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+module Language.Nomyx.Examples(nothing, helloWorld, accounts, createBankAccount, winXEcuPerDay,+    winXEcuOnRuleAccepted, moneyTransfer, delRule, voteWithMajority, king, makeKing, monarchy,+    revolution, victoryXRules, victoryXEcu, displayTime, noGroupVictory, iWin, returnToDemocracy,+    banPlayer, referendum, referendumOnKickPlayer, gameMasterElections,+    module Data.Time.Recurrence, module Control.Monad, module Data.List, module Data.Time.Clock) where  import Language.Nomyx.Definition import Language.Nomyx.Rule@@ -16,6 +19,10 @@ import Control.Arrow import Data.List import Control.Monad+import Language.Nomyx.Vote+       (elections, referendum, assessOnTimeDelay, assessOnEveryVotes,+        withQuorum, majority, voteWith_)+import Language.Nomyx.Utils (oneDay)  -- | A rule that does nothing nothing :: RuleFunc@@ -121,13 +128,13 @@  -- | a majority vote, voteWithMajority :: RuleFunc-voteWithMajority = onRuleProposed $ voteWith (majority `withQuorum` 2) $ assessOnEveryVotes >> assessOnTimeDelay oneDay+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"+   addRuleParams_ "vote with majority" voteWithMajority "voteWithMajority" 1 "meta-rule: return true if a majority of players vote positively for a new rule"    activateRule_ 1    autoDelete @@ -137,3 +144,22 @@    delPlayer pn    onEvent_ (Player Arrive) $ \(PlayerData _) -> void $ delPlayer pn +-- * Referendum & elections++-- | triggers a referendum, if the outcome is yes player 2 will be kicked+referendumOnKickPlayer :: RuleFunc+referendumOnKickPlayer = referendum " kick player 2" (void $ delPlayer 2)++-- | triggers elections (all players are candidates), the winner becomes game master+gameMasterElections :: RuleFunc+gameMasterElections = voidRule $ do+   pls <- getPlayers+   elections "Game Master" pls makeGM++makeGM :: PlayerNumber -> Nomex()+makeGM pn = do+   newVar "GameMaster" pn+   void $ modifyPlayerName pn ("GameMaster " ++)++gameMaster :: V PlayerNumber+gameMaster = V "GameMaster"
src/Language/Nomyx/Expression.hs view
@@ -19,8 +19,9 @@ import Text.Read.Lex (Lexeme(..)) import Text.ParserCombinators.ReadPrec (reset) import GHC.Show (showList__)-import Debug.Trace.Helpers (traceM) import Control.Monad.Error+import Language.Nomyx.Utils ((===))+import Data.List (intersperse) 
 type PlayerNumber = Int
 type PlayerName = String
@@ -97,9 +98,6 @@ instance Show a => Show (Nomex a) where
    show _ = "Nomex" -- ++ (show a)
 --- 
 -- * Variables
 
@@ -120,7 +118,7 @@ 
 type Output = (PlayerNumber, String)
 
-
+type Id a = a
 -- * Events
 
 -- | events types
@@ -170,22 +168,27 @@ deriving instance             Eq        (Message m)
 deriving instance (Eq e) =>   Eq        (Event e)
 
+data EventStatus = EvActive | EvDeleted 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 ()} -> EventHandler
+         event        :: Event e,
+         handler      :: (EventNumber, EventData e) -> Nomex (),+         _evStatus    :: EventStatus} -> EventHandler
 
 instance Show EventHandler where
-    show (EH en rn e _) = (show en) ++ " " ++ " " ++ (show rn) ++ " (" ++ (show e) ++"),\n"
+    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) 
 -- * Rule
 
@@ -200,7 +203,7 @@     deriving (Typeable) --An extended type for booleans supporting immediate or delayed response (through a message)
 data BoolResp = BoolResp Bool
-              | MsgResp (Event (Message Bool))
+              | MsgResp (Msg Bool)
  
 instance Show RuleResp where
@@ -256,11 +259,6 @@                    
 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
 
@@ -301,20 +299,11 @@       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-    
+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"
+
 $( makeLenses [''Game, ''GameDesc, ''Rule, ''PlayerInfo, ''EventHandler, ''Var] )
src/Language/Nomyx/Game.hs view
@@ -18,8 +18,9 @@ import Control.Category ((>>>)) import Data.Lens.Template import Control.Exception-import Control.Monad.Identity+import Language.Nomyx.Utils + data TimedEvent = TimedEvent UTCTime GameEvent deriving (Show, Read, Eq, Ord)  data GameEvent = GameSettings      GameName GameDesc UTCTime@@ -67,7 +68,7 @@ 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 (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"@@ -83,17 +84,17 @@  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 te inter  evalTimedEvent :: TimedEvent -> Maybe (RuleCode -> IO RuleFunc) -> StateT LoggedGame IO () evalTimedEvent (TimedEvent _ e) inter = focus game $ do    enactEvent e inter    lg <- get    lift $ evaluate lg+   --liftIO $! putStrLn $ "evaluating " ++ (show e)    return ()  getLoggedGame :: Game -> (RuleCode -> IO RuleFunc) -> [TimedEvent] -> IO LoggedGame@@ -122,7 +123,7 @@          tracePN pn $ "Joining game: " ++ (_gameName g)          let player = PlayerInfo { _playerNumber = pn, _playerName = name}          players %= (player : )-         runEvalError pn $ triggerEvent (Player Arrive) (PlayerData player)+         runEvalError pn $ triggerEvent_ (Player Arrive) (PlayerData player)   -- | leave the game.@@ -157,11 +158,11 @@ 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)+   runEvalError pn $ triggerEvent_ event (InputStringData input)   getTimes :: EventHandler -> Maybe UTCTime-getTimes (EH _ _ (Time t) _) = Just t+getTimes (EH _ _ (Time t) _ EvActive) = Just t getTimes _ = Nothing  @@ -174,8 +175,6 @@ execWithGame' t gs g = execStateT gs ((game >>> currentTime) `setL` t $ g)  ---accessors- activeRules :: Game -> [Rule] activeRules = sort . filter ((==Active) . getL rStatus) . _rules @@ -188,14 +187,13 @@ 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+   tracePN pn $ "Creating rule n=" ++ (show rn) ++ " code=" ++ code    return $ Rule {_rNumber = rn,                   _rName = name,                   _rDescription = desc,
src/Language/Nomyx/Rule.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE DeriveDataTypeable, GADTs, ScopedTypeVariables, TupleSections, FlexibleInstances#-}
+{-# LANGUAGE DeriveDataTypeable, GADTs, ScopedTypeVariables, TupleSections,+    FlexibleInstances, TypeFamilies, FlexibleContexts, Rank2Types #-}
 
 -- | Basic rules examples.
 module Language.Nomyx.Rule where
@@ -6,15 +7,10 @@ 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+import Language.Nomyx.Vote+ 
 -- | This rule will activate automatically any new rule.
 autoActivate :: RuleFunc
@@ -40,12 +36,12 @@ 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
+--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))
@@ -57,138 +53,10 @@ 
 
 -- | 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
+onRuleProposed :: (Rule -> Nomex (Msg [ForAgainst]) ) -> RuleFunc
+onRuleProposed f = voidRule $ onEvent_ (RuleEv Proposed) $ \(RuleData rule) -> do
+    resp <- f rule+    onMessageOnce resp $ (activateOrReject rule) . (== [For]) . messageData
 
 -- | activate or reject a rule
 activateOrReject :: Rule -> Bool -> Nomex ()
@@ -244,9 +112,3 @@     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_
src/Language/Nomyx/Test.hs view
@@ -5,11 +5,12 @@ import Language.Nomyx.Rule import Language.Nomyx.Expression import Language.Nomyx.Evaluation-import Language.Nomyx.Definition+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"@@ -35,9 +36,9 @@                    _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+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+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),@@ -52,7 +53,7 @@          ("test user input write", testUserInputWriteEx),          ("test activate rule", testActivateRuleEx),          ("test auto activate", testAutoActivateEx),-         ("test meta rules vote", testApplicationMetaRuleEx),+         --("test meta rules vote", testApplicationMetaRuleEx),          ("test time event", testTimeEventEx),          ("test time event 2", testTimeEventEx2),          ("test assess on vote complete 1", testVoteAssessOnVoteComplete1),@@ -208,7 +209,7 @@ 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+testTimeEventEx2 = (_outputs $ flip execState testGame (runEvalError 0 $ evalExp testTimeEvent2 0 >> void gameEvs)) == [(1,show date2), (1,show date1)] where     gameEvs = do         evTriggerTime date1         evTriggerTime date2@@ -221,13 +222,16 @@     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+    evs <- getChoiceEvents+    let pos = take positives evs+    let neg = take negatives $ drop positives evs+    mapM_ (\x -> triggerChoice x (fromEnum For)) pos+    mapM_ (\x -> triggerChoice x (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 = "unanimityRule", _rRuleFunc = rf, _rNumber = 1, _rStatus = Active}+   let rule = testRule {_rName = "testRule", _rRuleFunc = rf, _rNumber = 1, _rStatus = Active}    evAddRule rule    evActivateRule (_rNumber rule) 0    return ()@@ -239,34 +243,34 @@ 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 ()+--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+--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+-- 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+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
+ src/Language/Nomyx/Utils.hs view
@@ -0,0 +1,54 @@+
+
+
+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)+import Data.List (intersperse)++-- | 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
+ src/Language/Nomyx/Vote.hs view
@@ -0,0 +1,230 @@+{-# LANGUAGE ScopedTypeVariables, FlexibleInstances, TypeFamilies, FlexibleContexts,+    DeriveDataTypeable, GADTs #-}+    
+-- | Voting system
+module Language.Nomyx.Vote 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.List (sort, group)+import Language.Nomyx.Utils (oneDay)+import qualified Data.Map as M+import Control.Monad.Error (MonadError(..))++data VoteType a = ExclusiveVote (Maybe (Alts a))+                | NonExclusiveVote [Alts a]++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+   name :: a -> String+   exclusiveWinner :: a ->  Maybe (Alts a, Alts a)+   exclusiveWinner _ = Nothing++type ForAgainst = Alts Rule
+instance Votable Rule where+   data Alts Rule = For | Against deriving (Typeable, Enum, Show, Eq, Bounded, Read, Ord)+   alts = [For, Against]+   quota For q _ = q+   quota Against q vs = vs - q + 1+   name r = "rule " ++ (show $ _rNumber r)+   exclusiveWinner _ = Just (For, Against)++
+type Vote a = (PlayerNumber, Maybe (Alts a))+type VoteResult a = VoteStats a -> [Alts a]
+data VoteStats a = VoteStats { voteCounts :: M.Map (Maybe (Alts a)) Int,+                               voteFinished :: Bool}++data VoteData a = VoteData { msgEnd :: Msg [Alts a],                   -- message sent when the vote is finished with the winners
+                             voteVar :: ArrayVar PlayerNumber (Alts a),-- variable containing the votes
+                             inputNumbers :: [EventNumber],            -- numbers of the toggle inputs of the players (to delete them at the end of vote)
+                             assessFunction :: VoteResult a}           -- function used to count the votes
+type Assessor a = StateT (VoteData a) Nomex ()
+++
+-- | Performs a vote.+voteWith :: (Votable a) => VoteResult a         -- ^ the function used to count the votes.+                        -> Assessor a           -- ^ assessors: when and how to perform the vote assessment (several assessors can be chained).+                        -> a                    -- ^ toVote: the matter to be voted.+                        -> [Alts a]             -- ^ the vote alternatives.+                        -> Nomex (Msg [Alts a]) -- ^ return value: a message containing the result of the vote. 
+voteWith countVotes assessors toVote als = do
+    pns <- getAllPlayerNumbers
+    let toVoteName = name toVote
+    let msgEnd = Message ("Result of votes for " ++ toVoteName) :: Msg [Alts a]
+    --create an array variable to store the votes.
+    (voteVar :: ArrayVar PlayerNumber (Alts a)) <- newArrayVar ("Votes for " ++ toVoteName) pns
+    let askPlayer pn = onInputChoiceOnce ("Vote for " ++ toVoteName ++ ":") als (putArrayVar voteVar pn) pn
+    inputs <- mapM askPlayer pns
+    let voteData = VoteData msgEnd voteVar inputs countVotes
+    evalStateT assessors voteData
+    cleanVote voteData
+    return $ msgEnd++-- | Performs a vote, all the possible alternatives are selected.+voteWith_ :: (Votable a) => VoteResult a -> Assessor a -> a -> Nomex (Msg [Alts a]) 
+voteWith_ assessFunction assessors toVote = voteWith assessFunction assessors toVote alts
++
+-- | 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 :: (Votable a) => Assessor a
+assessOnEveryVotes = do
+   (VoteData msgEnd voteVar _ assess) <- get
+   lift $ do
+      msgVotes <- getArrayVarMessage voteVar
+      onMessage msgVotes $ \(MessageData votes) -> do+         let res = assess $ getVoteStats votes False+         when (not $ null res) $ sendMessage msgEnd res
+
+
+-- | assess the vote with the assess function when time is reached, and sends a signal with the issue (positive of negative)
+assessOnTimeLimit :: (Votable a) => UTCTime -> Assessor a
+assessOnTimeLimit time = do
+   (VoteData msgEnd voteVar _ assess) <- get
+   lift $ do
+      onEvent_ (Time time) $ \_ -> do
+         votes <- getArrayVarData voteVar
+         sendMessage msgEnd (assess $ getVoteStats votes True)
++   
+-- | assess the vote with the assess function when time is elapsed, and sends a signal with the issue (positive of negative)
+assessOnTimeDelay :: (Votable a) => NominalDiffTime -> Assessor a
+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 :: (Votable a) => Assessor a
+assessWhenEverybodyVoted = do
+   (VoteData msgEnd voteVar _ assess) <- get
+   lift $ do
+      msgVotes <- getArrayVarMessage voteVar
+      onMessage msgVotes $ \(MessageData vs) -> do+         when (all isJust (map snd vs)) $ sendMessage msgEnd $ assess $ getVoteStats vs True
+
+
+-- | clean events and variables necessary for the vote
+cleanVote :: (Votable a) => VoteData a -> Nomex ()
+cleanVote (VoteData msgEnd voteVar inputsNumber _) = onMessage msgEnd$ \_ -> do
+   delAllEvents msgEnd
+   delArrayVar voteVar
+   mapM_ delEvent inputsNumber
+
+
+-- | a quorum is the neccessary number of voters for the validity of the vote
+quorum :: (Votable a) => Int -> VoteStats a -> Bool
+quorum q vs = (voted vs) >= q
+
+-- | adds a quorum to an assessing function
+withQuorum :: (Votable a) => VoteResult a -> Int -> VoteResult a
+withQuorum assess q vs = if (quorum q vs) then assess vs else []
++-- | assess the vote results according to a unanimity (everybody votes for)
+unanimity :: (Votable a) => VoteStats a -> [Alts a]
+unanimity vs = voteQuota (nbVoters vs) vs
+  
+-- | assess the vote results according to an absolute majority (half voters plus one, no quorum is needed)
+majority :: (Votable a) => VoteStats a -> [Alts a]
+majority vs = voteQuota ((nbVoters vs) `div` 2 + 1) vs
+
+-- | assess the vote results according to a majority of x (in %)
+majorityWith :: (Votable a) => Int -> VoteStats a -> [Alts a]
+majorityWith x vs = voteQuota ((nbVoters vs) * x `div` 100 + 1) vs
+
+-- | assess the vote results according to a necessary number of positive votes
+numberPositiveVotes :: (Votable a) => Int -> VoteStats a -> [Alts a]
+numberPositiveVotes i vs = voteQuota i vs
+
+-- | return the vote alternatives that are above threshold
+voteQuota :: forall a. (Votable a) => Int -> VoteStats a -> [Alts a]
+voteQuota q votes = case (exclusiveWinner (undefined :: a)) of+   Nothing -> catMaybes $ M.keys $ M.filter (>= q) (voteCounts votes)+   Just a -> maybeToList $ exclusiveVoteQuota q votes a++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+   | M.findWithDefault 0 (Just against) vs > (nbVoters votes) - q = Just against+   | otherwise = Nothing+   where vs = voteCounts votes+++-- | number of people that voted if the voting is finished,+-- total number of people that should vote otherwise+nbVoters :: (Votable a) => VoteStats a -> Int+nbVoters vs+   | voteFinished vs = (totalVoters vs) - (notVoted vs)+   | otherwise = totalVoters vs++totalVoters, voted, notVoted :: (Votable a) => VoteStats a -> Int+totalVoters vs = M.foldr (+) 0 (voteCounts vs)+notVoted    vs = fromMaybe 0 $ M.lookup Nothing (voteCounts vs)+voted       vs = (totalVoters vs) - (notVoted vs)+++getVoteStats :: (Votable a) => [Vote a] -> Bool -> VoteStats a+getVoteStats vs voteFinished = VoteStats+   {voteCounts = M.fromList $ counts (snd <$> vs),+    voteFinished = voteFinished}++counts :: (Eq a, Ord a) => [a] -> [(a, Int)]+counts as = map (head &&& length) (group $ sort as)+   
++-- * Referendum & elections++data Referendum = Referendum String deriving (Typeable)+instance Votable Referendum where+   data Alts Referendum = Yes | No deriving (Enum, Show, Eq, Bounded, Read, Ord)+   alts = [Yes, No]+   quota Yes q _ = q+   quota No q vs = vs - q + 1+   name (Referendum n) = "referendum on " ++ n++referendum :: String -> Nomex () -> RuleFunc+referendum name action = voidRule $ do+   msg <- voteWith_ (majority `withQuorum` 2) (assessOnEveryVotes >> assessOnTimeDelay oneDay) (Referendum name)+   onMessageOnce msg resolution where+      resolution (MessageData [Yes]) = do+            outputAll "Positive result of referendum"+            action+      resolution (MessageData [No]) = outputAll "Negative result of referendum"+      resolution (MessageData [])   = outputAll "No result for referendum"+      resolution (MessageData _)    = throwError "Impossible result for referendum"+++data Election = Election String deriving (Typeable)+instance Votable Election where+   data Alts Election = Candidate {candidate :: PlayerInfo}+   alts = map (\n -> Candidate (PlayerInfo n "")) [1..]+   quota _ q _ = q+   name (Election n) = "elections on " ++ n++instance Show (Alts Election) where+   show (Candidate (PlayerInfo _ name)) = name++instance Eq (Alts Election) where+   (Candidate (PlayerInfo pn1 _)) == (Candidate (PlayerInfo pn2 _)) = pn1 == pn2++instance Ord (Alts Election) where+   compare (Candidate (PlayerInfo pn1 _)) (Candidate (PlayerInfo pn2 _)) = compare pn1 pn2++elections :: String -> [PlayerInfo] -> (PlayerNumber -> Nomex()) -> Nomex ()+elections name pns action = do+   msg <- voteWith majority (assessWhenEverybodyVoted {-assessOnEveryVotes >> 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!"+         action $ _playerNumber pi+      resolution (MessageData []) = outputAll $ "Result of elections: nobody won!"+      resolution (MessageData _)  = throwError "Impossible result for elections"