Nomyx-Rules (empty) → 0.0.1

raw patch · 11 files changed

+1501/−0 lines, 11 filesdep +basedep +containersdep +ghcsetup-changed

Dependencies added: base, containers, ghc, hint-server, hslogger, mtl, old-locale, safe, stm, time, time-recurrence

Files

AUTHORS +1/−0
LICENSE +27/−0
Nomyx-Rules.cabal +29/−0
README +22/−0
Setup.lhs +6/−0
examples/Examples.hs +99/−0
src/Language/Nomyx/Evaluation.hs +269/−0
src/Language/Nomyx/Expression.hs +225/−0
src/Language/Nomyx/Rule.hs +556/−0
src/Paths_Nomyx_Rules.hs +32/−0
tests/Test.hs +235/−0

+ AUTHORS view

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

+ LICENSE view

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

+ Nomyx-Rules.cabal view

@@ -0,0 +1,29 @@+name: Nomyx-Rules+version: 0.0.1+cabal-version: >=1.2+build-type: Simple+license: BSD3+license-file: LICENSE+copyright: 2012 Corentin Dupont+maintainer: Corentin Dupont+stability: Experimental+synopsis: Language to express rules for Nomic+description: Provide a DSL to express rules for the Nomic game, with evaluation engine+category: Game Engine+author: Corentin Dupont+data-files: examples/Examples.hs src/Language/Nomyx/Evaluation.hs+            src/Language/Nomyx/Expression.hs src/Language/Nomyx/Rule.hs+            tests/Test.hs+data-dir: ""+extra-source-files: examples/Examples.hs tests/Test.hs, 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: True+    buildable: True+    hs-source-dirs: examples src tests+

+ README view

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

+ Setup.lhs view

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

+ examples/Examples.hs view

@@ -0,0 +1,99 @@+{-# 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 ()++-- | 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+    addRule_ $ defaultRule {rName = "monarchy", rRuleFunc = monarchy, rRuleCode = "monarchy", rNumber = 1}+    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+    setVictory $ map fst $ filter ((>= x) . snd) counts++-- | 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

+ src/Language/Nomyx/Evaluation.hs view

@@ -0,0 +1,269 @@+{-# LANGUAGE FlexibleInstances, NoMonomorphismRestriction, GADTs, NamedFieldPuns, ScopedTypeVariables #-}++module Language.Nomyx.Evaluation where++import Language.Nomyx.Expression+import Control.Monad+import Control.Monad.State.Class+import Data.Maybe+import Control.Monad.State.Lazy+import Data.List+import Data.Typeable+import Data.Maybe+import Data.Function+import Data.Time+import Debug.Trace+import Unsafe.Coerce++-- | evaluate an expression.+evalExp :: Exp a -> RuleNumber -> State Game a+evalExp (NewVar name def) rn = do+    vars <- gets variables+    case find (\(Var _ myName _) -> myName == name) vars of+       Nothing -> do+          modify (\game -> game { variables = (Var rn name def) : vars})+          return $ Just (V name)+       Just _ -> return Nothing+++evalExp (DelVar (V name)) _ = do+    vars <- gets variables+    case find (\(Var a myName b) -> myName == name) vars of+       Nothing -> return False+       Just _ -> do+          modify (\g -> g { variables = filter (\(Var a myName b) -> myName /= name) vars})+          return True++evalExp (ReadVar (V name)) rn = do+    vars <- gets variables+    let var = find (\(Var _ myName val) -> myName == name) vars+    case var of+       Nothing -> return Nothing+       Just (Var _ _ val) -> case cast val of+           Just v -> return $ Just v+           Nothing -> return Nothing+++evalExp (WriteVar (V name) val) rn = do+    vars <- gets variables+    let newVars = replaceWith (\(Var rn n v) -> n == name) (Var rn name val) vars+    case find (\(Var a myName b) -> myName == name) vars of+       Nothing -> return False+       Just _ -> do+          modify (\game -> game { variables = newVars})+          return True++evalExp (OnEvent event handler) rn = do+    evs <- gets events+    let en = getFreeNumber (map eventNumber evs)+    modify (\game -> game { events = (EH en rn event handler) : evs})+    return en++evalExp (DelEvent en) _ = do+    evs <- gets events+    case find (\EH {eventNumber} -> eventNumber == en) evs of+       Nothing -> return False+       Just _ -> do+          modify (\g -> g { events = filter (\EH {eventNumber} -> eventNumber /= en) evs})+          return True++evalExp (DelAllEvents e) _ = do+    evs <- gets events+    modify (\g -> g { events = filter (\EH {event} -> not $ event === e) evs})+++evalExp (SendMessage (Message id) myData) rn = do+    triggerEvent (Message id) (MessageData myData)+    return ()++evalExp (Output pn string) rn = outputS pn string >> return ()+evalExp (ProposeRule rule) _ = evProposeRule rule+evalExp (ActivateRule rule) rn = evActivateRule rule rn+evalExp (RejectRule rule) rn = evRejectRule rule rn+evalExp (AddRule rule) _ = evAddRule rule+evalExp (DelRule del) _ = evDelRule del+evalExp (ModifyRule mod rule) rn = evModifyRule mod rule+evalExp GetRules rn = gets rules+evalExp GetPlayers rn = gets players+evalExp SelfRuleNumber rn = return rn+evalExp (SetVictory ps) rn = do+    modify (\game -> game { victory = ps})+    pls <- gets players+    let victorious = filter (\pl -> playerNumber pl `elem` ps) pls+    trace "setV           " $ triggerEvent Victory (VictoryData victorious)+    return ()++evalExp (CurrentTime) _ = gets currentTime+evalExp (Const a) _ = return a+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 -> State Game ()+triggerEvent e dat = do+    --traceState ("trigger event " ++ (show e))+    --traceState ("EventData " ++ (show dat))+    evs <- gets 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+                traceState ("event found " ++ (show e))+                evalExp (castedH (eventNumber, dat)) ruleNumber+            Nothing -> outputS 1 ("failed " ++ (show $ typeOf handler))++triggerChoice :: Int -> Int -> State Game ()+triggerChoice myEventNumber choiceIndex = do+    evs <- gets events+    let filtered = filter (\(EH {eventNumber}) -> eventNumber == myEventNumber) evs+    mapM_ (execChoiceHandler myEventNumber choiceIndex) filtered+    return ()++execChoiceHandler :: EventNumber -> Int -> EventHandler -> State Game ()+execChoiceHandler eventNumber choiceIndex (EH _ _ (InputChoice ruleNumber _ cs _) handler) = evalExp (handler (eventNumber, InputChoiceData (cs!!choiceIndex))) ruleNumber+execChoiceHandler _ _ _ = return ()+++--execute all the handlers of the specified event with the given data+findEvent ::EventNumber -> [EventHandler] -> Maybe (EventHandler)+findEvent en evs = find (\(EH {eventNumber}) -> en == eventNumber) evs+++findChoice :: (Eq a, Read a) => String -> Event (InputChoice a) -> a+findChoice s (InputChoice _ _ choices _) = fromJust $ find (== (read s)) choices++outputS :: PlayerNumber -> String -> State Game ()+outputS pn s = modify (\game -> game { outputs = (pn, s) : (outputs game)})++getFreeNumber :: (Eq a, Num a, Enum a) => [a] -> a+getFreeNumber l = head [a| a <- [1..], not $ a `elem` l]+++evProposeRule :: Rule -> State Game Bool+evProposeRule rule = do+    rs <- gets rules+    case find (\Rule { rNumber = rn} -> rn == rNumber rule) rs of+       Nothing -> do+          modify (\game -> game { rules = rule : rs})+          triggerEvent (RuleEv Proposed) (RuleData rule)+          return True+       Just _ -> return False++--Sets the rule status to Active and execute it if possible+evActivateRule :: RuleNumber -> RuleNumber -> State Game Bool+evActivateRule rn by = do+    rs <- gets rules+    case find (\Rule { rNumber = myrn} -> myrn == rn) rs of+       Nothing -> return False+       Just r -> do+          let newrules = replaceWith (\Rule { rNumber = myrn} -> myrn == rn) r {rStatus = Active, rAssessedBy = Just by} rs+          modify (\g -> g { rules = newrules})+          --execute the rule+          case rRuleFunc r of+             (VoidRule vr) -> evalExp vr rn+             _ -> return ()+          triggerEvent (RuleEv Activated) (RuleData r)+          return True++evRejectRule :: RuleNumber -> RuleNumber -> State Game Bool+evRejectRule rule by = do+    rs <- gets rules+    case find (\Rule { rNumber = myrn} -> myrn == rule) rs of+       Nothing -> return False+       Just r -> do+          let newrules = replaceWith (\Rule { rNumber = myrn} -> myrn == rule) r {rStatus = Reject, rAssessedBy = Just by} rs+          modify (\g -> g { rules = newrules})+          triggerEvent (RuleEv Rejected) (RuleData r)+          delVarsRule rule+          delEventsRule rule+          return True++evAddRule :: Rule -> State Game Bool+evAddRule rule = do+    rs <- gets rules+    case find (\Rule { rNumber = rn} -> rn == rNumber rule) rs of+       Nothing -> do+          modify (\game -> game { rules = rule : rs})+          --execute the rule+          --case rRuleFunc rule of+          --   (VoidRule vr) -> evalExp vr (rNumber rule)+          --   _ -> return ()+          triggerEvent (RuleEv Added) (RuleData rule)+          return True+       Just _ -> return False++evDelRule :: RuleNumber -> State Game Bool+evDelRule del = do+    rs <- gets rules+    case find (\Rule { rNumber = myrn} -> myrn == del) rs of+       Nothing -> return False+       Just r -> do+          let newrules = filter (\Rule {rNumber} -> rNumber /= del) rs+          modify (\g -> g { rules = newrules})+          delVarsRule del+          delEventsRule del+          triggerEvent (RuleEv Deleted) (RuleData r)+          return True++--TODO: clean and execute new rule+evModifyRule :: RuleNumber -> Rule -> State Game Bool+evModifyRule mod rule = do+    rs <- gets rules+    let newRules = replaceWith (\Rule { rNumber = myrn} -> myrn == mod) rule rs+    case find (\Rule { rNumber = myrn} -> myrn == mod) rs of+       Nothing -> return False+       Just r ->  do+          modify (\game -> game { rules = newRules})+          triggerEvent (RuleEv Modified) (RuleData r)+          return True++addPlayer :: PlayerInfo -> State Game Bool+addPlayer pi@(PlayerInfo {playerNumber = pn}) = do+    pls <- gets players+    let exists = any (((==) `on` playerNumber) pi) pls+    when (not exists) $ do+        modify (\game -> game { players = pi : pls})+        triggerEvent (Player Arrive) (PlayerData pi)+    return $ not exists++delPlayer :: PlayerInfo -> State Game Bool+delPlayer pi@(PlayerInfo {playerNumber = pn}) = do+    pls <- gets players+    let exists = any (((==) `on` playerNumber) pi) pls+    when exists $ do+        modify (\game -> game { players = filter ((/= pn) . playerNumber) pls})+        triggerEvent (Player Leave) (PlayerData pi)+    return exists++evInputChoice :: (Eq d, Show d, Typeable d, Read d) => Event(InputChoice d) -> d -> State Game ()+evInputChoice ic d = triggerEvent ic (InputChoiceData d)++evTriggerTime :: UTCTime -> State Game ()+evTriggerTime t = do+    triggerEvent (Time t) (TimeData t)+++--delete all variables of a rule+delVarsRule :: RuleNumber -> State Game ()+delVarsRule rn = do+    vars <- gets variables+    modify (\g -> g { variables = filter (\(Var myrn _ _) -> myrn /= rn) vars})++--delete all events of a rule+delEventsRule :: RuleNumber -> State Game ()+delEventsRule rn = do+    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))+

+ src/Language/Nomyx/Expression.hs view

@@ -0,0 +1,225 @@+
+{-# LANGUAGE NoMonomorphismRestriction, FlexibleInstances, GADTs,
+    UndecidableInstances, DeriveDataTypeable, FlexibleContexts,
+    GeneralizedNewtypeDeriving, MultiParamTypeClasses, TypeFamilies,
+    TypeSynonymInstances, TemplateHaskell, ExistentialQuantification,
+    TypeFamilies, ScopedTypeVariables, StandaloneDeriving, NamedFieldPuns,
+    EmptyDataDecls #-}
+
+-- | This module containt the type definitions necessary to build a Nomic rule. 
+module Language.Nomyx.Expression where
+
+import Data.Typeable
+import Data.Ratio
+import Control.Monad.State
+import Data.List
+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 VarName = String
+type GameName = String
+type Code = String
+
+-- * Expression
+
+-- | an Exp allows the player's rule to have access to the state of the game.
+-- | it is a compositional algebra defined with a GADT.
+data Exp a where
+     NewVar       :: (Typeable a, Show a, Eq a) => VarName -> a -> Exp (Maybe (V a))
+     DelVar       :: (V a) -> Exp Bool
+     ReadVar      :: (Typeable a, Show a, Eq a) => (V a) -> Exp (Maybe a)
+     WriteVar     :: (Typeable a, Show a, Eq a) => (V a) -> a -> Exp Bool
+     OnEvent      :: (Typeable e, Show e, Eq e) => Event e -> ((EventNumber, EventData e) -> Exp ()) -> Exp EventNumber
+     DelEvent     :: EventNumber -> Exp Bool
+     DelAllEvents :: (Typeable e, Show e, Eq e) => Event e -> Exp ()
+     SendMessage  :: (Typeable a, Show a, Eq a) => Event (Message a) -> a -> Exp ()
+     Output       :: PlayerNumber -> String -> Exp ()
+     ProposeRule  :: Rule -> Exp Bool
+     ActivateRule :: RuleNumber -> Exp Bool
+     RejectRule   :: RuleNumber -> Exp Bool
+     AddRule      :: Rule -> Exp Bool
+     DelRule      :: RuleNumber -> Exp Bool
+     ModifyRule   :: RuleNumber -> Rule -> Exp Bool
+     GetRules     :: Exp [Rule]
+     SetVictory   :: [PlayerNumber] -> Exp ()
+     GetPlayers   :: Exp [PlayerInfo]
+     Const        :: a -> Exp a
+     Bind         :: Exp a -> (a -> Exp b) -> Exp b
+     CurrentTime  :: Exp (UTCTime)+     SelfRuleNumber :: Exp RuleNumber
+     deriving (Typeable)
+
+instance Monad Exp where
+   return = Const
+   (>>=) = Bind
+
+-- * Variables
+
+-- | a container for a variable name and type
+data V a = V String
+
+-- | stores the variable's data
+data Var = forall a . (Typeable a, Show a, Eq a) =>
+        Var { vRuleNumber :: Int,
+              vName :: String,
+              vData :: a}
+
+instance Show Var where
+    show (Var a b c) = (show a) ++ " " ++ (show b) ++ " " ++ (show c)
+
+instance Eq Var where
+    Var a b c == Var d e f = (a,b,c) === (d,e,f)
+
+type Output = (PlayerNumber, String)
+
+
+-- * Events
+
+-- | events types
+data Player = Arrive | Leave deriving (Typeable, Show, Eq)
+data RuleEvent = Proposed | Activated | Rejected | Added | Modified | Deleted deriving (Typeable, Show, Eq)
+data Time           deriving Typeable
+data EvRule         deriving Typeable
+data Message m      deriving Typeable
+data InputChoice c  deriving Typeable
+data InputString    deriving Typeable
+data Victory        deriving Typeable
+
+-- | events names
+data Event a where
+    Player      :: Player ->                 Event Player
+    RuleEv      :: RuleEvent ->              Event RuleEvent
+    Time        :: UTCTime ->                Event Time
+    Message     :: String ->                 Event (Message m)
+    InputChoice :: (Eq c, Show c) => PlayerNumber -> String -> [c] -> c -> Event (InputChoice c)
+    InputString :: PlayerNumber -> String -> Event InputString
+    Victory     ::                           Event Victory
+
+-- | data associated with each events
+data EventData a where
+    PlayerData      :: {playerData :: PlayerInfo}    -> EventData Player
+    RuleData        :: {ruleData :: Rule}            -> EventData RuleEvent
+    TimeData        :: {timeData :: UTCTime}         -> EventData Time
+    MessageData     :: (Show m) => {messageData :: m}            -> EventData (Message m)
+    InputChoiceData :: (Show c) => {inputChoiceData :: c}        -> EventData (InputChoice c)
+    InputStringData :: {inputStringData :: String}   -> EventData InputString
+    VictoryData     :: {victoryData :: [PlayerInfo]} -> EventData Victory
+
+deriving instance Typeable1 EventData
+deriving instance Typeable1 Event
+deriving instance (Show a) => Show (Event a)
+deriving instance Show Time
+deriving instance (Show a) => Show (Message a)
+deriving instance (Show a) => Show (InputChoice a)
+deriving instance Show InputString
+deriving instance Show Victory
+deriving instance Eq Time
+deriving instance Eq Victory
+deriving instance Eq EvRule
+deriving instance Eq (InputChoice a)
+deriving instance Eq InputString
+deriving instance Eq (Message m)
+deriving instance (Eq e) => Eq (Event e)
+deriving instance (Show a) => Show (EventData a)
+
+data EventHandler where
+    EH :: (Typeable e, Show e, Eq e) =>
+        {eventNumber :: EventNumber,
+         ruleNumber  :: RuleNumber,
+         event       :: Event e,
+         handler     :: (EventNumber, EventData e) -> Exp ()} -> EventHandler
+
+instance Show EventHandler where
+    show (EH en rn e _) = (show en) ++ " " ++ (show rn) ++ " (" ++ (show e) ++")"
++instance Eq EventHandler where+    (EH {eventNumber=e1}) == (EH {eventNumber=e2}) = e1 == e2++instance Ord EventHandler where+    (EH {eventNumber=e1}) <= (EH {eventNumber=e2}) = e1 <= e2+
+-- * Rule
+
+-- | type of rule to assess the legality of a given parameter
+type OneParamRule a = a -> Exp RuleResponse
+
+-- | 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}
+    | PlayerRule {playerRule :: OneParamRule PlayerInfo}
+    | VoidRule   {voidRule   :: NoParamRule} deriving (Typeable)
+
+instance Show RuleFunc where
+    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 
+                   rDescription  :: String,           -- description of the rule
+                   rProposedBy   :: PlayerNumber,     -- player proposing the rule
+                   rRuleCode     :: Code,             -- code of the rule as a string
+                   rRuleFunc     :: RuleFunc,         -- function representing the rule (interpreted from rRuleCode)
+                   rStatus       :: RuleStatus,       -- status of the rule
+                   rAssessedBy    :: Maybe RuleNumber} -- which rule accepted or rejected this rule
+                   deriving (Typeable, Show)
+
+instance Eq Rule where
+    (Rule {rNumber=r1}) == (Rule {rNumber=r2}) = r1 == r2
+
+instance Ord Rule where
+     (Rule {rNumber=r1}) <= (Rule {rNumber=r2}) = r1 <= r2
+
+-- | the status of a rule.
+data RuleStatus = Active      -- Active rules forms the current Constitution
+                | Pending     -- Proposed rules
+                | Reject      -- Rejected rules
+                deriving (Eq, Show, Typeable)
+
+-- * Player
+
+-- | informations on players
+data PlayerInfo = PlayerInfo { playerNumber :: PlayerNumber,
+                               playerName   :: String}
+                               deriving (Eq, Typeable, Show)
+
+-- * Game
+           
+-- | The state of the game:
+data Game = Game { gameName      :: GameName,
+                   rules         :: [Rule],
+                   players       :: [PlayerInfo],
+                   variables     :: [Var],
+                   events        :: [EventHandler],
+                   outputs       :: [Output],
+                   victory       :: [PlayerNumber],
+                   currentTime   :: UTCTime}
+                   deriving (Typeable)
+
+instance Show Game where
+    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)
+
+
+-- | an equality that tests also the types.
+(===) :: (Typeable a, Typeable b, Eq b) => a -> b -> Bool
+(===) x y = cast x == Just y
+
+
+

+ src/Language/Nomyx/Rule.hs view

@@ -0,0 +1,556 @@+{-# LANGUAGE DeriveDataTypeable, GADTs, ScopedTypeVariables, TupleSections#-}
+
+-- | All the building blocks to build rules and basic rules examples.
+module Language.Nomyx.Rule where
+
+import Language.Nomyx.Expression
+import Data.Typeable
+import Control.Monad.State
+import Data.List
+import Data.Maybe
+import Data.Time hiding (getCurrentTime)
+import Data.Function
+import Data.Map hiding (map, filter, insert, mapMaybe)
+import qualified Data.Map as M (map, insert)
+import System.Locale (defaultTimeLocale, rfc822DateFormat)
+import Control.Arrow
+import Data.Time.Recurrence hiding (filter)+import Safe++-- * Variables
+-- | variable creation
+newVar :: (Typeable a, Show a, Eq a) => VarName -> a -> Exp (Maybe (V a))
+newVar = NewVar
+
+newVar_ :: (Typeable a, Show a, Eq a) => VarName -> a -> Exp (V a)
+newVar_ s a = do
+    mv <- NewVar s a
+    case mv of
+        Just var -> return var
+        Nothing -> error "newVar_: Variable existing"
+
+-- | variable reading
+readVar :: (Typeable a, Show a, Eq a) => (V a) -> Exp (Maybe a)
+readVar = ReadVar
+
+readVar_ :: forall a. (Typeable a, Show a, Eq a) => (V a) -> Exp a
+readVar_ v@(V a) = do
+    ma <- ReadVar v
+    case ma of
+        Just (val:: a) -> return val
+        Nothing -> error $ "readVar_: Variable " ++ a ++ " not existing"
+
+-- | variable writing
+writeVar :: (Typeable a, Show a, Eq a) => (V a) -> a -> Exp Bool
+writeVar = WriteVar
+
+writeVar_ :: (Typeable a, Show a, Eq a) => (V a) -> a -> Exp ()
+writeVar_ var val = do
+    ma <- WriteVar var val
+    case ma of
+       True -> return ()
+       False -> error "writeVar_: Variable not existing"
+
+modifyVar :: (Typeable a, Show a, Eq a) => (V a) -> (a -> a) -> Exp ()
+modifyVar v f = writeVar_ v . f =<< readVar_ v
+
+-- | delete variable
+delVar :: (V a) -> Exp Bool
+delVar = DelVar
+
+delVar_ :: (V a) -> Exp ()
+delVar_ v = DelVar v >> return ()
++-- * Variable arrays
+-- | ArrayVar is an indexed array with a signal attached to warn when the array is filled.
+--each indexed elements starts empty (value=Nothing), and when the array is full, the signal is triggered.
+--This is useful to wait for a serie of events to happen, and trigger a computation on the collected results.
+data ArrayVar i a = ArrayVar (Event (Message [(i, 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] -> Exp (ArrayVar i a)
+newArrayVar name l = do
+    let list = map (\i -> (i, Nothing)) l
+    v <- newVar_ name (fromList list)
+    return $ ArrayVar (Message name) v
+
+-- | initialize an empty ArrayVar, registering a callback that will be triggered when the array is filled
+newArrayVar' :: (Ord i, Typeable a, Show a, Eq a, Typeable i, Show i) => VarName -> [i] -> ([(i,a)] -> Exp ()) -> Exp (ArrayVar i a)
+newArrayVar' name l f = do
+    av@(ArrayVar m v) <- newArrayVar name l
+    onMessage m $ f . messageData
+    return av
+
+-- | initialize an empty ArrayVar, registering a callback.
+--the callback will be triggered when the array is filled, and then the ArrayVar will be deleted
+newArrayVarOnce :: (Ord i, Typeable a, Show a, Eq a, Typeable i, Show i) => VarName -> [i] -> ([(i,a)] -> Exp ()) -> Exp (ArrayVar i a)
+newArrayVarOnce name l f = do
+    av@(ArrayVar m v) <- newArrayVar name l
+    onMessageOnce m (\a -> (f $ messageData a) >> (delVar_ v))
+    return av
+
+-- | store one value and the given index. If this is the last filled element, the registered callbacks are triggered.
+putArrayVar :: (Ord i, Typeable a, Show a, Eq a, Typeable i, Show i) => (ArrayVar i a) -> i -> a -> Exp ()
+putArrayVar (ArrayVar m v) i a = do
+    ar <- readVar_ v
+    let ar2 = M.insert i (Just a) ar
+    writeVar_ v ar2
+    let finish = and $ map isJust $ elems ar2
+    when finish $ sendMessage m (toList $ M.map fromJust 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) -> Exp (Event (Message [(i, a)]))
+getArrayVarMessage (ArrayVar m _) = return m
+
+-- | get the association array
+getArrayVarData :: (Ord i, Typeable a, Show a, Eq a, Typeable i, Show i) => (ArrayVar i a) -> Exp ([(i, Maybe a)])
+getArrayVarData (ArrayVar _ v) = readVar_ v >>= return . toList
+
+-- | 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
+
+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
++-- * Events+
+-- | register a callback on an event
+onEvent :: (Typeable e, Show e, Eq e) => Event e -> ((EventNumber, EventData e) -> Exp ()) -> Exp EventNumber
+onEvent = OnEvent
+
+-- | register a callback on an event, disregard the event number
+onEvent_ :: forall e. (Typeable e, Show e, Eq e) => Event e -> (EventData e -> Exp ()) -> Exp ()
+onEvent_ e h = do
+    OnEvent e (\(_, d) -> h d)
+    return ()
+
+-- | set an handler for an event that will be triggered only once
+onEventOnce :: (Typeable e, Show e, Eq e) => Event e -> (EventData e -> Exp ()) -> Exp EventNumber
+onEventOnce e h = do
+    let handler (en, ed) = delEvent_ en >> h ed
+    n <- OnEvent e handler
+    return n
+
+-- | set an handler for an event that will be triggered only once
+onEventOnce_ :: (Typeable e, Show e, Eq e) => Event e -> (EventData e -> Exp ()) -> Exp ()
+onEventOnce_ e h = do
+    let handler (en, ed) = delEvent_ en >> h ed
+    OnEvent e handler
+    return ()
+
+delEvent :: EventNumber -> Exp Bool
+delEvent = DelEvent
+
+delEvent_ :: EventNumber -> Exp ()
+delEvent_ e = delEvent e >> return ()
+
+delAllEvents :: (Typeable e, Show e, Eq e) => Event e -> Exp ()
+delAllEvents = DelAllEvents
++-- | broadcast a message that can be catched by another rule
+sendMessage :: (Typeable a, Show a, Eq a) => Event (Message a) -> a -> Exp ()
+sendMessage = SendMessage
+
+sendMessage_ :: Event (Message ()) -> Exp ()
+sendMessage_ m = SendMessage m ()
++-- | subscribe on a message 
+onMessage :: (Typeable m, Show m) => Event (Message m) -> ((EventData (Message m)) -> Exp ()) -> Exp ()
+onMessage m f = onEvent_ m f
+
+onMessageOnce :: (Typeable m, Show m) => Event (Message m) -> ((EventData (Message m)) -> Exp ()) -> Exp ()
+onMessageOnce m f = onEventOnce_ m f
+
+-- | on the provided schedule, the supplied function will be called
+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++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+    now <- getCurrentTime+    let nextMay = headMay $ filter (>now) $ sched+    case nextMay of+        Just next -> onEventOnce_ (Time next) $ f' 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
+
+schedule'_ :: [UTCTime] -> Exp () -> Exp ()
+schedule'_ ts f = schedule' ts (\_-> f)
++-- * Rule management
++-- | activate a rule: change its state to Active and execute it
+activateRule :: RuleNumber -> Exp Bool
+activateRule = ActivateRule
+
+activateRule_ :: RuleNumber -> Exp ()
+activateRule_ r = activateRule r >> return ()
++-- | reject a rule: change its state to Suppressed and suppresses all its environment (events, variables, inputs)+-- the rule can be activated again later
+rejectRule :: RuleNumber -> Exp Bool
+rejectRule = RejectRule
+
+rejectRule_ :: RuleNumber -> Exp ()
+rejectRule_ r = rejectRule r >> return ()
+
+getRules :: Exp [Rule]
+getRules = GetRules
+
+getActiveRules :: Exp [Rule]
+getActiveRules = return . (filter ((== Active) . rStatus) ) =<< getRules
+
+getRule :: RuleNumber -> Exp (Maybe Rule)
+getRule rn = do
+   rs <- GetRules
+   return $ find (\(Rule {rNumber = n}) -> n == rn) rs
+
+getRulesByNumbers :: [RuleNumber] -> Exp [Rule]
+getRulesByNumbers rns = mapMaybeM getRule rns
+
+getRuleFuncs :: Exp [RuleFunc]
+getRuleFuncs = return . (map rRuleFunc) =<< getRules
++-- | add a rule to the game, it will have to be activated 
+addRule :: Rule -> Exp Bool
+addRule r = AddRule r++addRule_ :: Rule -> Exp ()
+addRule_ r = AddRule r >> return ()
++--suppresses completly a rule and its environment from the system
+suppressRule :: RuleNumber -> Exp Bool
+suppressRule rn = DelRule rn
++suppressRule_ :: RuleNumber -> Exp ()
+suppressRule_ rn = DelRule rn >> return ()+
+suppressAllRules :: Exp Bool
+suppressAllRules = do
+    rs <- getRules
+    res <- mapM (suppressRule . rNumber) rs
+    return $ and res
+
+modifyRule :: RuleNumber -> Rule -> Exp Bool
+modifyRule rn r = ModifyRule rn r
+
++-- * Inputs+
+inputChoice :: (Eq c, Show c) => PlayerNumber -> String -> [c] -> c -> Event (InputChoice c)
+inputChoice = InputChoice
+
+inputChoiceHead :: (Eq c, Show c) => PlayerNumber -> String -> [c] -> Event (InputChoice c)
+inputChoiceHead pn title choices = inputChoice pn title choices (head choices)
+
+inputChoiceEnum :: forall c. (Enum c, Bounded c, Typeable c, Eq c,  Show c) => PlayerNumber -> String -> c -> Event (InputChoice c)
+inputChoiceEnum pn title defaultChoice = inputChoice pn title (enumFrom (minBound::c)) defaultChoice
+
+inputString :: PlayerNumber -> String -> Event InputString
+inputString = InputString
+
+-- | triggers a choice input to the user. The result will be sent to the callback
+onInputChoice :: (Typeable a, Eq a,  Show a) => String -> [a] -> (EventNumber -> a -> Exp ()) -> PlayerNumber -> Exp EventNumber
+onInputChoice title choices handler pn = onEvent (inputChoiceHead pn title choices) (\(en, a) -> handler en (inputChoiceData a))
+
+-- | the same, disregard the event number
+onInputChoice_ :: (Typeable a, Eq a, Show a) => String -> [a] -> (a -> Exp ()) -> PlayerNumber -> Exp ()
+onInputChoice_ title choices handler pn = onEvent_ (inputChoiceHead pn title choices) (handler . inputChoiceData)
+
+-- | the same, suppress the event after first trigger
+onInputChoiceOnce :: (Typeable a, Eq a, Show a) => String -> [a] -> (a -> Exp ()) -> PlayerNumber -> Exp EventNumber
+onInputChoiceOnce title choices handler pn = onEventOnce (inputChoiceHead pn title choices) (handler . inputChoiceData)
+
+-- | the same, disregard the event number
+onInputChoiceOnce_ :: (Typeable a, Eq a, Show a) => String -> [a] -> (a -> Exp ()) -> PlayerNumber -> Exp ()
+onInputChoiceOnce_ title choices handler pn = onEventOnce_ (inputChoiceHead pn title choices) (handler . inputChoiceData)
+
+-- | triggers a choice input to the user, using an enumerate as input
+onInputChoiceEnum :: forall a. (Enum a, Bounded a, Typeable a, Eq a,  Show a) => String -> a -> (EventNumber -> a -> Exp ()) -> PlayerNumber -> Exp EventNumber
+onInputChoiceEnum title defaultChoice handler pn = onEvent (inputChoiceEnum pn title defaultChoice) (\(en, a) -> handler en (inputChoiceData a))
+
+-- | the same, disregard the event number
+onInputChoiceEnum_ :: forall a. (Enum a, Bounded a, Typeable a, Eq a,  Show a) => String -> a -> (a -> Exp ()) -> PlayerNumber -> Exp ()
+onInputChoiceEnum_ title defaultChoice handler pn = onEvent_ (inputChoiceEnum pn title defaultChoice) (handler . inputChoiceData)
+
+-- | the same, suppress the event after first trigger
+onInputChoiceEnumOnce_ :: forall a. (Enum a, Bounded a, Typeable a, Eq a,  Show a) => String -> a -> (a -> Exp ()) -> PlayerNumber -> Exp ()
+onInputChoiceEnumOnce_ title defaultChoice handler pn = onEventOnce_ (inputChoiceEnum pn title defaultChoice) (handler . inputChoiceData)
+
+
+-- | triggers a string input to the user. The result will be sent to the callback
+onInputString :: String -> (EventNumber -> String -> Exp ()) -> PlayerNumber -> Exp EventNumber
+onInputString title handler pn = onEvent (inputString pn title) (\(en, a) -> handler en (inputStringData a))
+
+-- | asks the player pn to answer a question, and feed the callback with this data.
+onInputString_ :: String -> (String -> Exp ()) -> PlayerNumber -> Exp ()
+onInputString_ title handler pn = onEvent_ (inputString pn title) (handler . inputStringData)
+
+-- | asks the player pn to answer a question, and feed the callback with this data.
+onInputStringOnce_ :: String -> (String -> Exp ()) -> PlayerNumber -> Exp ()
+onInputStringOnce_ title handler pn = onEventOnce_ (inputString pn title) (handler . inputStringData)
+++-- * Victory, players, output, time and self-number+
+-- | set victory to a list of players
+setVictory :: [PlayerNumber] -> Exp ()
+setVictory = SetVictory
+
+-- | give victory to one player
+giveVictory :: PlayerNumber -> Exp ()
+giveVictory pn = SetVictory [pn]+
+getPlayers :: Exp [PlayerInfo]
+getPlayers = GetPlayers
+
+-- | Get the total number of players
+getPlayersNumber :: Exp Int
+getPlayersNumber = getPlayers >>= return . length
+
+getAllPlayerNumbers :: Exp [PlayerNumber]
+getAllPlayerNumbers = do
+   ps <- getPlayers
+   return $ map playerNumber ps
++-- | 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+
+getCurrentTime :: Exp UTCTime
+getCurrentTime = CurrentTime
++-- | allows a rule to retrieve its self number (for auto-deleting for example)+getSelfRuleNumber :: Exp RuleNumber+getSelfRuleNumber = SelfRuleNumber+++
+-- * Rule samples
+
+-- | This rule will activate automatically any new rule.
+autoActivate :: RuleFunc
+autoActivate = VoidRule $ onEvent_ (RuleEv Proposed) (activateRule_ . rNumber . ruleData)
++immutableRule :: RuleNumber -> RuleFunc
+immutableRule rn = RuleRule f where
+   f r = do
+      protectedRule <- getRule rn
+      case protectedRule of
+         Just pr -> case rRuleFunc r of
+            RuleRule paramRule -> paramRule pr
+            otherwise -> return $ BoolResp True
+         Nothing -> return $ BoolResp True
+
+-- | A rule will be always legal
+legal :: RuleFunc
+legal = RuleRule $ \_ -> return $ BoolResp True
+
+-- | A rule will be always illegal
+illegal :: RuleFunc
+illegal = RuleRule $ \_ -> return $ BoolResp False+
+-- | This rule establishes a list of criteria rules that will be used to test any incoming rule
+-- the rules applyed shall give the answer immediatly
+simpleApplicationRule :: RuleFunc
+simpleApplicationRule = VoidRule $ do
+    v <- newVar_ "rules" ([]:: [RuleNumber])
+    onEvent_ (RuleEv Proposed) (h v) where
+        h v (RuleData rule) = do
+            (rns:: [RuleNumber]) <- readVar_ v
+            rs <- getRulesByNumbers rns
+            oks <- mapM (applyRule rule) rs
+            when (and oks) $ activateRule_ $ rNumber rule
+
+
+-- | active metarules are automatically used to evaluate a given rule
+autoMetarules :: Rule -> Exp RuleResponse
+autoMetarules r = do
+    rs <- getActiveRules
+    let rrs = mapMaybe f rs
+    evals <- mapM (\rr -> rr r) rrs
+    andrrs evals
+    where
+        f Rule {rRuleFunc = (RuleRule r)} = Just r
+        f _ = Nothing
+
+-- | any incoming rule will be activate if all active meta rules agrees
+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 ()
+
+applyRule :: Rule -> Rule -> Exp Bool
+applyRule (Rule {rRuleFunc = rf}) r = do
+    case rf of
+        RuleRule f1 -> f1 r >>= return . boolResp
+        otherwise -> return False
+
+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
+    pns <- getAllPlayerNumbers
+    let rn = show $ rNumber rule
+    let m = Message ("Unanimity for " ++ rn)
+    --create an array variable to store the votes. A message with the result of the vote is sent upon completion
+    voteVar <- newArrayVarOnce ("Votes for " ++ rn) pns (sendMessage m . f)
+    --create inputs to allow every player to vote and store the results in the array variable
+    let askPlayer pn = onInputChoiceOnce_ ("Vote for rule " ++ rn) [For, Against] (putArrayVar voteVar pn) pn
+    mapM_ askPlayer pns
+    return $ MsgResp m
+
+-- | assess the vote results according to a unanimity
+unanimity :: [(PlayerNumber, ForAgainst)] -> Bool
+unanimity l = ((length $ filter ((== Against) . snd) l) == 0)
+
+-- | assess the vote results according to a majority
+majority :: [(PlayerNumber, ForAgainst)] -> Bool
+majority l = ((length $ filter ((== For) . snd) l) >= length l)
+
+activateOrReject :: Rule -> Bool -> Exp ()
+activateOrReject r b = if b then activateRule_ (rNumber r) else rejectRule_ (rNumber r)
+
+-- | rule that performs a vote for a rule on all players. The provided function is used to count the votes,
+--it will be called when every players has voted or when the time limit is reached
+voteWithTimeLimit :: ([(PlayerNumber, ForAgainst)] -> Bool) -> UTCTime -> RuleFunc
+voteWithTimeLimit f t = RuleRule $ \rule -> do
+    pns <- getAllPlayerNumbers
+    let rn = show $ rNumber rule
+    let m = Message ("Unanimity for " ++ rn)
+    --create an array variable to store the votes. A message with the result of the vote is sent upon completion
+    voteVar <- newArrayVarOnce ("Votes for " ++ rn) pns (sendMessage m . f)
+    --create inputs to allow every player to vote and store the results in the array variable
+    let askPlayer pn = onInputChoiceOnce ("Vote for rule " ++ rn) [For, Against] (putArrayVar voteVar pn) pn
+    ics <- mapM askPlayer pns
+    --time limit
+    onEventOnce_ (Time t) $ \_ -> do
+        getArrayVarData' voteVar >>= sendMessage m . f
+        delArrayVar voteVar
+        mapM_ delEvent ics
+    return $ MsgResp m
+
+
+-- | create a value initialized for each players
+--manages players joining and leaving
+createValueForEachPlayer :: Int -> String -> Exp ()
+createValueForEachPlayer initialValue varName = 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
++-- | create and modify values for players+createValueForEachPlayer_ :: String -> 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))
+
+modifyAllValues :: String -> (Int -> Int) -> Exp ()
+modifyAllValues var f = modifyVar (V var::V [(Int, Int)]) $ map $ second f
+
+-- | Player p cannot propose anymore rules
+noPlayPlayer :: PlayerNumber -> RuleFunc
+noPlayPlayer p = RuleRule $ \r -> return $ BoolResp $ (rProposedBy r) /= p
++-- | a rule can autodelete itself (generaly after having performed some actions)
+autoDelete :: Exp ()+autoDelete = do+    s <- getSelfRuleNumber+    suppressRule_ s++
+-- | All rules from player p are erased:
+eraseAllRules :: PlayerNumber -> Exp Bool
+eraseAllRules p = do
+    rs <- getRules
+    let myrs = filter (\r ->  (rProposedBy r) == p) rs
+    res <- mapM (suppressRule . rNumber) myrs
+    return $ and res
++-- * 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 (a, Nothing) = Nothing
++
+--combine two rule responses
+andrr :: RuleResponse -> RuleResponse -> Exp RuleResponse
+andrr a@(BoolResp _) b@(MsgResp _) = andrr b a
+andrr (BoolResp a) (BoolResp b) = return $ BoolResp $ a && b
+andrr (MsgResp m1@(Message s1)) (MsgResp m2@(Message s2)) = do
+    let m = Message (s1 ++ " and " ++ s2)
+    v <- newArrayVarOnce (s1 ++ ", " ++ s2) [1::Integer, 2] (f m)
+    return (MsgResp m) where
+        f m ((_, a):(_, b):[]) = sendMessage m $ a && b
+andrr (MsgResp m1@(Message s1)) (BoolResp b2) = do
+    let m = Message (s1 ++ " and " ++ (show b2))
+    onMessageOnce m1 (f m)
+    return (MsgResp m) where
+        f m (MessageData b1) = sendMessage m $ b1 && b2
+
+andrrs :: [RuleResponse] -> Exp RuleResponse
+andrrs l = foldM andrr (BoolResp True) l
+
+--combine two rules
+(&&.) :: RuleFunc -> RuleFunc -> RuleFunc
+(VoidRule r1) &&. (VoidRule r2) =  VoidRule $ r1 >> r2
+rf1@(VoidRule _) &&. rf2@(RuleRule _) =  rf2 &&. rf1
+(RuleRule r1) &&. (VoidRule r2) =  RuleRule $ \a -> do
+    res <- r1 a
+    r2
+    return res
+(RuleRule r1) &&. (RuleRule r2) =  RuleRule $ \a -> do
+    res1 <- r1 a
+    res2 <- r2 a
+    res <- andrr res1 res2
+    return res
+_ &&. _ = error "rules impossible to combine"++-- | a default rule+defaultRule = Rule  {+    rNumber       = 1,+    rName         = "",+    rDescription  = "",+    rProposedBy   = 0,+    rRuleCode     = "",+    rRuleFunc     = VoidRule $ return (),+    rStatus       = Pending,+    rAssessedBy   = Nothing}

+ src/Paths_Nomyx_Rules.hs view

@@ -0,0 +1,32 @@+module Paths_Nomyx_Rules (+    version,+    getBinDir, getLibDir, getDataDir, getLibexecDir,+    getDataFileName+  ) where++import qualified Control.Exception as Exception+import Data.Version (Version(..))+import System.Environment (getEnv)+catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a+catchIO = Exception.catch+++version :: Version+version = Version {versionBranch = [0,0,1], versionTags = []}+bindir, libdir, datadir, libexecdir :: FilePath++bindir     = "/home/cdupont/.cabal/bin"+libdir     = "/home/cdupont/.cabal/lib/Nomyx-Rules-0.0.1/ghc-7.4.1"+datadir    = "/home/cdupont/.cabal/share/Nomyx-Rules-0.0.1"+libexecdir = "/home/cdupont/.cabal/libexec"++getBinDir, getLibDir, getDataDir, getLibexecDir :: IO FilePath+getBinDir = catchIO (getEnv "Nomyx_Rules_bindir") (\_ -> return bindir)+getLibDir = catchIO (getEnv "Nomyx_Rules_libdir") (\_ -> return libdir)+getDataDir = catchIO (getEnv "Nomyx_Rules_datadir") (\_ -> return datadir)+getLibexecDir = catchIO (getEnv "Nomyx_Rules_libexecdir") (\_ -> return libexecdir)++getDataFileName :: FilePath -> IO FilePath+getDataFileName name = do+  dir <- getDataDir+  return (dir ++ "/" ++ name)

+ tests/Test.hs view

@@ -0,0 +1,235 @@+{-# 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+-}++