diff --git a/AUTHORS b/AUTHORS new file mode 100644 --- /dev/null +++ b/AUTHORS @@ -0,0 +1,1 @@ +Corentin Dupont diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Nomyx-Rules.cabal b/Nomyx-Rules.cabal new file mode 100644 --- /dev/null +++ b/Nomyx-Rules.cabal @@ -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 + diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -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 diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,6 @@ +#!/usr/bin/runhaskell +> module Main where +> import Distribution.Simple +> main :: IO () +> main = defaultMain + diff --git a/examples/Examples.hs b/examples/Examples.hs new file mode 100644 --- /dev/null +++ b/examples/Examples.hs @@ -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 diff --git a/src/Language/Nomyx/Evaluation.hs b/src/Language/Nomyx/Evaluation.hs new file mode 100644 --- /dev/null +++ b/src/Language/Nomyx/Evaluation.hs @@ -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)) + diff --git a/src/Language/Nomyx/Expression.hs b/src/Language/Nomyx/Expression.hs new file mode 100644 --- /dev/null +++ b/src/Language/Nomyx/Expression.hs @@ -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 + + + diff --git a/src/Language/Nomyx/Rule.hs b/src/Language/Nomyx/Rule.hs new file mode 100644 --- /dev/null +++ b/src/Language/Nomyx/Rule.hs @@ -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} diff --git a/src/Paths_Nomyx_Rules.hs b/src/Paths_Nomyx_Rules.hs new file mode 100644 --- /dev/null +++ b/src/Paths_Nomyx_Rules.hs @@ -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) diff --git a/tests/Test.hs b/tests/Test.hs new file mode 100644 --- /dev/null +++ b/tests/Test.hs @@ -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 +-} + +