diff --git a/Nomyx-Rules.cabal b/Nomyx-Rules.cabal --- a/Nomyx-Rules.cabal +++ b/Nomyx-Rules.cabal @@ -1,6 +1,8 @@ name: Nomyx-Rules -version: 0.0.3 +version: 0.1.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_Rules) build-type: Simple license: BSD3 license-file: LICENSE @@ -11,19 +13,20 @@ 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: examples/Examples.hs src/Language/Nomyx/Evaluation.hs +data-files: src/Language/Nomyx/Examples.hs src/Language/Nomyx/Evaluation.hs src/Language/Nomyx/Expression.hs src/Language/Nomyx/Rule.hs - tests/Test.hs + src/Language/Nomyx/Test.hs data-dir: "" -extra-source-files: examples/Examples.hs tests/Test.hs, AUTHORS, README +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, time -any, time-recurrence -any - exposed-modules: Examples Language.Nomyx.Evaluation - Language.Nomyx.Expression Language.Nomyx.Rule Test Paths_Nomyx_Rules + exposed-modules: Language.Nomyx.Examples Language.Nomyx.Evaluation + Language.Nomyx.Expression Language.Nomyx.Rule Language.Nomyx.Test + Paths_Nomyx_Rules exposed: True buildable: True - hs-source-dirs: examples src tests - + hs-source-dirs: src + other-modules: diff --git a/examples/Examples.hs b/examples/Examples.hs deleted file mode 100644 --- a/examples/Examples.hs +++ /dev/null @@ -1,114 +0,0 @@ -{-# 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 Examples where - -import Language.Nomyx.Rule -import Language.Nomyx.Expression -import Data.Function -import System.Locale (defaultTimeLocale, rfc822DateFormat) -import qualified Data.Time.Clock as T -import Data.Time.Recurrence hiding (filter) -import Control.Arrow -import Data.List -import Debug.Trace -import Control.Monad - --- | A rule that does nothing -nothing :: RuleFunc -nothing = VoidRule $ return () - --- | A rule that says hello to all players -helloWorld :: RuleFunc -helloWorld = VoidRule $ outputAll "hello" - --- | account variable name -accounts :: String -accounts = "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", "monthly" as recurrences and everything in time-recurrence -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 -moneyTransfer :: RuleFunc -moneyTransfer = VoidRule $ do - pls <- getAllPlayerNumbers - when (length pls >= 2) $ mapM_ (selPlayer pls) 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 (+ (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 >> return () - --- | Change unanimity vote (usually rule 2) to absolute majority (half participants plus one) -voteWithMajority :: RuleFunc -voteWithMajority = VoidRule $ do - suppressRule 2 - addRuleParams_ "vote with majority" (vote majority) "vote majority" 2 "meta-rule: return true if a majority of players vote positively for a new rule" - activateRule_ 2 - autoDelete - - --- | player pn is the king -makeKing :: PlayerNumber -> RuleFunc -makeKing pn = VoidRule $ newVar_ "King" pn >> return () - -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 - suppressRule 2 - voidRule $ 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 - --- | will display the time to all players in 5 seconds -displayTime :: RuleFunc -displayTime = VoidRule $ do - t <- getCurrentTime - onEventOnce_ (Time (T.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 number of players voting: --- a coalition of players could simply force a "victory" rule and win the game. -onePlayerVictory :: RuleFunc -onePlayerVictory = VoidRule $ onEvent_ Victory $ \(VictoryData ps) -> when (length ps >1) $ setVictory [] diff --git a/src/Language/Nomyx/Evaluation.hs b/src/Language/Nomyx/Evaluation.hs --- a/src/Language/Nomyx/Evaluation.hs +++ b/src/Language/Nomyx/Evaluation.hs @@ -13,9 +13,9 @@ import Data.Function import Data.Time import Debug.Trace -import Unsafe.Coerce -- | evaluate an expression. +-- The rule number passed is the number of the rule containing the expression. evalExp :: Exp a -> RuleNumber -> State Game a evalExp (NewVar name def) rn = do vars <- gets variables @@ -78,6 +78,8 @@ evalExp (Output pn string) rn = outputS pn string >> return () evalExp (ProposeRule rule) _ = evProposeRule rule + +-- | activates (execute) a rule evalExp (ActivateRule rule) rn = evActivateRule rule rn evalExp (RejectRule rule) rn = evRejectRule rule rn evalExp (AddRule rule) _ = evAddRule rule @@ -110,7 +112,7 @@ mapM_ f filtered where f (EH {ruleNumber, eventNumber, handler}) = case cast handler of Just castedH -> do - traceState ("event found " ++ (show e)) + --traceState ("event found " ++ (show e)) evalExp (castedH (eventNumber, dat)) ruleNumber Nothing -> outputS 1 ("failed " ++ (show $ typeOf handler)) @@ -237,8 +239,7 @@ evInputChoice ic d = triggerEvent ic (InputChoiceData d) evTriggerTime :: UTCTime -> State Game () -evTriggerTime t = do - triggerEvent (Time t) (TimeData t) +evTriggerTime t = triggerEvent (Time t) (TimeData t) --delete all variables of a rule @@ -253,12 +254,7 @@ evs <- gets events modify (\g -> g { events = filter (\(EH {ruleNumber = myrn}) -> myrn /= rn) evs}) --- | 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) + traceState :: String -> State s String traceState x = state (\s -> trace ("trace: " ++ x) (x, s)) diff --git a/src/Language/Nomyx/Examples.hs b/src/Language/Nomyx/Examples.hs new file mode 100644 --- /dev/null +++ b/src/Language/Nomyx/Examples.hs @@ -0,0 +1,129 @@ +{-# 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, + module Data.Time.Recurrence, module Control.Monad, module Data.List, module Data.Time.Clock) where + +import Language.Nomyx.Rule +import Language.Nomyx.Expression +import Data.Function +import System.Locale (defaultTimeLocale, rfc822DateFormat) +import Data.Time.Clock hiding (getCurrentTime) +import Data.Time.Recurrence hiding (filter) +import Control.Arrow +import Data.List +import Debug.Trace +import Control.Monad + +-- | A rule that does nothing +nothing :: RuleFunc +nothing = VoidRule $ return () + +-- | 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 (+ (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 + +-- | Change unanimity vote (usually rule 2) to absolute majority (half participants plus one) +voteWithMajority :: RuleFunc +voteWithMajority = VoidRule $ do + suppressRule 1 + addRuleParams_ "vote with majority" (onRuleProposed $ voteWith majority) "onProposedRule $ voteWith majority" 2 "meta-rule: return true if a majority of players vote positively for a new rule" + activateRule_ 1 + autoDelete + + +-- | player pn is the king +makeKing :: PlayerNumber -> RuleFunc +makeKing pn = VoidRule $ newVar_ "King" pn >> return () + +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 + voidRule $ 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 + + + diff --git a/src/Language/Nomyx/Expression.hs b/src/Language/Nomyx/Expression.hs --- a/src/Language/Nomyx/Expression.hs +++ b/src/Language/Nomyx/Expression.hs @@ -16,14 +16,15 @@ import Control.Concurrent.STM import Language.Haskell.Interpreter.Server import Data.Time - + type PlayerNumber = Int type PlayerName = String type RuleNumber = Int type RuleName = String type RuleText = String type RuleCode = String -type EventNumber = Int +type EventNumber = Int +type EventName = String type VarName = String type GameName = String type Code = String @@ -59,12 +60,16 @@ instance Monad Exp where return = Const - (>>=) = Bind + (>>=) = Bind + +instance Functor Exp where + fmap f e = Bind e $ Const . f + -- * Variables -- | a container for a variable name and type -data V a = V String +data V a = V {varName :: String} deriving (Typeable) -- | stores the variable's data data Var = forall a . (Typeable a, Show a, Eq a) => @@ -105,13 +110,13 @@ -- | 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 + 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 @@ -133,12 +138,13 @@ data EventHandler where EH :: (Typeable e, Show e, Eq e) => {eventNumber :: EventNumber, - ruleNumber :: RuleNumber, + ruleNumber :: RuleNumber, + --eventName :: EventName, event :: Event e, handler :: (EventNumber, EventData e) -> Exp ()} -> EventHandler instance Show EventHandler where - show (EH en rn e _) = (show en) ++ " " ++ (show rn) ++ " (" ++ (show e) ++")" + show (EH en rn e _) = (show en) ++ " " ++ " " ++ (show rn) ++ " (" ++ (show e) ++")" instance Eq EventHandler where (EH {eventNumber=e1}) == (EH {eventNumber=e2}) = e1 == e2 @@ -151,13 +157,13 @@ -- | type of rule to assess the legality of a given parameter type OneParamRule a = a -> Exp RuleResponse +-- | type of rule that just mofify the game state +type NoParamRule = Exp () + -- | a rule can assess the legality either immediatly of later through a messsage data RuleResponse = BoolResp {boolResp :: Bool} | MsgResp {msgResp :: Event (Message Bool)} --- | type of rule that just mofify the game state -type NoParamRule = Exp () - -- | the different types of rules data RuleFunc = RuleRule {ruleRule :: OneParamRule Rule} @@ -165,9 +171,8 @@ | VoidRule {voidRule :: NoParamRule} deriving (Typeable) instance Show RuleFunc where - show _ = "RuleFunc" - - + show _ = "RuleFunc" + -- | 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 @@ -201,7 +206,8 @@ -- * Game -- | The state of the game: -data Game = Game { gameName :: GameName, +data Game = Game { gameName :: GameName, + gameDesc :: String, rules :: [Rule], players :: [PlayerInfo], variables :: [Var], @@ -215,11 +221,23 @@ show (Game { gameName, rules, players, variables, events, outputs, victory}) = "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) - + +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 + -- | 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) diff --git a/src/Language/Nomyx/Rule.hs b/src/Language/Nomyx/Rule.hs --- a/src/Language/Nomyx/Rule.hs +++ b/src/Language/Nomyx/Rule.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveDataTypeable, GADTs, ScopedTypeVariables, TupleSections#-} +{-# LANGUAGE DeriveDataTypeable, GADTs, ScopedTypeVariables, TupleSections, TemplateHaskell#-} -- | All the building blocks to build rules and basic rules examples. module Language.Nomyx.Rule where @@ -16,7 +16,9 @@ import Control.Arrow import Data.Time.Recurrence hiding (filter) import Safe +import Control.Applicative + -- * Variables -- | variable creation newVar :: (Typeable a, Show a, Eq a) => VarName -> a -> Exp (Maybe (V a)) @@ -38,7 +40,7 @@ ma <- ReadVar v case ma of Just (val:: a) -> return val - Nothing -> error $ "readVar_: Variable " ++ a ++ " not existing" + Nothing -> error $ "readVar_: Variable \"" ++ a ++ "\" with type \"" ++ (show $ typeOf v) ++ "\" not existing" -- | variable writing writeVar :: (Typeable a, Show a, Eq a) => (V a) -> a -> Exp Bool @@ -105,11 +107,11 @@ -- | get the association array getArrayVarData :: (Ord i, Typeable a, Show a, Eq a, Typeable i, Show i) => (ArrayVar i a) -> Exp ([(i, Maybe a)]) -getArrayVarData (ArrayVar _ v) = readVar_ v >>= return . toList +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) -> Exp ([(i, a)]) -getArrayVarData' v = getArrayVarData v >>= return . catMaybes . map sndMaybe +getArrayVarData' v = catMaybes . map sndMaybe <$> (getArrayVarData v) delArrayVar :: (Ord i, Typeable a, Show a, Eq a, Typeable i, Show i) => (ArrayVar i a) -> Exp () delArrayVar (ArrayVar m v) = delAllEvents m >> delVar_ v @@ -167,31 +169,39 @@ schedule :: (Schedule Freq) -> (UTCTime -> Exp ()) -> Exp () schedule sched f = do now <- getCurrentTime - let next = head $ drop 1 $ starting now $ sched - onEventOnce_ (Time next) $ f' sched where - f' sched (TimeData t) = do - let next = head $ drop 1 $ starting t $ sched - onEventOnce_ (Time next) $ f' sched - f t + 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 -> Exp ()) -> (Schedule Freq) -> (EventData Time) -> Exp () +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) -> Exp () -> Exp () schedule_ ts f = schedule ts (\_-> f) --at each time provided, the supplied function will be called schedule' :: [UTCTime] -> (UTCTime -> Exp ()) -> Exp () schedule' sched f = do + let sched' = sort sched now <- getCurrentTime - let nextMay = headMay $ filter (>now) $ sched + let nextMay = headMay $ filter (>=now) $ sched' case nextMay of - Just next -> onEventOnce_ (Time next) $ f' sched + Just next -> do + if (next == now) then executeAndScheduleNext' (f . timeData) sched' (TimeData now) + else onEventOnce_ (Time next) $ executeAndScheduleNext' (f . timeData) sched' Nothing -> return () - where - f' sched (TimeData t) = do - let nextMay = headMay $ filter (>t) $ sched - case nextMay of - Just next -> onEventOnce_ (Time next) $ f' sched - Nothing -> return () - f t + + +executeAndScheduleNext' :: (EventData Time -> Exp ()) -> [UTCTime] -> (EventData Time) -> Exp () +executeAndScheduleNext' f sched now = do + f now + let rest = drop 1 $ sched + when (rest /= []) $ onEventOnce_ (Time $ head rest) $ executeAndScheduleNext' f sched + schedule'_ :: [UTCTime] -> Exp () -> Exp () schedule'_ ts f = schedule' ts (\_-> f) @@ -328,21 +338,18 @@ -- | Get the total number of players getPlayersNumber :: Exp Int -getPlayersNumber = getPlayers >>= return . length +getPlayersNumber = length <$> getPlayers getAllPlayerNumbers :: Exp [PlayerNumber] -getAllPlayerNumbers = do - ps <- getPlayers - return $ map playerNumber ps +getAllPlayerNumbers = map playerNumber <$> getPlayers + -- | outputs a message to one player output :: String -> PlayerNumber -> Exp () output s pn = Output pn s outputAll :: String -> Exp () -outputAll s = do - pls <- getPlayers - mapM_ ((output s) . playerNumber) pls +outputAll s = getPlayers >>= mapM_ ((output s) . playerNumber) getCurrentTime :: Exp UTCTime getCurrentTime = CurrentTime @@ -351,7 +358,14 @@ getSelfRuleNumber :: Exp RuleNumber getSelfRuleNumber = SelfRuleNumber +getSelfRule :: Exp Rule +getSelfRule = do + srn <- getSelfRuleNumber + rs:[] <- getRulesByNumbers [srn] + return rs +getSelfProposedByPlayer :: Exp PlayerNumber +getSelfProposedByPlayer = getSelfRule >>= return . rProposedBy -- * Rule samples @@ -359,6 +373,7 @@ 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 = RuleRule f where f r = do @@ -389,38 +404,42 @@ oks <- mapM (applyRule rule) rs when (and oks) $ activateRule_ $ rNumber rule - +applyRule :: Rule -> Rule -> Exp Bool +applyRule (Rule {rRuleFunc = rf}) r = do + case rf of + RuleRule f1 -> f1 r >>= return . boolResp + otherwise -> return False + + -- | active metarules are automatically used to evaluate a given rule -autoMetarules :: Rule -> Exp RuleResponse -autoMetarules r = do +checkWithMetarules :: Rule -> Exp RuleResponse +checkWithMetarules r = do rs <- getActiveRules - let rrs = mapMaybe f rs + let rrs = mapMaybe maybeMetaRule rs evals <- mapM (\rr -> rr r) rrs andrrs evals - where - f Rule {rRuleFunc = (RuleRule r)} = Just r - f _ = Nothing --- | any new rule will be activate if all active meta rules returns True -applicationMetaRule :: RuleFunc -applicationMetaRule = VoidRule $ onEvent_ (RuleEv Proposed) $ \(RuleData rule) -> do - r <- autoMetarules rule - case r of - BoolResp b -> activateOrReject rule b - MsgResp m -> onMessageOnce m $ (activateOrReject rule) . messageData - return () + +maybeMetaRule :: Rule -> Maybe (OneParamRule Rule) +maybeMetaRule Rule {rRuleFunc = (RuleRule r)} = Just r +maybeMetaRule _ = Nothing -applyRule :: Rule -> Rule -> Exp Bool -applyRule (Rule {rRuleFunc = rf}) r = do - case rf of - RuleRule f1 -> f1 r >>= return . boolResp - otherwise -> return False + +-- | any new rule will be activate if all active meta rules returns True +onRuleProposed :: (Rule -> Exp RuleResponse) -> 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) -- | rule that performs a vote for a rule on all players. The provided function is used to count the votes. -vote :: ([(PlayerNumber, ForAgainst)] -> Bool) -> RuleFunc -vote f = RuleRule $ \rule -> do +voteWith :: ([(PlayerNumber, ForAgainst)] -> Bool) -> Rule -> Exp RuleResponse +voteWith f rule = do pns <- getAllPlayerNumbers let rn = show $ rNumber rule let m = Message ("Unanimity for " ++ rn) @@ -460,26 +479,42 @@ delArrayVar voteVar mapM_ delEvent ics return $ MsgResp m - + +-- | perform an action for each current players, new players and leaving players +forEachPlayer :: (PlayerNumber -> Exp ()) -> (PlayerNumber -> Exp ()) -> (PlayerNumber -> Exp ()) -> Exp () +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 -> Exp ()) -> Exp () +forEachPlayer_ action = forEachPlayer action action (\_ -> return ()) + +forEachPlayer' :: (PlayerNumber -> Exp a) -> ((PlayerNumber, a) -> Exp ()) -> Exp () +forEachPlayer' = undefined -- | create a value initialized for each players --manages players joining and leaving -createValueForEachPlayer :: Int -> String -> Exp () -createValueForEachPlayer initialValue varName = do +createValueForEachPlayer :: Int -> V [(Int, Int)] -> Exp () +createValueForEachPlayer initialValue var = do pns <- getAllPlayerNumbers - v <- newVar_ varName $ map (,initialValue::Int) pns - onEvent_ (Player Arrive) $ \(PlayerData p) -> modifyVar v ((playerNumber p, initialValue):) - onEvent_ (Player Leave) $ \(PlayerData p) -> modifyVar v $ filter $ (/= playerNumber p) . fst + v <- newVar_ (varName var) $ map (,initialValue::Int) pns + forEachPlayer (\_-> return ()) + (\p -> modifyVar v ((p, initialValue):)) + (\p -> modifyVar v $ filter $ (/= p) . fst) --- | create and modify values for players -createValueForEachPlayer_ :: String -> Exp () +-- | create a value initialized for each players initialized to zero +--manages players joining and leaving +createValueForEachPlayer_ :: V [(Int, Int)] -> Exp () createValueForEachPlayer_ = createValueForEachPlayer 0 -modifyValueOfPlayer :: PlayerNumber -> String -> (Int -> Int) -> Exp () -modifyValueOfPlayer pn var f = modifyVar (V var::V [(Int, Int)]) $ map $ (\(a,b) -> if a == pn then (a, f b) else (a,b)) +modifyValueOfPlayer :: PlayerNumber -> V [(Int, Int)] -> (Int -> Int) -> Exp () +modifyValueOfPlayer pn var f = modifyVar var $ map $ (\(a,b) -> if a == pn then (a, f b) else (a,b)) -modifyAllValues :: String -> (Int -> Int) -> Exp () -modifyAllValues var f = modifyVar (V var::V [(Int, Int)]) $ map $ second f +modifyAllValues :: V [(Int, Int)] -> (Int -> Int) -> Exp () +modifyAllValues var f = modifyVar var $ map $ second f -- | Player p cannot propose anymore rules noPlayPlayer :: PlayerNumber -> RuleFunc @@ -487,9 +522,7 @@ -- | a rule can autodelete itself (generaly after having performed some actions) autoDelete :: Exp () -autoDelete = do - s <- getSelfRuleNumber - suppressRule_ s +autoDelete = getSelfRuleNumber >>= suppressRule_ -- | All rules from player p are erased: diff --git a/src/Language/Nomyx/Test.hs b/src/Language/Nomyx/Test.hs new file mode 100644 --- /dev/null +++ b/src/Language/Nomyx/Test.hs @@ -0,0 +1,249 @@ +{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable, NamedFieldPuns, GADTs#-} + +module Language.Nomyx.Test where + +import Language.Nomyx.Rule +import Language.Nomyx.Expression +import Language.Nomyx.Evaluation +import Control.Monad +import Control.Monad.State.Lazy +import Data.Typeable +import Data.Time +import Data.Maybe (fromJust) + +date1 = parse822Time "Tue, 02 Sep 1997 09:00:00 -0400" +date2 = parse822Time "Tue, 02 Sep 1997 10:00:00 -0400" + +testGame = Game { gameName = "test", + gameDesc = "test", + rules = [], + players = [PlayerInfo 1 "coco"], + variables = [], + events = [], + outputs = [], + victory = [], + currentTime = date1} + +testRule = Rule { rNumber = 0, + rName = "test", + rDescription = "test", + rProposedBy = 0, + rRuleCode = "", + rRuleFunc = VoidRule $ return (), + rStatus = Pending, + rAssessedBy = Nothing} + +evalRuleFunc (VoidRule f) = evalState (evalExp f 0) testGame +execRuleFuncEvent (VoidRule f) e d = execState (evalExp f 0 >> (triggerEvent e d)) testGame +execRuleFuncGame (VoidRule f) g = execState (evalExp f 0) g +execRuleFuncEventGame (VoidRule f) e d g = execState (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 unanimity vote", testUnanimityVoteEx), + ("test time event", testTimeEventEx), + ("test time event 2", testTimeEventEx2)] + +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 + Nothing -> 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 + Nothing -> 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) + +--mkInputChoiceEnum_ :: forall a. (Enum a, Bounded a, Typeable a, Eq a, Show a) => String -> a -> PlayerNumber -> (a -> Exp ()) -> Exp EventNumber + + +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")] + + +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 ())) f + sendMessage_ (Message "msg") where + f (MessageData a) = output "Received" 1 + +testSendMessageEx2 = outputs (execRuleFunc testSendMessage2) == [(1,"Received")] + +data Choice2 = Me | You deriving (Enum, Typeable, Show, Eq, Bounded) + +testUserInputWrite :: RuleFunc +testUserInputWrite = VoidRule $ do + var <- 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 + Nothing -> output "problem" 1 + +testUserInputWriteEx = (outputs $ execRuleFuncEvent testUserInputWrite (InputChoice 1 "Vote for" [Me, You] Me) (InputChoiceData Me)) == [(1,"voted Me")] + +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 + +unanimityRule = testRule {rName = "unanimityRule", rRuleFunc = RuleRule $ voteWith unanimity, rNumber = 2, rStatus = Active} +applicationMetaRuleRule = testRule {rName = "onRuleProposedUseMetaRules", rRuleFunc = onRuleProposed checkWithMetarules, rNumber = 3, rStatus = Active} +gameUnanimity = testGame {rules=[unanimityRule]} + +testUnanimityVote :: Game +testUnanimityVote = flip execState testGame $ do + addPlayer (PlayerInfo 1 "coco") + addPlayer (PlayerInfo 2 "jean paul") + evAddRule unanimityRule + evActivateRule (rNumber unanimityRule) 0 + evAddRule applicationMetaRuleRule + evActivateRule (rNumber applicationMetaRuleRule) 0 + evProposeRule testRule + evInputChoice (InputChoice 1 "Vote for rule 0" [For, Against] For) For + evInputChoice (InputChoice 2 "Vote for rule 0" [For, Against] For) For + +testUnanimityVoteEx = (rStatus $ head $ rules testUnanimityVote) == Active + +testTimeEvent :: RuleFunc +testTimeEvent = VoidRule $ do + onEvent_ (Time date1) f where + f t = outputAll $ show date1 + +testTimeEventEx = (outputs $ execRuleFuncEvent testTimeEvent (Time date1) (TimeData date1)) == [(1,show date1)] + +testTimeEvent2 :: Exp () +testTimeEvent2 = schedule' [date1, date2] (outputAll . show) + +testTimeEventEx2 = (outputs $ flip execState testGame (evalExp testTimeEvent2 0 >> gameEvs)) == [(1,show date2), (1,show date1)] where + gameEvs = do + evTriggerTime date1 + evTriggerTime date2 + +timedUnanimityRule = testRule {rName = "unanimityRule", rRuleFunc = voteWithTimeLimit unanimity date1, rNumber = 2, rStatus = Active} +gameTimedUnanimity = testGame {rules=[timedUnanimityRule]} +testTimedUnanimityVote :: Game +testTimedUnanimityVote = flip execState testGame $ do + addPlayer (PlayerInfo 1 "coco") + addPlayer (PlayerInfo 2 "jean paul") + evAddRule timedUnanimityRule + evActivateRule (rNumber timedUnanimityRule) 0 + evAddRule applicationMetaRuleRule + evActivateRule (rNumber applicationMetaRuleRule) 0 + evProposeRule testRule + evInputChoice (InputChoice 1 "Vote for rule 0" [For, Against] For) Against + evTriggerTime date1 + +testTimedUnanimityVoteEx = (rStatus $ head $ rules testTimedUnanimityVote) == Reject + +-- now <- Rule.getCurrentTime +-- let oneDay = 24 * 60 * 60 :: NominalDiffTime + + +{-autoMetarulesR = testRule {rName = "autoMetaRules", rRuleFunc = autoMetarules, rNumber = 2, rStatus = Active} +gameautoMetarules = testGame {rules=[autoMetarulesR]} + +testAutoMetarules :: Game +testAutoMetarules = flip execState testGame $ do + evAddRule unanimityRule + evActivateRule (rNumber unanimityRule) 0 + evProposeRule testRule + evInputChoice (InputChoice 1 "Vote for rule test") For + evInputChoice (InputChoice 2 "Vote for rule test") For + +testAutoMetarulesEx = (rStatus $ head $ rules testUnanimityVote) == Active +-} + + diff --git a/tests/Test.hs b/tests/Test.hs deleted file mode 100644 --- a/tests/Test.hs +++ /dev/null @@ -1,235 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable, NamedFieldPuns, GADTs#-} - -module Test where - -import Language.Nomyx.Rule -import Language.Nomyx.Expression -import Language.Nomyx.Evaluation -import Control.Monad -import Control.Monad.State.Lazy -import Data.Typeable -import Data.Time -import Data.Maybe (fromJust) - -date1 = parse822Time "Tue, 02 Sep 1997 09:00:00 -0400" -date2 = parse822Time "Tue, 02 Sep 1997 10:00:00 -0400" - -testGame = Game { gameName = "test", - rules = [], - players = [PlayerInfo 1 "coco"], - variables = [], - events = [], - outputs = [], - victory = [], - currentTime = date1} - -testRule = Rule { rNumber = 0, - rName = "test", - rDescription = "test", - rProposedBy = 0, - rRuleCode = "", - rRuleFunc = VoidRule $ return (), - rStatus = Pending, - rAssessedBy = Nothing} - -evalRuleFunc (VoidRule f) = evalState (evalExp f 0) testGame -execRuleFuncEvent (VoidRule f) e d = execState (evalExp f 0 >> (triggerEvent e d)) testGame -execRuleFuncGame (VoidRule f) g = execState (evalExp f 0) g -execRuleFuncEventGame (VoidRule f) e d g = execState (evalExp f 0 >> (triggerEvent e d)) g -execRuleFunc f = execRuleFuncGame f testGame - -tests = [testVarEx1, testVarEx2, testVarEx3, testVarEx4, testVarEx5, testSingleInputEx, testInputStringEx, - testSendMessageEx, testSendMessageEx2, testUserInputWriteEx, testActivateRuleEx, - testAutoActivateEx, testUnanimityVoteEx, testTimeEventEx, testTimeEventEx2] -allTests = and $ 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 - Nothing -> 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 - Nothing -> 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) - ---mkInputChoiceEnum_ :: forall a. (Enum a, Bounded a, Typeable a, Eq a, Show a) => String -> a -> PlayerNumber -> (a -> Exp ()) -> Exp EventNumber - - -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")] - - -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 ())) f - sendMessage_ (Message "msg") where - f (MessageData a) = output "Received" 1 - -testSendMessageEx2 = outputs (execRuleFunc testSendMessage2) == [(1,"Received")] - -data Choice2 = Me | You deriving (Enum, Typeable, Show, Eq, Bounded) - -testUserInputWrite :: RuleFunc -testUserInputWrite = VoidRule $ do - var <- 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 - Nothing -> output "problem" 1 - -testUserInputWriteEx = (outputs $ execRuleFuncEvent testUserInputWrite (InputChoice 1 "Vote for" [Me, You] Me) (InputChoiceData Me)) == [(1,"voted Me")] - -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 - -unanimityRule = testRule {rName = "unanimityRule", rRuleFunc = vote unanimity, rNumber = 2, rStatus = Active} -applicationMetaRuleRule = testRule {rName = "applicationMetaRule", rRuleFunc = applicationMetaRule, rNumber = 3, rStatus = Active} -gameUnanimity = testGame {rules=[unanimityRule]} - -testUnanimityVote :: Game -testUnanimityVote = flip execState testGame $ do - addPlayer (PlayerInfo 1 "coco") - addPlayer (PlayerInfo 2 "jean paul") - evAddRule unanimityRule - evActivateRule (rNumber unanimityRule) 0 - evAddRule applicationMetaRuleRule - evActivateRule (rNumber applicationMetaRuleRule) 0 - evProposeRule testRule - evInputChoice (InputChoice 1 "Vote for rule 0" [For, Against] For) For - evInputChoice (InputChoice 2 "Vote for rule 0" [For, Against] For) For - -testUnanimityVoteEx = (rStatus $ head $ rules testUnanimityVote) == Active - -testTimeEvent :: RuleFunc -testTimeEvent = VoidRule $ do - onEvent_ (Time date1) f where - f t = outputAll $ show date1 - -testTimeEventEx = (outputs $ execRuleFuncEvent testTimeEvent (Time date1) (TimeData date1)) == [(1,show date1)] - -testTimeEvent2 :: Exp () -testTimeEvent2 = schedule' [date1, date2] (outputAll . show) - -testTimeEventEx2 = (outputs $ flip execState testGame (evalExp testTimeEvent2 0 >> gameEvs)) == [(1,show date2), (1,show date1)] where - gameEvs = do - evTriggerTime date1 - evTriggerTime date2 - -timedUnanimityRule = testRule {rName = "unanimityRule", rRuleFunc = voteWithTimeLimit unanimity date1, rNumber = 2, rStatus = Active} -gameTimedUnanimity = testGame {rules=[timedUnanimityRule]} -testTimedUnanimityVote :: Game -testTimedUnanimityVote = flip execState testGame $ do - addPlayer (PlayerInfo 1 "coco") - addPlayer (PlayerInfo 2 "jean paul") - evAddRule timedUnanimityRule - evActivateRule (rNumber timedUnanimityRule) 0 - evAddRule applicationMetaRuleRule - evActivateRule (rNumber applicationMetaRuleRule) 0 - evProposeRule testRule - evInputChoice (InputChoice 1 "Vote for rule 0" [For, Against] For) Against - evTriggerTime date1 - -testTimedUnanimityVoteEx = (rStatus $ head $ rules testTimedUnanimityVote) == Reject - --- now <- Rule.getCurrentTime --- let oneDay = 24 * 60 * 60 :: NominalDiffTime - - -{-autoMetarulesR = testRule {rName = "autoMetaRules", rRuleFunc = autoMetarules, rNumber = 2, rStatus = Active} -gameautoMetarules = testGame {rules=[autoMetarulesR]} - -testAutoMetarules :: Game -testAutoMetarules = flip execState testGame $ do - evAddRule unanimityRule - evActivateRule (rNumber unanimityRule) 0 - evProposeRule testRule - evInputChoice (InputChoice 1 "Vote for rule test") For - evInputChoice (InputChoice 2 "Vote for rule test") For - -testAutoMetarulesEx = (rStatus $ head $ rules testUnanimityVote) == Active --} - -