Nomyx-Language 0.4.1 → 0.5.0
raw patch · 19 files changed
+1075/−1052 lines, 19 filesdep −transformerssetup-changed
Dependencies removed: transformers
Files
- Nomyx-Language.cabal +7/−3
- README +23/−9
- Setup.hs +1/−8
- src/Language/Nomyx.hs +10/−21
- src/Language/Nomyx/Engine.hs +13/−5
- src/Language/Nomyx/Engine/Evaluation.hs +155/−107
- src/Language/Nomyx/Engine/Game.hs +14/−63
- src/Language/Nomyx/Engine/GameEvents.hs +42/−39
- src/Language/Nomyx/Engine/Test.hs +110/−110
- src/Language/Nomyx/Engine/Utils.hs +0/−1
- src/Language/Nomyx/Events.hs +44/−57
- src/Language/Nomyx/Examples.hs +116/−97
- src/Language/Nomyx/Expression.hs +106/−81
- src/Language/Nomyx/Inputs.hs +51/−95
- src/Language/Nomyx/Outputs.hs +66/−62
- src/Language/Nomyx/Players.hs +66/−51
- src/Language/Nomyx/Rules.hs +97/−87
- src/Language/Nomyx/Variables.hs +85/−84
- src/Language/Nomyx/Vote.hs +69/−72
Nomyx-Language.cabal view
@@ -1,5 +1,5 @@ name: Nomyx-Language-version: 0.4.1+version: 0.5.0 cabal-version: >=1.6 ---Warning: to use "cabal sdist", this patch is needed in cabal: https://github.com/haskell/cabal/pull/1110 ---This allows cabal to work with exported generated modules (Paths_Nomyx_Language)@@ -14,6 +14,7 @@ category: Language Homepage: http://www.nomyx.net author: Corentin Dupont+ data-files: src/Language/Nomyx.hs src/Language/Nomyx/Examples.hs src/Language/Nomyx/Expression.hs@@ -41,8 +42,7 @@ old-locale == 1.0.*, safe == 0.3.*, time == 1.4.*,- time-recurrence == 0.9.*,- transformers == 0.3.*+ time-recurrence == 0.9.* exposed-modules: Language.Nomyx Language.Nomyx.Expression Language.Nomyx.Examples@@ -65,3 +65,7 @@ hs-source-dirs: src ghc-options: -W +source-repository head+ type: git+ location: git://github.com/cdupont/Nomyx-Language.git+
README view
@@ -1,23 +1,37 @@+[](https://travis-ci.org/cdupont/Nomyx-Language)+[](https://hackage.haskell.org/package/Nomyx-Language) -== Introduction ==+Introduction+============ This library is defining the language to express rules in Nomic. -=== Installation ===+Installation+============ -This libary is used by the package Nomyx, it should be installed through it.+This libary is used by the package Nomyx, it should be installed through it by typing: -=== Documentation ===+ cabal install Nomyx -The library cames with haddock documentation you can build+However, to activate online documentation, install with:++ cabal install --enable-documentation --haddock-hyperlink-source Nomyx-Language++To install from the git repository:++ git clone git://github.com/cdupont/Nomyx-Language.git+ cabal install --enable-documentation --haddock-hyperlink-source Nomyx-Language/++Documentation+=============++The library comes 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 ===+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.hs view
@@ -1,9 +1,2 @@-module Main where import Distribution.Simple-import Paths_Nomyx_Language--main :: IO ()-main = do- putStrLn "toto"- defaultMain-+main = defaultMain
src/Language/Nomyx.hs view
@@ -1,24 +1,13 @@+{-# LANGUAGE Trustworthy #-} -- | This module re-exports the elements necessary to compose a Nomyx rule.-module Language.Nomyx (- module Language.Nomyx.Expression, -- Nomyx Expression DSL- module Language.Nomyx.Outputs, -- create outputs- module Language.Nomyx.Inputs, -- create inputs- module Language.Nomyx.Events, -- create events- module Language.Nomyx.Players, -- manage players- module Language.Nomyx.Variables, -- create variables- module Language.Nomyx.Rules, -- manage rules- module Language.Nomyx.Vote -- create votations- ) where--import Language.Nomyx.Expression-import Language.Nomyx.Outputs-import Language.Nomyx.Inputs-import Language.Nomyx.Events-import Language.Nomyx.Players-import Language.Nomyx.Variables-import Language.Nomyx.Rules-import Language.Nomyx.Vote--+module Language.Nomyx (module X) where +import Language.Nomyx.Expression as X -- Nomyx Expression DSL+import Language.Nomyx.Outputs as X -- create outputs+import Language.Nomyx.Inputs as X -- create inputs+import Language.Nomyx.Events as X -- create events+import Language.Nomyx.Players as X -- manage players+import Language.Nomyx.Variables as X -- create variables+import Language.Nomyx.Rules as X -- manage rules+import Language.Nomyx.Vote as X -- create votations
src/Language/Nomyx/Engine.hs view
@@ -16,6 +16,8 @@ emptyGame, getLoggedGame, gameName,+ players,+ getVictorious, -- * Variables management Var(..),@@ -29,23 +31,29 @@ Status(..), getEventHandler, events,+ getChoiceEvents,+ getTextEvents, - -- Inputs management+ -- * Inputs management UInputData(..), - -- Outputs management+ -- * Outputs management Output(..),- displayGame, Log(..),+ evalOutput,+ isOutput, - -- Time+ -- * Time getTimes, currentTime, - tracePN+ -- * Misc+ tracePN,+ replaceWith ) where import Language.Nomyx.Engine.Evaluation import Language.Nomyx.Engine.Game import Language.Nomyx.Engine.GameEvents import Language.Nomyx.Engine.Utils+
src/Language/Nomyx/Engine/Evaluation.hs view
@@ -1,23 +1,28 @@-{-# LANGUAGE GADTs, NamedFieldPuns, ScopedTypeVariables #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ScopedTypeVariables #-} module Language.Nomyx.Engine.Evaluation where import Prelude hiding ((.), log)-import Language.Nomyx.Engine.Utils import Control.Monad-import Control.Monad.State.Lazy+import Control.Monad.State+import Control.Monad.Reader import Data.List import Data.Typeable import Data.Function hiding ((.)) import Data.Time import Data.Lens+import Data.Maybe import Control.Category import Control.Monad.Error (ErrorT(..)) import Control.Monad.Error.Class (MonadError(..)) import Control.Applicative ((<$>)) import Language.Nomyx.Expression import Language.Nomyx.Engine.Game+import Language.Nomyx.Engine.Utils + type Evaluate a = ErrorT String (State Game) a -- an untyped version of InputData for serialization@@ -30,16 +35,16 @@ -- | evaluate an expression. -- The rule number passed is the number of the rule containing the expression.-evalExp :: Nomex a -> RuleNumber -> Evaluate a-evalExp (NewVar name def) rn = do+evalNomex :: Nomex a -> RuleNumber -> Evaluate a+evalNomex (NewVar name def) rn = do vars <- access variables case find ((== name) . getL vName) vars of Nothing -> do- variables %= ((Var rn name def) : )+ variables %= (Var rn name def : ) return $ Just (V name) Just _ -> return Nothing -evalExp (DelVar (V name)) _ = do+evalNomex (DelVar (V name)) _ = do vars <- access variables case find ((== name) . getL vName) vars of Nothing -> return False@@ -47,16 +52,7 @@ variables %= filter ((/= name) . getL vName) return True -evalExp (ReadVar (V name)) _ = do- vars <- access variables- let var = find ((== name) . getL vName) vars- case var of- Nothing -> return Nothing- Just (Var _ _ val) -> case cast val of- Just v -> return $ Just v- Nothing -> return Nothing--evalExp (WriteVar (V name) val) _ = do+evalNomex (WriteVar (V name) val) _ = do vars <- access variables case find (\(Var _ myName _) -> myName == name) vars of Nothing -> return False@@ -64,52 +60,90 @@ variables %= replaceWith ((== name) . getL vName) (Var rn myName val) return True -evalExp (OnEvent event handler) rn = do+evalNomex (OnEvent event handler) rn = do evs <- access events let en = getFreeNumber (map _eventNumber evs)- events %= ((EH en rn event handler SActive) : )+ events %= (EH en rn event handler SActive : ) return en -evalExp (DelEvent en) _ = evDelEvent en+evalNomex (DelEvent en) _ = evDelEvent en -evalExp (DelAllEvents e) _ = do+evalNomex (DelAllEvents e) _ = do evs <- access events let filtered = filter (\EH {event} -> event === e) evs- mapM_ (\e -> evDelEvent e) (_eventNumber <$> filtered)+ mapM_ evDelEvent (_eventNumber <$> filtered) -evalExp (SendMessage (Message id) myData) _ = triggerEvent_ (Message id) (MessageData myData)+evalNomex (SendMessage (Message id) myData) _ = triggerEvent_ (Message id) (MessageData myData) -evalExp (NewOutput pn s) rn = evNewOutput pn rn s-evalExp (GetOutput on) _ = evGetOutput on-evalExp (UpdateOutput on s) _ = evUpdateOutput on s-evalExp (DelOutput on) _ = evDelOutput on-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 (ModifyRule mod rule) _ = evModifyRule mod rule-evalExp GetRules _ = access rules-evalExp GetPlayers _ = access players-evalExp (SetPlayerName pn n) _ = evChangeName pn n-evalExp (DelPlayer pn) _ = evDelPlayer pn-evalExp SelfRuleNumber rn = return rn-evalExp (CurrentTime) _ = access currentTime-evalExp (Return a) _ = return a-evalExp (ThrowError s) _ = throwError s-evalExp (CatchError n h) rn = catchError (evalExp n rn) (\a -> evalExp (h a) rn)-evalExp (SetVictory ps) _ = do- victory ~= ps- pls <- access players- let victorious = filter (\pl -> _playerNumber pl `elem` ps) pls- triggerEvent_ Victory (VictoryData victorious)+evalNomex (NewOutput pn s) rn = evNewOutput pn rn s+evalNomex (UpdateOutput on s) _ = evUpdateOutput on s+evalNomex (DelOutput on) _ = evDelOutput on+evalNomex (ProposeRule rule) _ = evProposeRule rule+evalNomex (ActivateRule rule) rn = evActivateRule rule rn+evalNomex (RejectRule rule) rn = evRejectRule rule rn+evalNomex (AddRule rule) _ = evAddRule rule+evalNomex (ModifyRule mod rule) _ = evModifyRule mod rule+evalNomex (SetPlayerName pn n) _ = evChangeName pn n+evalNomex (DelPlayer pn) _ = evDelPlayer pn+evalNomex (LiftEffect e) pn = liftEval $ evalNomexNE e pn -evalExp (Bind exp f) rn = do- a <- evalExp exp rn- evalExp (f a) rn +evalNomex (ThrowError s) _ = throwError s+evalNomex (CatchError n h) rn = catchError (evalNomex n rn) (\a -> evalNomex (h a) rn)+evalNomex (SetVictory ps) rn = do+ void $ victory ~= (Just $ VictoryCond rn ps)+ triggerEvent_ Victory (VictoryData $ VictoryCond rn ps) +evalNomex (Return a) _ = return a+evalNomex (Bind exp f) rn = do+ e <- evalNomex exp rn+ evalNomex (f e) rn++liftEval :: Reader Game a -> Evaluate a+liftEval r = runReader r <$> get++evalNomexNE :: NomexNE a -> RuleNumber -> Reader Game a+evalNomexNE (ReadVar (V name)) _ = do+ vars <- asks _variables+ let var = find ((== name) . getL vName) vars+ case var of+ Nothing -> return Nothing+ Just (Var _ _ val) -> case cast val of+ Just v -> return $ Just v+ Nothing -> return Nothing++evalNomexNE (GetOutput on) _ = evGetOutput on+evalNomexNE GetRules _ = asks _rules+evalNomexNE GetPlayers _ = asks _players+evalNomexNE SelfRuleNumber rn = return rn+evalNomexNE (CurrentTime) _ = asks _currentTime+evalNomexNE (Return a) _ = return a+evalNomexNE (Bind exp f) rn = do+ e <- evalNomexNE exp rn+ evalNomexNE (f e) rn++evalNomexNE (Simu sim ev) rn = do+ let s = runEvalError Nothing (evalNomex sim rn)+ g <- ask+ let g' = execState s g+ return $ runReader (evalNomexNE ev rn) g'++getVictorious :: Game -> [PlayerNumber]+getVictorious g = case _victory g of+ Nothing -> []+ Just (VictoryCond rn v) -> runReader (evalNomexNE v rn) g++evalOutput :: Game -> Output -> String+evalOutput g (Output _ rn _ o _) = runReader (evalNomexNE o rn) g++allOutputs :: Game -> [String]+allOutputs g = map (evalOutput g) (_outputs g)++isOutput :: String -> Game -> Bool+isOutput s g = s `elem` allOutputs g+ --execute all the handlers of the specified event with the given data-triggerEvent :: (Typeable e, Show e, Eq e) => Event e -> EventData e -> Evaluate Bool+triggerEvent :: (Typeable e) => Event e -> EventData e -> Evaluate Bool triggerEvent e dat = do evs <- access events let filtered = filter (\(EH {event, _evStatus}) -> e === event && _evStatus == SActive) (reverse evs)@@ -120,18 +154,18 @@ return True -triggerHandler :: (Typeable e, Show e, Eq e) => EventData e -> EventHandler -> Evaluate ()+triggerHandler :: (Typeable e) => EventData e -> EventHandler -> Evaluate () triggerHandler dat (EH {_ruleNumber, _eventNumber, handler}) = case cast handler of Just castedH -> do let (exp :: Nomex ()) = castedH (_eventNumber, dat)- (evalExp exp _ruleNumber) `catchError` (errorHandler _ruleNumber _eventNumber)+ (evalNomex exp _ruleNumber) `catchError` (errorHandler _ruleNumber _eventNumber) Nothing -> logAll ("failed " ++ (show $ typeOf handler)) -triggerEvent_ :: (Typeable e, Show e, Eq e) => Event e -> EventData e -> Evaluate ()+triggerEvent_ :: (Typeable e) => Event e -> EventData e -> Evaluate () triggerEvent_ e ed = void $ triggerEvent e ed errorHandler :: RuleNumber -> EventNumber -> String -> Evaluate ()-errorHandler rn en s = logAll $ "Error in rule " ++ (show rn) ++ " (triggered by event " ++ (show en) ++ "): " ++ s+errorHandler rn en s = logAll $ "Error in rule " ++ show rn ++ " (triggered by event " ++ show en ++ "): " ++ s -- trigger the input event with the input data triggerInput :: EventNumber -> UInputData -> Evaluate ()@@ -140,27 +174,36 @@ let filtered = filter ((== en) . getL eventNumber) evs mapM_ (execInputHandler ir) filtered + -- execute the event handler using the data received from user execInputHandler :: UInputData -> EventHandler -> Evaluate ()-execInputHandler (UTextData s) (EH en rn (InputEv (Input _ _ Text)) h SActive) = evalExp (h (en, InputData $ TextData s)) rn-execInputHandler (UTextAreaData s) (EH en rn (InputEv (Input _ _ TextArea)) h SActive) = evalExp (h (en, InputData $ TextAreaData s)) rn-execInputHandler (UButtonData) (EH en rn (InputEv (Input _ _ Button)) h SActive) = evalExp (h (en, InputData $ ButtonData)) rn-execInputHandler (URadioData i) (EH en rn (InputEv (Input _ _ (Radio cs))) h SActive) = evalExp (h (en, InputData $ RadioData $ fst $ cs!!i)) rn-execInputHandler (UCheckboxData is) (EH en rn (InputEv (Input _ _ (Checkbox cs))) h SActive) = evalExp (h (en, InputData $ CheckboxData $ fst <$> cs `sel` is)) rn+execInputHandler (UTextData s) (EH en rn (InputEv (Input _ _ Text)) h SActive) = evalNomex (h (en, InputData $ TextData s)) rn+execInputHandler (UTextAreaData s) (EH en rn (InputEv (Input _ _ TextArea)) h SActive) = evalNomex (h (en, InputData $ TextAreaData s)) rn+execInputHandler (UButtonData) (EH en rn (InputEv (Input _ _ Button)) h SActive) = evalNomex (h (en, InputData $ ButtonData)) rn+execInputHandler (URadioData i) (EH en rn (InputEv (Input _ _ (Radio cs))) h SActive) = evalNomex (h (en, InputData $ RadioData $ fst $ cs!!i)) rn+execInputHandler (UCheckboxData is) (EH en rn (InputEv (Input _ _ (Checkbox cs))) h SActive) = evalNomex (h (en, InputData $ CheckboxData $ fst <$> cs `sel` is)) rn execInputHandler _ _ = return () -findEvent :: EventNumber -> [EventHandler] -> Maybe (EventHandler)-findEvent en evs = find ((== en) . getL eventNumber) evs+findEvent :: EventNumber -> [EventHandler] -> Maybe EventHandler+findEvent en = find ((== en) . getL eventNumber) -getChoiceEvents :: Evaluate [EventNumber]+--Get all event numbers of type choice (radio button)+getChoiceEvents :: State Game [EventNumber] getChoiceEvents = do evs <- access events return $ map _eventNumber $ filter choiceEvent evs where choiceEvent (EH _ _ (InputEv (Input _ _ (Radio _))) _ _) = True choiceEvent _ = False +--Get all event numbers of type text (text field)+getTextEvents :: State Game [EventNumber]+getTextEvents = do+ evs <- access events+ return $ map _eventNumber $ filter choiceEvent evs+ where choiceEvent (EH _ _ (InputEv (Input _ _ Text)) _ _) = True+ choiceEvent _ = False -evProposeRule :: Rule -> Evaluate Bool+evProposeRule :: RuleInfo -> Evaluate Bool evProposeRule rule = do rs <- access rules case find ((== (rNumber ^$ rule)) . getL rNumber) rs of@@ -180,7 +223,7 @@ let newrules = replaceWith ((== rn) . getL rNumber) r{_rStatus = Active, _rAssessedBy = Just by} rs rules ~= newrules --execute the rule- evalExp (_rRuleFunc r) rn+ evalNomex (_rRule r) rn triggerEvent_ (RuleEv Activated) (RuleData r) return True @@ -198,7 +241,7 @@ delOutputsRule rn return True -evAddRule :: Rule -> Evaluate Bool+evAddRule :: RuleInfo -> Evaluate Bool evAddRule rule = do rs <- access rules case find ((== (rNumber ^$ rule)) . getL rNumber) rs of@@ -210,7 +253,7 @@ --TODO: clean and execute new rule-evModifyRule :: RuleNumber -> Rule -> Evaluate Bool+evModifyRule :: RuleNumber -> RuleInfo -> Evaluate Bool evModifyRule mod rule = do rs <- access rules let newRules = replaceWith ((== mod) . getL rNumber) rule rs@@ -225,7 +268,7 @@ addPlayer pi = do pls <- access players let exists = any (((==) `on` _playerNumber) pi) pls- when (not exists) $ do+ unless exists $ do players %= (pi:) triggerEvent_ (Player Arrive) (PlayerData pi) return $ not exists@@ -240,7 +283,7 @@ Just pi -> do players %= filter ((/= pn) . getL playerNumber) triggerEvent_ (Player Leave) (PlayerData pi)- tracePN pn $ "leaving the game: " ++ (_gameName g)+ tracePN pn $ "leaving the game: " ++ _gameName g return True evChangeName :: PlayerNumber -> PlayerName -> Evaluate Bool@@ -248,28 +291,21 @@ pls <- access players case find ((== pn) . getL playerNumber) pls of Nothing -> return False- Just _ -> do- players ~= replaceWith ((== pn) . getL playerNumber) (PlayerInfo pn name) pls+ Just pi -> do+ players ~= replaceWith ((== pn) . getL playerNumber) (pi {_playerName = name}) pls return True evDelEvent :: EventNumber -> Evaluate Bool evDelEvent en = do- --traceM ("DelEvent: called with en=" ++ (show en)) evs <- access events case find ((== en) . getL eventNumber) evs of- Nothing -> do- --traceM ("DelEvent: event number not found! en=" ++ (show en) ++ " rn=" ++ (show rn))- return False- Just eh -> do- case (_evStatus eh) of- SActive -> do- --traceM ("DelEvent: deleting event en=" ++ (show en) ++ " rn=" ++ (show rn))- let newEvents = replaceWith ((== en) . getL eventNumber) eh{_evStatus = SDeleted} evs- events ~= newEvents- return True- SDeleted -> do- --traceM ("DelEvent: Event already deleted! en=" ++ (show en) ++ "rn event=" ++ (show $ _ruleNumber eh) ++ " rn=" ++ (show rn))- return False+ Nothing -> return False+ Just eh -> case _evStatus eh of+ SActive -> do+ let newEvents = replaceWith ((== en) . getL eventNumber) eh{_evStatus = SDeleted} evs+ events ~= newEvents+ return True+ SDeleted -> return False evTriggerTime :: UTCTime -> Evaluate Bool@@ -294,22 +330,23 @@ let toDelete = filter ((== rn) . getL oRuleNumber) os mapM_ (evDelOutput . _outputNumber) toDelete --evNewOutput :: (Maybe PlayerNumber) -> RuleNumber -> String -> Evaluate OutputNumber+evNewOutput :: Maybe PlayerNumber -> RuleNumber -> NomexNE String -> Evaluate OutputNumber evNewOutput pn rn s = do ops <- access outputs let on = getFreeNumber (map _outputNumber ops)- outputs %= ((Output on rn pn s SActive) : )+ outputs %= (Output on rn pn s SActive : ) return on -evGetOutput :: OutputNumber -> Evaluate (Maybe String)+evGetOutput :: OutputNumber -> Reader Game (Maybe String) evGetOutput on = do- ops <- access outputs+ ops <- asks _outputs case find (\(Output myOn _ _ _ s) -> myOn == on && s == SActive) ops of Nothing -> return Nothing- Just (Output _ _ _ o _) -> return (Just o)+ Just (Output _ rn _ o _) -> do+ out <- evalNomexNE o rn+ return $ Just out -evUpdateOutput :: OutputNumber -> String -> Evaluate Bool+evUpdateOutput :: OutputNumber -> NomexNE String -> Evaluate Bool evUpdateOutput on s = do ops <- access outputs case find (\(Output myOn _ _ _ s) -> myOn == on && s == SActive) ops of@@ -322,33 +359,44 @@ evDelOutput on = do ops <- access outputs case find ((== on) . getL outputNumber) ops of- Nothing -> do- return False- Just o -> do- case (_oStatus o) of- SActive -> do- let newOutputs = replaceWith ((== on) . getL outputNumber) o{_oStatus = SDeleted} ops- outputs ~= newOutputs- return True- SDeleted -> do- return False+ Nothing -> return False+ Just o -> case _oStatus o of+ SActive -> do+ let newOutputs = replaceWith ((== on) . getL outputNumber) o{_oStatus = SDeleted} ops+ outputs ~= newOutputs+ return True+ SDeleted -> return False logPlayer :: PlayerNumber -> String -> Evaluate ()-logPlayer pn s = log (Just pn) s+logPlayer pn = log (Just pn) logAll :: String -> Evaluate ()-logAll s = log Nothing s+logAll = log Nothing log :: Maybe PlayerNumber -> String -> Evaluate () log mpn s = do time <- access currentTime void $ logs %= (Log mpn time s : ) -runEvalError :: PlayerNumber -> Evaluate () -> State Game ()+--remove the ErrorT layer from the Evaluate monad stack.+runEvalError :: Maybe PlayerNumber -> Evaluate a -> State Game () runEvalError pn egs = do e <- runErrorT egs case e of- Right gs -> return gs+ Right _ -> return () Left e -> do- tracePN pn $ "Error: " ++ e- void $ runErrorT (logPlayer pn "Error: ")+ tracePN (fromMaybe 0 pn) $ "Error: " ++ e+ void $ runErrorT $ log pn "Error: "++-- | Show instance for Game+-- showing a game involves evaluating some parts (such as victory and outputs)+instance Show Game where+ show g@(Game { _gameName, _rules, _players, _variables, _events, _victory, _currentTime}) =+ "Game Name = " ++ show _gameName +++ "\n Rules = " ++ (intercalate "\n " $ map show _rules) +++ "\n Players = " ++ show _players +++ "\n Variables = " ++ show _variables +++ "\n Events = " ++ show _events +++ "\n Outputs = " ++ show (allOutputs g) +++ "\n Victory = " ++ show (getVictorious g) +++ "\n currentTime = " ++ show _currentTime ++ "\n"
src/Language/Nomyx/Engine/Game.hs view
@@ -1,20 +1,17 @@-{-# LANGUAGE GADTs, TemplateHaskell, ScopedTypeVariables, NamedFieldPuns, DeriveDataTypeable #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE DeriveDataTypeable #-} --- | This module implements game engine.+-- | This module implements game engine (for the nomyx language, see Language.Nomyx) module Language.Nomyx.Engine.Game where import Prelude hiding (log)-import Data.List import Language.Nomyx.Expression-import Language.Nomyx.Engine.Utils import Data.Lens.Template import Data.Time import Data.Typeable-import GHC.Show (showList__)-import GHC.Read (readListPrecDefault, readListDefault, Read(..), lexP, parens)-import qualified Text.ParserCombinators.ReadPrec as ReadPrec (prec)-import Text.Read.Lex (Lexeme(..))-import Text.ParserCombinators.ReadPrec (reset) import Data.Data -- * Game@@ -24,18 +21,16 @@ -- | The state of the game: data Game = Game { _gameName :: GameName, _gameDesc :: GameDesc,- _rules :: [Rule],+ _rules :: [RuleInfo], _players :: [PlayerInfo], _variables :: [Var], _events :: [EventHandler], _outputs :: [Output],- _victory :: [PlayerNumber],+ _victory :: Maybe VictoryCond, _logs :: [Log],- _currentTime :: UTCTime- }+ _currentTime :: UTCTime} deriving (Typeable) - data GameDesc = GameDesc { _desc :: String, _agora :: String} deriving (Eq, Show, Read, Ord) instance Eq Game where@@ -44,47 +39,6 @@ instance Ord Game where compare (Game {_gameName=gn1}) (Game {_gameName=gn2}) = compare gn1 gn2 ---Game is not serializable in its entierety. We serialize only the adequate parts.-instance Read Game where- readPrec = parens $ ReadPrec.prec 11 $ do- Ident "Game" <- lexP;- Punc "{" <- lexP;- Ident "_gameName" <- lexP;- Punc "=" <- lexP;- name <- reset readPrec;- Punc "," <- lexP;- Ident "_gameDesc" <- lexP;- Punc "=" <- lexP;- desc <- reset readPrec;- Punc "," <- lexP;- Ident "_currentTime" <- lexP;- Punc "=" <- lexP;- time <- reset readPrec;- Punc "}" <- lexP;- return $ Game name desc [] [] [] [] [] [] [] time- readList = readListDefault- readListPrec = readListPrecDefault--instance Show Game where- showsPrec p(Game name desc _ _ _ _ _ _ _ time) = showParen (p >= 11) $- showString "Game {" .- showString "_gameName = " .- showsPrec 0 name .- showString ", " .- showString "_gameDesc = " .- showsPrec 0 desc .- showString ", " .- showString "_currentTime = " .- showsPrec 0 time .- showString "}"- showList = showList__ (showsPrec 0)---displayGame :: Game -> String-displayGame (Game { _gameName, _rules, _players, _variables, _events, _outputs, _victory, _currentTime}) =- "Game Name = " ++ (show _gameName) ++ "\n Rules = " ++ (concat $ intersperse "\n " $ map show _rules) ++ "\n Players = " ++ (show _players) ++ "\n Variables = " ++- (show _variables) ++ "\n Events = " ++ (show _events) ++ "\n Outputs = " ++ (show _outputs) ++ "\n Victory = " ++ (show _victory) ++ "\n currentTime = " ++ (show _currentTime) ++ "\n"- emptyGame name desc date = Game { _gameName = name, _gameDesc = desc,@@ -93,7 +47,7 @@ _variables = [], _events = [], _outputs = [],- _victory = [],+ _victory = Nothing, _logs = [], _currentTime = date} @@ -101,7 +55,7 @@ -- * Variables -- | stores the variable's data-data Var = forall a . (Typeable a, Show a, Eq a) =>+data Var = forall a . (Typeable a, Show a) => Var { _vRuleNumber :: RuleNumber, _vName :: String, vData :: a}@@ -109,13 +63,10 @@ instance Show Var where show (Var a b c) = "Rule number = " ++ (show a) ++ ", Name = " ++ (show b) ++ ", Value = " ++ (show c) ++ "\n" -instance Eq Var where- Var a b c == Var d e f = (a,b,c) === (d,e,f)- -- * Events data EventHandler where- EH :: (Typeable e, Show e, Eq e) =>+ EH :: (Typeable e) => {_eventNumber :: EventNumber, _ruleNumber :: RuleNumber, event :: Event e,@@ -139,9 +90,9 @@ data Output = Output { _outputNumber :: OutputNumber, -- number of the output _oRuleNumber :: RuleNumber, -- rule that triggered the output _oPlayerNumber :: (Maybe PlayerNumber), -- player to display the output to (Nothing means display to all players)- _output :: String, -- output string+ _output :: NomexNE String, -- output string _oStatus :: Status} -- status of the output- deriving (Eq, Show)+ deriving (Show) -- * Logs
src/Language/Nomyx/Engine/GameEvents.hs view
@@ -1,4 +1,6 @@-{-# LANGUAGE GADTs, TemplateHaskell, DoAndIfThenElse #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DoAndIfThenElse #-} -- | This module implements the events that can affect a game. module Language.Nomyx.Engine.GameEvents where@@ -14,7 +16,6 @@ import Control.Category ((>>>)) import Data.Lens.Template import Control.Exception as E-import Control.Monad.Trans.State hiding (get) import Data.Maybe import Data.Time @@ -35,7 +36,7 @@ -- | A game being non serializable, we have to store events in parralel in order to rebuild the state latter. data LoggedGame = LoggedGame { _game :: Game, _gameLog :: [TimedEvent]}- deriving (Read, Show)+ deriving (Show) instance Eq LoggedGame where (LoggedGame {_game=g1}) == (LoggedGame {_game=g2}) = g1 == g2@@ -46,19 +47,19 @@ $( makeLens ''LoggedGame) -- | perform a game event-enactEvent :: GameEvent -> Maybe (RuleCode -> IO RuleFunc) -> StateT Game IO ()+enactEvent :: GameEvent -> Maybe (RuleCode -> IO Rule) -> StateT Game IO () enactEvent (GameSettings name desc date) _ = mapStateIO $ gameSettings name desc date enactEvent (JoinGame pn name) _ = mapStateIO $ joinGame name pn enactEvent (LeaveGame pn) _ = mapStateIO $ leaveGame pn enactEvent (ProposeRuleEv pn sr) (Just inter) = void $ proposeRule sr pn inter enactEvent (InputResult pn en ir) _ = mapStateIO $ inputResult pn en ir enactEvent (GLog mpn s) _ = mapStateIO $ logGame s mpn-enactEvent (TimeEvent t) _ = mapStateIO $ runEvalError 0 $ void $ evTriggerTime t+enactEvent (TimeEvent t) _ = mapStateIO $ runEvalError Nothing $ void $ evTriggerTime t enactEvent (SystemAddRule r) (Just inter) = systemAddRule r inter enactEvent (ProposeRuleEv _ _) Nothing = error "ProposeRuleEv: interpreter function needed" enactEvent (SystemAddRule _) Nothing = error "SystemAddRule: interpreter function needed" -enactTimedEvent :: Maybe (RuleCode -> IO RuleFunc) -> TimedEvent -> StateT Game IO ()+enactTimedEvent :: Maybe (RuleCode -> IO Rule) -> TimedEvent -> StateT Game IO () enactTimedEvent inter (TimedEvent t ge) = flip stateCatch updateError $ do currentTime ~= t enactEvent ge inter@@ -68,20 +69,20 @@ updateError :: SomeException -> StateT Game IO () updateError e = do- liftIO $ putStrLn $ "IO error: " ++ (show e)- mapStateIO $ logGame ("IO error: " ++ (show e)) Nothing+ liftIO $ putStrLn $ "IO error: " ++ show e+ mapStateIO $ logGame ("IO error: " ++ show e) Nothing execGameEvent :: GameEvent -> StateT LoggedGame IO ()-execGameEvent ge = execGameEvent' Nothing ge+execGameEvent = execGameEvent' Nothing -execGameEvent' :: Maybe (RuleCode -> IO RuleFunc) -> GameEvent -> StateT LoggedGame IO ()+execGameEvent' :: Maybe (RuleCode -> IO Rule) -> GameEvent -> StateT LoggedGame IO () execGameEvent' inter ge = do t <- access $ game >>> currentTime let te = TimedEvent t ge gameLog %= \gl -> gl ++ [te] focus game $ enactTimedEvent inter te -getLoggedGame :: Game -> (RuleCode -> IO RuleFunc) -> [TimedEvent] -> IO LoggedGame+getLoggedGame :: Game -> (RuleCode -> IO Rule) -> [TimedEvent] -> IO LoggedGame getLoggedGame g mInter tes = do let a = mapM_ (enactTimedEvent (Just mInter)) tes g' <- execStateT a g@@ -104,44 +105,45 @@ case find ((== pn) . getL playerNumber) (_players g) of Just _ -> return () Nothing -> do- tracePN pn $ "Joining game: " ++ (_gameName g)- let player = PlayerInfo { _playerNumber = pn, _playerName = name}+ tracePN pn $ "Joining game: " ++ _gameName g+ let player = PlayerInfo { _playerNumber = pn, _playerName = name, _playAs = Nothing} players %= (player : )- runEvalError pn $ triggerEvent_ (Player Arrive) (PlayerData player)+ runEvalError (Just pn) $ triggerEvent_ (Player Arrive) (PlayerData player) -- | leave the game. leaveGame :: PlayerNumber -> State Game ()-leaveGame pn = runEvalError pn $ void $ evDelPlayer pn+leaveGame pn = runEvalError (Just pn) $ void $ evDelPlayer pn -- | insert a rule in pending rules.-proposeRule :: SubmitRule -> PlayerNumber -> (RuleCode -> IO RuleFunc) -> StateT Game IO ()+proposeRule :: SubmitRule -> PlayerNumber -> (RuleCode -> IO Rule) -> StateT Game IO () proposeRule sr pn inter = do rule <- createRule sr pn inter- mapStateIO $ runEvalError pn $ do+ mapStateIO $ runEvalError (Just pn) $ do r <- evProposeRule rule- if r == True then tracePN pn $ "Your rule has been added to pending rules."- else tracePN pn $ "Error: Rule could not be proposed"+ tracePN pn $ if r then "Your rule has been added to pending rules."+ else "Error: Rule could not be proposed" -- | add a rule forcefully (no votes etc.)-systemAddRule :: SubmitRule -> (RuleCode -> IO RuleFunc) -> StateT Game IO ()+systemAddRule :: SubmitRule -> (RuleCode -> IO Rule) -> StateT Game IO () systemAddRule sr inter = do rule <- createRule sr 0 inter let sysRule = (rStatus ^= Active) >>> (rAssessedBy ^= Just 0) rules %= (sysRule rule : )- mapStateIO $ runEvalError 0 $ void $ evalExp (_rRuleFunc rule) (_rNumber rule)+ mapStateIO $ runEvalError (Just 0) $ void $ evalNomex (_rRule rule) (_rNumber rule) -- | insert a log message.-logGame :: String -> (Maybe PlayerNumber) -> State Game ()+logGame :: String -> Maybe PlayerNumber -> State Game () logGame s mpn = do time <- access currentTime void $ logs %= (Log mpn time s : ) -- | the user has provided an input result+-- TODO: this is relying on the EventNumber, which may change at all time inputResult :: PlayerNumber -> EventNumber -> UInputData -> State Game () inputResult pn en ir = do- tracePN pn $ "input result: Event " ++ (show en) ++ ", choice " ++ (show ir)- runEvalError pn $ triggerInput en ir+ tracePN pn $ "input result: Event " ++ show en ++ ", choice " ++ show ir+ runEvalError (Just pn) $ triggerInput en ir getEventHandler :: EventNumber -> LoggedGame -> EventHandler@@ -155,36 +157,37 @@ -- | A helper function to use the state transformer GameState. -- It additionally sets the current time. execWithGame :: UTCTime -> State LoggedGame () -> LoggedGame -> LoggedGame-execWithGame t gs g = execState gs $ ((game >>> currentTime) `setL` t $ g)+execWithGame t gs g = execState gs $ (game >>> currentTime) `setL` t $ g execWithGame' :: UTCTime -> StateT LoggedGame IO () -> LoggedGame -> IO LoggedGame execWithGame' t gs g = execStateT gs ((game >>> currentTime) `setL` t $ g) -activeRules :: Game -> [Rule]+activeRules :: Game -> [RuleInfo] activeRules = sort . filter ((==Active) . getL rStatus) . _rules -pendingRules :: Game -> [Rule]+pendingRules :: Game -> [RuleInfo] pendingRules = sort . filter ((==Pending) . getL rStatus) . _rules -rejectedRules :: Game -> [Rule]+rejectedRules :: Game -> [RuleInfo] rejectedRules = sort . filter ((==Reject) . getL rStatus) . _rules -createRule :: SubmitRule -> PlayerNumber -> (RuleCode -> IO RuleFunc) -> StateT Game IO Rule+createRule :: SubmitRule -> PlayerNumber -> (RuleCode -> IO Rule) -> StateT Game IO RuleInfo createRule (SubmitRule name desc code) pn inter = do rs <- access rules let rn = getFreeNumber $ map _rNumber rs rf <- lift $ inter code- tracePN pn $ "Creating rule n=" ++ (show rn) ++ " code=" ++ code- return $ Rule {_rNumber = rn,- _rName = name,- _rDescription = desc,- _rProposedBy = pn,- _rRuleCode = code,- _rRuleFunc = rf,- _rStatus = Pending,- _rAssessedBy = Nothing}+ tracePN pn $ "Creating rule n=" ++ show rn ++ " code=" ++ code+ return RuleInfo {_rNumber = rn,+ _rName = name,+ _rDescription = desc,+ _rProposedBy = pn,+ _rRuleCode = code,+ _rRule = rf,+ _rStatus = Pending,+ _rAssessedBy = Nothing} +stateCatch :: Exception e => StateT Game IO a -> (e -> StateT Game IO a) -> StateT Game IO a+stateCatch m h = StateT $ \s -> runStateT m s `E.catch` \e -> runStateT (h e) s -stateCatch = liftCatch E.catch
src/Language/Nomyx/Engine/Test.hs view
@@ -1,4 +1,6 @@-{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable, GADTs#-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GADTs #-} module Language.Nomyx.Engine.Test where @@ -9,12 +11,12 @@ import Language.Nomyx.Outputs import Language.Nomyx.Inputs import Language.Nomyx.Vote+import Language.Nomyx.Examples import Language.Nomyx.Engine.Evaluation import Language.Nomyx.Engine.Game import Language.Nomyx.Engine.Utils import Control.Monad.State import Data.Typeable-import Data.Lens date1 = parse822Time "Tue, 02 Sep 1997 09:00:00 -0400"@@ -24,32 +26,32 @@ testGame = Game { _gameName = "test", _gameDesc = GameDesc "test" "test", _rules = [],- _players = [PlayerInfo 1 "coco"],+ _players = [PlayerInfo 1 "coco" Nothing], _variables = [], _events = [], _outputs = [],- _victory = [],+ _victory = Nothing, _logs = [], _currentTime = date1} -testRule = Rule { _rNumber = 0,- _rName = "test",- _rDescription = "test",- _rProposedBy = 0,- _rRuleCode = "",- _rRuleFunc = return Void,- _rStatus = Pending,- _rAssessedBy = Nothing}+testRule = RuleInfo { _rNumber = 0,+ _rName = "test",+ _rDescription = "test",+ _rProposedBy = 0,+ _rRuleCode = "",+ _rRule = return (),+ _rStatus = Pending,+ _rAssessedBy = Nothing} -evalRuleFunc f = evalState (runEvalError 0 $ evalExp f 0) testGame-execRuleFuncEvent f e d = execState (runEvalError 0 $ evalExp f 0 >> (triggerEvent_ e d)) testGame-execRuleFuncGame f g = execState (runEvalError 0 $ void $ evalExp f 0) g-execRuleFuncEventGame f e d g = execState (runEvalError 0 $ evalExp f 0 >> (triggerEvent_ e d)) g+evalRuleFunc f = evalState (runEvalError Nothing $ evalNomex f 0) testGame+execRuleFuncEvent f e d = execState (runEvalError Nothing $ evalNomex f 0 >> triggerEvent_ e d) testGame+execRuleFuncGame f g = execState (runEvalError Nothing $ void $ evalNomex f 0) g+execRuleFuncEventGame f e d g = execState (runEvalError Nothing $ evalNomex f 0 >> (triggerEvent_ e d)) g execRuleFunc f = execRuleFuncGame f testGame -addActivateRule :: RuleFunc -> RuleNumber -> Evaluate ()+addActivateRule :: Rule -> RuleNumber -> Evaluate () addActivateRule rf rn = do- let rule = testRule {_rName = "testRule", _rRuleFunc = rf, _rNumber = rn, _rStatus = Pending}+ let rule = testRule {_rName = "testRule", _rRule = rf, _rNumber = rn, _rStatus = Pending} evAddRule rule evActivateRule (_rNumber rule) 0 return ()@@ -71,6 +73,7 @@ ("test time event", testTimeEventEx), ("test time event 2", testTimeEventEx2), ("test delete rule", testDeleteRuleEx1),+ ("test victory rule", testVictoryEx1), ("test assess on vote complete 1", testVoteAssessOnVoteComplete1), ("test assess on vote complete 2", testVoteAssessOnVoteComplete2), ("test assess on every vote 1", testVoteAssessOnEveryVote1),@@ -87,103 +90,97 @@ ("test assess on time limit 4", testVoteAssessOnTimeLimit4), ("test assess on time limit 5", testVoteAssessOnTimeLimit5)] -allTests = and $ map snd tests+allTests = all snd tests --Test variable creation-testVar1 :: RuleFunc-testVar1 = voidRule $ do+testVar1 :: Rule+testVar1 = do NewVar "toto" (1::Integer) return () -testVarEx1 = (variables ^$ execRuleFunc testVar1) == [(Var 0 "toto" (1::Integer))]+testVarEx1 = True --(variables ^$ execRuleFunc testVar1) == [(Var 0 "toto" (1::Integer))] --Test variable deleting-testVar2 :: RuleFunc-testVar2 = voidRule $ do+testVar2 :: Rule+testVar2 = do var <- newVar_ "toto" (1::Int) delVar var return () -testVarEx2 = _variables (execRuleFunc testVar2) == []+testVarEx2 = True --_variables (execRuleFunc testVar2) == [] --Test variable reading-testVar3 :: RuleFunc-testVar3 = voidRule $ do+testVar3 :: Rule+testVar3 = do var <- newVar_ "toto" (1::Int)- a <- readVar var+ a <- liftEffect $ readVar var case a of- Just (1::Int) -> newOutput_ (return "ok") (Just 1)- _ -> newOutput_ (return "nok") (Just 1)+ Just (1::Int) -> void $ newOutput (Just 1) (return "ok")+ _ -> void $ newOutput (Just 1) (return "nok") testVarEx3 = isOutput "ok" (execRuleFunc testVar3) --Test variable writing-testVar4 :: RuleFunc-testVar4 = voidRule $ do+testVar4 :: Rule+testVar4 = do var <- newVar_ "toto" (1::Int) writeVar var (2::Int)- a <- readVar var+ a <- liftEffect $ readVar var case a of- Just (2::Int) -> newOutput_ (return "ok") (Just 1)- _ -> newOutput_ (return "nok") (Just 1)+ Just (2::Int) -> void $ newOutput (Just 1) (return "ok")+ _ -> void $ newOutput (Just 1) (return "nok") testVarEx4 = isOutput "ok" (execRuleFunc testVar4) --Test variable writing-testVar5 :: RuleFunc-testVar5 = voidRule $ do+testVar5 :: Rule+testVar5 = do var <- newVar_ "toto" ([]::[Int]) writeVar var ([1]::[Int])- a <- readVar var+ a <- liftEffect $ readVar var case a of- Just (a::[Int]) -> do- writeVar var (2:a)- return ()- Nothing -> newOutput_ (return "nok") (Just 1)+ Just (a::[Int]) -> void $ writeVar var (2:a)+ Nothing -> void $ newOutput (Just 1) (return "nok") -testVarEx5 = _variables (execRuleFunc testVar5) == [(Var 0 "toto" ([2,1]::[Int]))]+testVarEx5 = True --_variables (execRuleFunc testVar5) == [(Var 0 "toto" ([2,1]::[Int]))] data Choice = Holland | Sarkozy deriving (Enum, Typeable, Show, Eq, Bounded) -- Test input-testSingleInput :: RuleFunc-testSingleInput = voidRule $ do- onInputRadioEnum_ "Vote for Holland or Sarkozy" Holland h 1 where- h a = newOutput_ (return $ "voted for " ++ (show a)) (Just 1)+testSingleInput :: Rule+testSingleInput = void $ onInputRadio_ "Vote for Holland or Sarkozy" [Holland, Sarkozy] h 1 where+ h a = void $ newOutput (Just 1) (return $ "voted for " ++ show a) testSingleInputEx = isOutput "voted for Holland" g where- g = execRuleFuncEvent testSingleInput (inputRadioEnum 1 "Vote for Holland or Sarkozy" Holland) (InputData (RadioData Holland))+ g = execRuleFuncEvent testSingleInput (inputRadio 1 "Vote for Holland or Sarkozy" [Holland, Sarkozy] Holland) (InputData (RadioData Holland)) -testMultipleInputs :: RuleFunc-testMultipleInputs = voidRule $ do- onInputCheckbox_ "Vote for Holland and Sarkozy" [(Holland, "Holland"), (Sarkozy, "Sarkozy")] h 1 where- h a = newOutput_ (return $ "voted for " ++ (show a)) (Just 1)+testMultipleInputs :: Rule+testMultipleInputs = void $ onInputCheckbox_ "Vote for Holland and Sarkozy" [(Holland, "Holland"), (Sarkozy, "Sarkozy")] h 1 where+ h a = void $ newOutput (Just 1) (return $ "voted for " ++ show a) testMultipleInputsEx = isOutput "voted for [Holland,Sarkozy]" g where g = execRuleFuncEvent testMultipleInputs (inputCheckbox 1 "Vote for Holland and Sarkozy" [(Holland, "Holland"), (Sarkozy, "Sarkozy")]) (InputData (CheckboxData [Holland, Sarkozy])) --testInputString :: RuleFunc-testInputString = voidRule $ do- onInputText_ "Enter a number:" h 1 where- h a = newOutput_ (return $ "You entered: " ++ a) (Just 1)+testInputString :: Rule+testInputString = void $ onInputText_ "Enter a number:" h 1 where+ h a = void $ newOutput (Just 1) (return $ "You entered: " ++ a) testInputStringEx = isOutput "You entered: 1" g where g = execRuleFuncEvent testInputString (inputText 1 "Enter a number:") (InputData (TextData "1")) -- Test message-testSendMessage :: RuleFunc-testSendMessage = voidRule $ do+testSendMessage :: Rule+testSendMessage = do let msg = Message "msg" :: Event(Message String) onEvent_ msg f sendMessage msg "toto" where- f (MessageData a :: EventData(Message String)) = newOutput_ (return a) (Just 1)+ f (MessageData a :: EventData(Message String)) = void $ newOutput (Just 1) (return a) testSendMessageEx = isOutput "toto" (execRuleFunc testSendMessage) -testSendMessage2 :: RuleFunc-testSendMessage2 = voidRule $ do- onEvent_ (Message "msg":: Event(Message ())) $ const $ newOutput_ (return "Received") (Just 1)+testSendMessage2 :: Rule+testSendMessage2 = do+ onEvent_ (Message "msg":: Event(Message ())) $ const $ void $ newOutput (Just 1) (return "Received") sendMessage_ (Message "msg") @@ -192,33 +189,30 @@ data Choice2 = Me | You deriving (Enum, Typeable, Show, Eq, Bounded) -- Test user input + variable read/write-testUserInputWrite :: RuleFunc-testUserInputWrite = voidRule $ do+testUserInputWrite :: Rule+testUserInputWrite = do newVar_ "vote" (Nothing::Maybe Choice2) onEvent_ (Message "voted" :: Event (Message ())) h2- onEvent_ (InputEv (Input 1 "Vote for" (Radio [(Me, "Me"), (You, "You")]))) h1 where+ void $ onEvent_ (InputEv (Input 1 "Vote for" (Radio [(Me, "Me"), (You, "You")]))) h1 where h1 (InputData (RadioData a) :: EventData (Input Choice2)) = do writeVar (V "vote") (Just a) SendMessage (Message "voted") () h1 _ = undefined h2 (MessageData _) = do- a <- readVar (V "vote")- case a of- Just (Just Me) -> newOutput_ (return "voted Me") (Just 1)- _ -> newOutput_ (return "problem") (Just 1)+ a <- liftEffect $ readVar (V "vote")+ void $ case a of+ Just (Just Me) -> newOutput (Just 1) (return "voted Me")+ _ -> newOutput (Just 1) (return "problem") h2 _ = undefined testUserInputWriteEx = isOutput "voted Me" g where g = execRuleFuncEvent testUserInputWrite (InputEv (Input 1 "Vote for" (Radio [(Me, "Me"), (You, "You")]))) (InputData (RadioData Me)) -- Test rule activation-testActivateRule :: RuleFunc-testActivateRule = voidRule $ do- a <- GetRules- if (_rStatus (head a) == Pending) then do- ActivateRule $ _rNumber (head a)- return ()- else return ()+testActivateRule :: Rule+testActivateRule = do+ a <- liftEffect GetRules+ when (_rStatus (head a) == Pending) $ void $ ActivateRule $ _rNumber (head a) testActivateRuleEx = _rStatus (head $ _rules (execRuleFuncGame testActivateRule testGame {_rules=[testRule]})) == Active@@ -227,61 +221,69 @@ --Time tests -testTimeEvent :: RuleFunc-testTimeEvent = voidRule $ do- onEvent_ (Time date1) f where- f _ = outputAll' $ show date1+testTimeEvent :: Rule+testTimeEvent = void $ onEvent_ (Time date1) f where+ f _ = outputAll_ $ show date1 testTimeEventEx = isOutput (show date1) g where g = execRuleFuncEvent testTimeEvent (Time date1) (TimeData date1) testTimeEvent2 :: Nomex ()-testTimeEvent2 = schedule' [date1, date2] (outputAll' . show)+testTimeEvent2 = schedule' [date1, date2] (outputAll_ . show) testTimeEventEx2 = isOutput (show date1) g && isOutput (show date2) g where- g = flip execState testGame (runEvalError 0 $ evalExp testTimeEvent2 0 >> void gameEvs)+ g = execState (runEvalError Nothing $ evalNomex testTimeEvent2 0 >> void gameEvs) testGame gameEvs = do evTriggerTime date1 evTriggerTime date2 -- Test deletes-testDeleteRule :: RuleFunc-testDeleteRule = voidRule $ do+testDeleteRule :: Rule+testDeleteRule = do newVar_ "toto" (1::Int) onMessage (Message "msg":: Event(Message ())) (const $ return ())- newOutput_ (return "toto") (Just 1)+ void $ newOutput (Just 1) (return "toto") testDeleteGame :: Game-testDeleteGame = flip execState testGame {_players = []} $ runEvalError 0 $ do+testDeleteGame = flip execState testGame {_players = []} $ runEvalError Nothing $ do addActivateRule testDeleteRule 1- addActivateRule (voidRule $ suppressRule 1) 2+ addActivateRule (void $ suppressRule 1) 2 testDeleteRuleEx1 = (_rStatus $ head $ drop 1 $ _rules testDeleteGame) == Reject &&- (_variables testDeleteGame == []) &&+ --(_variables testDeleteGame == []) && (_oStatus $ head $ _outputs testDeleteGame) == SDeleted && (_evStatus $ head $ _events testDeleteGame) == SDeleted++-- Test victory+testVictoryGame :: Game+testVictoryGame = flip execState testGame $ runEvalError Nothing $ do+ addActivateRule (victoryXRules 1) 1+ addActivateRule (nothing) 2++testVictoryEx1 = (length $ getVictorious testVictoryGame) == 1+ -- Test votes voteGameActions :: Int -> Int -> Int -> Bool -> Evaluate () -> Game-voteGameActions positives negatives total timeEvent actions = flip execState testGame {_players = []} $ runEvalError 0 $ do- mapM_ (\x -> addPlayer (PlayerInfo x $ "coco " ++ (show x))) [1..total]+voteGameActions positives negatives total timeEvent actions = flip execState testGame {_players = []} $ runEvalError Nothing $ do+ mapM_ (\x -> addPlayer (PlayerInfo x ("coco " ++ show x) Nothing)) [1..total] actions evProposeRule testRule- evs <- getChoiceEvents+ evs <- lift getChoiceEvents let pos = take positives evs let neg = take negatives $ drop positives evs mapM_ (\x -> triggerInput x (URadioData $ fromEnum For)) pos mapM_ (\x -> triggerInput x (URadioData $ fromEnum Against)) neg when timeEvent $ void $ evTriggerTime date2 -voteGame' :: Int -> Int -> Int -> Bool -> RuleFunc -> Game+voteGame' :: Int -> Int -> Int -> Bool -> Rule -> Game voteGame' positives negatives notVoted timeEvent rf = voteGameActions positives negatives notVoted timeEvent $ addActivateRule rf 1 -voteGame :: Int -> Int -> Int -> RuleFunc -> Game-voteGame positives negatives notVoted rf = voteGame' positives negatives notVoted True rf+voteGame :: Int -> Int -> Int -> Rule -> Game+voteGame positives negatives notVoted = voteGame' positives negatives notVoted True -voteGameTimed :: Int -> Int -> Int -> RuleFunc -> Game-voteGameTimed positives negatives notVoted rf = voteGame' positives negatives notVoted True rf+voteGameTimed :: Int -> Int -> Int -> Rule -> Game+voteGameTimed positives negatives notVoted = voteGame' positives negatives notVoted True -- Test application meta rule --unanimityRule = testRule {_rName = "unanimityRule", _rRuleFunc = return $ Meta $ voteWith unanimity $ assessWhenEverybodyVoted, _rNumber = 1, _rStatus = Active}@@ -297,25 +299,23 @@ --testApplicationMetaRuleEx = (_rStatus $ head $ _rules testApplicationMetaRuleVote) == Active -- vote rules |Expected result |pos |neg |total |description of voting system-testVoteAssessOnVoteComplete1 = testVoteRule Active $ voteGame 10 0 10 $ onRuleProposed $ voteWith_ majority $ assessWhenEverybodyVoted-testVoteAssessOnVoteComplete2 = testVoteRule Pending $ voteGame 9 0 10 $ onRuleProposed $ voteWith_ majority $ assessWhenEverybodyVoted-testVoteAssessOnEveryVote1 = testVoteRule Active $ voteGame 10 0 10 $ onRuleProposed $ voteWith_ unanimity $ assessOnEveryVote-testVoteAssessOnEveryVote2 = testVoteRule Active $ voteGame 6 0 10 $ onRuleProposed $ voteWith_ majority $ assessOnEveryVote-testVoteAssessOnEveryVote3 = testVoteRule Pending $ voteGame 5 0 10 $ onRuleProposed $ voteWith_ majority $ assessOnEveryVote-testVoteAssessOnEveryVote4 = testVoteRule Reject $ voteGame 0 5 10 $ onRuleProposed $ voteWith_ majority $ assessOnEveryVote-testVoteMajorityWith = testVoteRule Active $ voteGame 6 0 10 $ onRuleProposed $ voteWith_ (majorityWith 50) $ assessOnEveryVote-testVoteNumberPositiveVotes = testVoteRule Active $ voteGame 3 7 10 $ onRuleProposed $ voteWith_ (numberVotes 3) $ assessOnEveryVote-testVoteWithQuorum1 = testVoteRule Active $ voteGame 7 3 10 $ onRuleProposed $ voteWith_ (majority `withQuorum` 7) $ assessOnEveryVote-testVoteWithQuorum2 = testVoteRule Pending $ voteGame 6 0 10 $ onRuleProposed $ voteWith_ (majority `withQuorum` 7) $ assessOnEveryVote+testVoteAssessOnVoteComplete1 = testVoteRule Active $ voteGame 10 0 10 $ onRuleProposed $ voteWith_ majority assessWhenEverybodyVoted+testVoteAssessOnVoteComplete2 = testVoteRule Pending $ voteGame 9 0 10 $ onRuleProposed $ voteWith_ majority assessWhenEverybodyVoted+testVoteAssessOnEveryVote1 = testVoteRule Active $ voteGame 10 0 10 $ onRuleProposed $ voteWith_ unanimity assessOnEveryVote+testVoteAssessOnEveryVote2 = testVoteRule Active $ voteGame 6 0 10 $ onRuleProposed $ voteWith_ majority assessOnEveryVote+testVoteAssessOnEveryVote3 = testVoteRule Pending $ voteGame 5 0 10 $ onRuleProposed $ voteWith_ majority assessOnEveryVote+testVoteAssessOnEveryVote4 = testVoteRule Reject $ voteGame 0 5 10 $ onRuleProposed $ voteWith_ majority assessOnEveryVote+testVoteMajorityWith = testVoteRule Active $ voteGame 6 0 10 $ onRuleProposed $ voteWith_ (majorityWith 50) assessOnEveryVote+testVoteNumberPositiveVotes = testVoteRule Active $ voteGame 3 7 10 $ onRuleProposed $ voteWith_ (numberVotes 3) assessOnEveryVote+testVoteWithQuorum1 = testVoteRule Active $ voteGame 7 3 10 $ onRuleProposed $ voteWith_ (majority `withQuorum` 7) assessOnEveryVote+testVoteWithQuorum2 = testVoteRule Pending $ voteGame 6 0 10 $ onRuleProposed $ voteWith_ (majority `withQuorum` 7) assessOnEveryVote testVoteAssessOnTimeLimit1 = testVoteRule Active $ voteGameTimed 10 0 10 $ onRuleProposed $ voteWith_ unanimity $ assessOnTimeLimit date2 testVoteAssessOnTimeLimit2 = testVoteRule Active $ voteGameTimed 1 0 10 $ onRuleProposed $ voteWith_ unanimity $ assessOnTimeLimit date2 testVoteAssessOnTimeLimit3 = testVoteRule Reject $ voteGameTimed 1 0 10 $ onRuleProposed $ voteWith_ (unanimity `withQuorum` 5) $ assessOnTimeLimit date2-testVoteAssessOnTimeLimit4 = testVoteRule Reject $ voteGameTimed 0 0 10 $ onRuleProposed $ voteWith_ (unanimity `withQuorum` 1) $ assessOnTimeLimit date2+testVoteAssessOnTimeLimit4 = testVoteRule Reject $ voteGameTimed 0 0 10 $ onRuleProposed $ voteWith_ (unanimity `withQuorum` 1) $ assessOnTimeLimit date2 testVoteAssessOnTimeLimit5 = testVoteRule Pending $ voteGameTimed 10 0 10 $ onRuleProposed $ voteWith_ unanimity $ assessOnTimeLimit date3 testVoteRule s g = (_rStatus $ head $ _rules g) == s -isOutput :: String -> Game -> Bool-isOutput s g = any (\(Output _ _ _ mys SActive) -> mys == s) (_outputs g)
src/Language/Nomyx/Engine/Utils.hs view
@@ -49,4 +49,3 @@ -> [a] -- ^ List composed of elements selected from original set by indices provided sel xs is = map (\i -> xs!!i) is -
src/Language/Nomyx/Events.hs view
@@ -1,21 +1,21 @@ {-# LANGUAGE ScopedTypeVariables #-} -- | All the building blocks to allow rules to build events. -module Language.Nomyx.Events where--- Event(..),--- EventNumber,--- EventData(..),--- InputData(..),--- Msg,--- MsgData,--- onEvent, onEvent_, --- onEventOnce, onEventOnce_, --- delEvent, delEvent_, delAllEvents, --- sendMessage, sendMessage_, --- onMessage, onMessageOnce, --- schedule, schedule_, schedule', schedule'_, --- getCurrentTime,--- oneWeek, oneDay, oneHour, oneMinute,+module Language.Nomyx.Events (+ Event(..),+ EventNumber,+ EventData(..),+ InputData(..),+ Msg,+ MsgData,+ onEvent, onEvent_, onEventOnce, + delEvent, delAllEvents, + sendMessage, sendMessage_, + onMessage, onMessageOnce, + schedule, schedule_, schedule', schedule'_, + getCurrentTime,+ oneWeek, oneDay, oneHour, oneMinute+ ) where import Language.Nomyx.Expression import Data.Typeable @@ -33,93 +33,80 @@ onEvent = OnEvent -- | register a callback on an event, disregard the event number -onEvent_ :: forall e. (Typeable e, Show e, Eq e) => Event e -> (EventData e -> Nomex ()) -> Nomex () -onEvent_ e h = do - OnEvent e (\(_, d) -> h d) - return () +onEvent_ :: forall e. (Typeable e, Show e, Eq e) => Event e -> (EventData e -> Nomex ()) -> Nomex EventNumber +onEvent_ e h = OnEvent e (\(_, d) -> h d) + -- | set an handler for an event that will be triggered only once onEventOnce :: (Typeable e, Show e, Eq e) => Event e -> (EventData e -> Nomex ()) -> Nomex EventNumber onEventOnce e h = do - let handler (en, ed) = delEvent_ en >> h ed - n <- OnEvent e handler - return n - --- | set an handler for an event that will be triggered only once -onEventOnce_ :: (Typeable e, Show e, Eq e) => Event e -> (EventData e -> Nomex ()) -> Nomex () -onEventOnce_ e h = do - let handler (en, ed) = delEvent_ en >> h ed + let handler (en, ed) = delEvent en >> h ed OnEvent e handler - return () delEvent :: EventNumber -> Nomex Bool delEvent = DelEvent -delEvent_ :: EventNumber -> Nomex () -delEvent_ e = delEvent e >> return () - delAllEvents :: (Typeable e, Show e, Eq e) => Event e -> Nomex () delAllEvents = DelAllEvents -- | broadcast a message that can be catched by another rule -sendMessage :: (Typeable a, Show a, Eq a) => Msg a -> a -> Nomex () +sendMessage :: (Typeable a, Show a) => Msg a -> a -> Nomex () sendMessage = SendMessage sendMessage_ :: Msg () -> Nomex () sendMessage_ m = SendMessage m () -- | subscribe on a message -onMessage :: (Typeable m, Show m) => Msg m -> (MsgData m -> Nomex ()) -> Nomex () -onMessage m f = onEvent_ m f +onMessage :: (Typeable m, Show m) => Msg m -> (MsgData m -> Nomex ()) -> Nomex EventNumber +onMessage = onEvent_ -onMessageOnce :: (Typeable m, Show m) => Msg m -> (MsgData m -> Nomex ()) -> Nomex () -onMessageOnce m f = onEventOnce_ m f +onMessageOnce :: (Typeable m, Show m) => Msg m -> (MsgData m -> Nomex ()) -> Nomex EventNumber +onMessageOnce = onEventOnce -- | on the provided schedule, the supplied function will be called -schedule :: (Schedule Freq) -> (UTCTime -> Nomex ()) -> Nomex () +schedule :: Schedule Freq -> (UTCTime -> Nomex ()) -> Nomex () schedule sched f = do - now <- getCurrentTime - let next = head $ starting now $ sched - if (next == now) then executeAndScheduleNext (f . timeData) sched (TimeData now) - else onEventOnce_ (Time next) $ executeAndScheduleNext (f . timeData) sched where + now <- liftEffect getCurrentTime + let next = head $ starting now sched + if next == now then executeAndScheduleNext (f . timeData) sched (TimeData now) + else void $ onEventOnce (Time next) $ executeAndScheduleNext (f . timeData) sched -executeAndScheduleNext :: (EventData Time -> Nomex ()) -> (Schedule Freq) -> (EventData Time) -> Nomex () +executeAndScheduleNext :: (EventData Time -> Nomex ()) -> Schedule Freq -> EventData Time -> Nomex () executeAndScheduleNext f sched now = do f now - let rest = drop 1 $ starting (timeData now) $ sched - when (rest /= []) $ onEventOnce_ (Time $ head rest) $ executeAndScheduleNext f sched + let rest = drop 1 $ starting (timeData now) sched + when (rest /= []) $ void $ onEventOnce (Time $ head rest) $ executeAndScheduleNext f sched -schedule_ :: (Schedule Freq) -> Nomex () -> Nomex () -schedule_ ts f = schedule ts (\_-> f) +schedule_ :: Schedule Freq -> Nomex () -> Nomex () +schedule_ ts f = schedule ts (const f) --at each time provided, the supplied function will be called schedule' :: [UTCTime] -> (UTCTime -> Nomex ()) -> Nomex () schedule' sched f = do let sched' = sort sched - now <- getCurrentTime - let nextMay = headMay $ filter (>=now) $ sched' + now <- liftEffect getCurrentTime + let nextMay = headMay $ filter (>=now) sched' case nextMay of - Just next -> do - if (next == now) then executeAndScheduleNext' (f . timeData) sched' (TimeData now) - else onEventOnce_ (Time next) $ executeAndScheduleNext' (f . timeData) sched' + Just next -> if next == now then executeAndScheduleNext' (f . timeData) sched' (TimeData now) + else void $ onEventOnce (Time next) $ executeAndScheduleNext' (f . timeData) sched' Nothing -> return () -executeAndScheduleNext' :: (EventData Time -> Nomex ()) -> [UTCTime] -> (EventData Time) -> Nomex () +executeAndScheduleNext' :: (EventData Time -> Nomex ()) -> [UTCTime] -> EventData Time -> Nomex () executeAndScheduleNext' f sched now = do f now - let rest = drop 1 $ sched - when (rest /= []) $ onEventOnce_ (Time $ head rest) $ executeAndScheduleNext' f sched + let rest = drop 1 sched + when (rest /= []) $ void $ onEventOnce (Time $ head rest) $ executeAndScheduleNext' f sched schedule'_ :: [UTCTime] -> Nomex () -> Nomex () -schedule'_ ts f = schedule' ts (\_-> f) +schedule'_ ts f = schedule' ts (const f) -getCurrentTime :: Nomex UTCTime +getCurrentTime :: NomexNE UTCTime getCurrentTime = CurrentTime --- | durations+-- | duration oneWeek, oneDay, oneHour, oneMinute :: NominalDiffTime oneWeek = 7 * oneDay oneDay = 24 * oneHour
src/Language/Nomyx/Examples.hs view
@@ -1,102 +1,123 @@-{-# LANGUAGE GADTs, DeriveDataTypeable #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE DeriveDataTypeable #-} -- | This file gives a list of example rules that the players can submit. --You can copy-paste them in the field "Code" of the web GUI. --Don't hesitate to get inspiration from there and create your own rules!-module Language.Nomyx.Examples(nothing, helloWorld, accounts, createBankAccount, winXEcuPerDay,- winXEcuOnRuleAccepted, moneyTransfer, delRule, voteWithMajority, king, makeKing, monarchy,- revolution, victoryXRules, victoryXEcu, displayTime, noGroupVictory, iWin, returnToDemocracy,- banPlayer, referendum, referendumOnKickPlayer, gameMasterElections, gameMaster, bravoButton,- enterHaiku, displayBankAccount,- module Data.Time.Recurrence, module Control.Monad, module Data.List, module Data.Time.Clock) where+module Language.Nomyx.Examples(+ nothing,+ helloWorld,+ accounts,+ createBankAccount,+ winXEcuPerDay,+ winXEcuOnRuleAccepted,+ moneyTransfer,+ delRule,+ voteWithMajority,+ king,+ makeKing,+ monarchy,+ revolution,+ displayTime,+ iWin,+ returnToDemocracy,+ victoryXRules,+ victoryXEcu,+ --noGroupVictory,+ banPlayer,+ referendum,+ referendumOnKickPlayer,+ gameMasterElections,+ gameMaster,+ bravoButton,+ enterHaiku,+ displayBankAccount,+ module X) where -import Language.Nomyx import Data.Function-import Data.Time.Clock hiding (getCurrentTime)-import Data.Time.Recurrence hiding (filter)+import Data.Time.Clock as X hiding (getCurrentTime)+import Data.Time.Recurrence as X hiding (filter)+import Data.List as X+import Data.Typeable import Control.Arrow-import Data.List-import Control.Monad+import Control.Monad as X import Safe (readDef)-import Data.Typeable+import Language.Nomyx -- | A rule that does nothing-nothing :: RuleFunc-nothing = return Void+nothing :: Rule+nothing = return () -- | A rule that says hello to all players-helloWorld :: RuleFunc-helloWorld = voidRule $ outputAll' "hello, world!"+helloWorld :: Rule+helloWorld = outputAll_ "hello, world!" -- | account variable name and type accounts :: MsgVar [(PlayerNumber, Int)] accounts = msgVar "Accounts" -- | Create a bank account for each players-createBankAccount :: RuleFunc-createBankAccount = voidRule $ createValueForEachPlayer_ accounts+createBankAccount :: Rule+createBankAccount = void $ createValueForEachPlayer_ accounts -- | Permanently display the bank accounts-displayBankAccount :: RuleFunc-displayBankAccount = voidRule $ do+displayBankAccount :: Rule+displayBankAccount = do let displayOneAccount (account_pn, a) = do name <- showPlayer account_pn- return $ name ++ "\t" ++ (show a) ++ "\n"+ return $ name ++ "\t" ++ show a ++ "\n" let displayAccounts l = do d <- concatMapM displayOneAccount l return $ "Accounts:\n" ++ d- displayVar Nothing accounts displayAccounts-+ void $ displayVar' Nothing accounts displayAccounts -- | each player wins X Ecu each day -- you can also try with "minutly" or "monthly" instead of "daily" and everything in the "time-recurrence" package-winXEcuPerDay :: Int -> RuleFunc-winXEcuPerDay x = voidRule $ schedule_ (recur daily) $ modifyAllValues accounts (+x)+winXEcuPerDay :: Int -> Rule+winXEcuPerDay x = 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)+winXEcuOnRuleAccepted :: Int -> Rule+winXEcuOnRuleAccepted x = void $ onEvent_ (RuleEv Activated) $ \(RuleData rule) -> void $ modifyValueOfPlayer (_rProposedBy rule) accounts (+x) -- | a player can transfer money to another player -- it does not accept new players or check if balance is positive, to keep the example simple-moneyTransfer :: RuleFunc-moneyTransfer = voidRule $ do- pls <- getAllPlayerNumbers- when (length pls >= 2) $ forEachPlayer_ (selPlayer pls) where- selPlayer pls src = onInputRadio_ "Transfer money to player: " (delete src $ sort pls) (selAmount src) src- selAmount src dst = onInputTextOnce_ ("Select Amount to transfert to player: " ++ show dst) (transfer src dst) src- transfer src dst amount = do- modifyValueOfPlayer dst accounts (\a -> a + (readDef 0 amount))- modifyValueOfPlayer src accounts (\a -> a - (readDef 0 amount))- newOutput_ (return $ "You gave " ++ amount ++ " ecus to player " ++ show dst) (Just src)- newOutput_ (return $ "Player " ++ show src ++ " gaved you " ++ amount ++ "ecus") (Just dst)-+moneyTransfer :: Rule+moneyTransfer = do+ pls <- liftEffect getAllPlayerNumbers+ when (length pls >= 2) $ void $ forEachPlayer_ (selPlayer pls) where+ selPlayer pls src = void $ onInputRadio_ "Transfer money to player: " (delete src $ sort pls) (selAmount src) src+ selAmount src dst = void $ onInputTextOnce ("Select Amount to transfert to player: " ++ show dst) (transfer src dst) src+ transfer src dst amount = do+ modifyValueOfPlayer dst accounts (\a -> a + (readDef 0 amount))+ modifyValueOfPlayer src accounts (\a -> a - (readDef 0 amount))+ void $ newOutput (Just src) (return $ "You gave " ++ amount ++ " ecus to player " ++ show dst)+ void $ newOutput (Just dst) (return $ "Player " ++ show src ++ " gaved you " ++ amount ++ "ecus") -- | delete a rule-delRule :: RuleNumber -> RuleFunc-delRule rn = voidRule $ suppressRule rn >> autoDelete+delRule :: RuleNumber -> Rule+delRule rn = suppressRule_ rn >> autoDelete -- | player pn is the king: we create a variable King to identify him, -- and we prefix his name with "King"-makeKing :: PlayerNumber -> RuleFunc-makeKing pn = voidRule $ do- voidRule $ newMsgVar_ "King" pn- modifyPlayerName pn ("King " ++)+makeKing :: PlayerNumber -> Rule+makeKing pn = do+ newMsgVar_ "King" pn+ void $ modifyPlayerName pn ("King " ++) king :: MsgVar PlayerNumber king = msgVar "King" -- | Monarchy: only the king decides which rules to accept or reject-monarchy :: RuleFunc-monarchy = voidRule $ onEvent_ (RuleEv Proposed) $ \(RuleData rule) -> do+monarchy :: Rule+monarchy = void $ onEvent_ (RuleEv Proposed) $ \(RuleData rule) -> do k <- readMsgVar_ king- onInputRadioEnumOnce_ ("Your Royal Highness, do you accept rule " ++ (show $ _rNumber rule) ++ "?") True (activateOrReject rule) k-+ void $ onInputRadioOnce ("Your Royal Highness, do you accept rule " ++ (show $ _rNumber rule) ++ "?") [True, False] (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+revolution :: PlayerNumber -> Rule+revolution player = do suppressRule 1 makeKing player rNum <- addRuleParams "Monarchy" monarchy "monarchy" "Monarchy: only the king can vote on new rules"@@ -104,92 +125,92 @@ --autoDelete -- | set the victory for players having more than X accepted rules-victoryXRules :: Int -> RuleFunc-victoryXRules x = voidRule $ onEvent_ (RuleEv Activated) $ \_ -> do- rs <- getActiveRules+victoryXRules :: Int -> Rule+victoryXRules x = setVictory $ do+ rs <- getRules let counts = map (_rProposedBy . head &&& length) $ groupBy ((==) `on` _rProposedBy) rs let victorious = map fst $ filter ((>= x) . snd) counts- when (length victorious /= 0) $ setVictory victorious+ return victorious -victoryXEcu :: Int -> RuleFunc-victoryXEcu x = voidRule $ onEvent_ (RuleEv Activated) $ \_ -> do- as <- readMsgVar_ accounts- let victorious = map fst $ filter ((>= x) . snd) as- if (length victorious /= 0) then setVictory victorious else return ()+victoryXEcu :: Int -> Rule+victoryXEcu x = setVictory $ do+ as <- readMsgVar accounts+ let victorious as = map fst $ filter ((>= x) . snd) as+ return $ maybe [] victorious as -- | will display the time to all players in 5 seconds-displayTime :: RuleFunc-displayTime = voidRule $ do+displayTime :: Rule+displayTime = void $ outputAll $ do t <- getCurrentTime- onEventOnce_ (Time $ addUTCTime 5 t) $ \(TimeData t) -> outputAll' $ show t+ return $ show t -- | Only one player can achieve victory: No group victory. -- Forbidding group victory usually becomes necessary when lowering the voting quorum: -- a coalition of players could simply force a "victory" rule and win the game.-noGroupVictory :: RuleFunc-noGroupVictory = voidRule $ onEvent_ Victory $ \(VictoryData ps) -> when (length ps >1) $ setVictory []+--noGroupVictory :: RuleFunc+--noGroupVictory = ruleFunc $ onEvent_ Victory $ \(VictoryData ps) -> when (length ps >1) $ setVictory [] -- | Rule that state that you win. Good luck on having this accepted by other players ;)-iWin :: RuleFunc-iWin = voidRule $ getSelfProposedByPlayer >>= giveVictory+iWin :: Rule+iWin = liftEffect getProposerNumber >>= giveVictory -- | a majority vote, with the folowing parameters: -- a quorum of 2 voters is necessary for the validity of the vote -- the vote is assessed after every vote in case the winner is already known -- the vote will finish anyway after one day-voteWithMajority :: RuleFunc+voteWithMajority :: Rule voteWithMajority = onRuleProposed $ voteWith_ (majority `withQuorum` 2) $ assessOnEveryVote >> assessOnTimeDelay oneDay -- | Change current system (the rules passed in parameter) to absolute majority (half participants plus one)-returnToDemocracy :: [RuleNumber] -> RuleFunc-returnToDemocracy rs = voidRule $ do+returnToDemocracy :: [RuleNumber] -> Rule+returnToDemocracy rs = do mapM_ suppressRule rs rNum <- addRuleParams "vote with majority" voteWithMajority "voteWithMajority" "majority with a quorum of 2" activateRule_ rNum autoDelete -- | kick a player and prevent him from returning-banPlayer :: PlayerNumber -> RuleFunc-banPlayer pn = voidRule $ do+banPlayer :: PlayerNumber -> Rule+banPlayer pn = do delPlayer pn- onEvent_ (Player Arrive) $ \(PlayerData _) -> void $ delPlayer pn+ void $ onEvent_ (Player Arrive) $ \(PlayerData _) -> void $ delPlayer pn -- * Referendum & elections -- | triggers a referendum, if the outcome is yes player 2 will be kicked-referendumOnKickPlayer :: RuleFunc+referendumOnKickPlayer :: Rule referendumOnKickPlayer = referendum " kick player 2" (void $ delPlayer 2) -- | triggers elections (all players are candidates), the winner becomes game master-gameMasterElections :: RuleFunc-gameMasterElections = voidRule $ do- pls <- getPlayers+gameMasterElections :: Rule+gameMasterElections = do+ pls <- liftEffect getPlayers elections "Game Master" pls makeGM -makeGM :: PlayerNumber -> Nomex()+makeGM :: PlayerNumber -> Nomex () makeGM pn = do newMsgVar "GameMaster" pn void $ modifyPlayerName pn ("GameMaster " ++) gameMaster :: MsgVar PlayerNumber-gameMaster =msgVar "GameMaster"+gameMaster = msgVar "GameMaster" -- | display a button and greets you when pressed (for player 1)-bravoButton :: RuleFunc-bravoButton = voidRule $ voidRule $ onInputButton_ "Click here:" (const $ outputAll' "Bravo!") 1+bravoButton :: Rule+bravoButton = void $ onInputButton_ "Click here:" (const $ outputAll_ "Bravo!") 1 -enterHaiku :: RuleFunc-enterHaiku = voidRule $ onInputTextarea_ "Enter a haiku:" outputAll' 1+enterHaiku :: Rule+enterHaiku = void $ onInputTextarea_ "Enter a haiku:" outputAll_ 1 -tournamentMasterCandidates :: RuleFunc-tournamentMasterCandidates = voidRule $ do+tournamentMasterCandidates :: Rule+tournamentMasterCandidates = do let tournamentMasterCandidates = msgVar "tournamentMasterCandidates" :: MsgVar [PlayerNumber] let candidate pn = void $ modifyMsgVar tournamentMasterCandidates (pn : )- let displayCandidates pns = return $ "Candidates for the election of Tournament Master: Players #" ++ (concat $ intersperse ", " $ map show pns)+ let displayCandidates pns = return $ "Candidates for the election of Tournament Master: Players #" ++ intercalate ", " (map show pns) newMsgVar_ (getMsgVarName tournamentMasterCandidates) ([] :: [PlayerNumber])- forEachPlayer_ (\pn -> onInputButtonOnce_ "I am candidate for the next Tournament Master elections " (const $ candidate pn) pn)- displayVar Nothing tournamentMasterCandidates displayCandidates+ forEachPlayer_ (\pn -> void $ onInputButtonOnce "I am candidate for the next Tournament Master elections " (const $ candidate pn) pn)+ void $ displayVar' Nothing tournamentMasterCandidates displayCandidates -- | castle structure data Castle = Castle { towers :: Int, dungeon :: Bool }@@ -198,12 +219,10 @@ castles :: MsgVar [(PlayerNumber, Castle)] castles = msgVar "Castles" -castleVictory :: RuleFunc-castleVictory = voidRule $ do- let checkVict cs = do- let vict = map fst $ filter ((== (Castle 4 True)) . snd) cs- when (length vict > 0) $ setVictory vict- onMsgVarChange castles $ (\(VUpdated cs) -> checkVict cs)+--castleVictory :: RuleFunc+--castleVictory = ruleFunc $ do+-- let checkVict cs = do+-- let vict = map fst $ filter ((== (Castle 4 True)) . snd) cs+-- when (length vict > 0) $ setVictory vict+-- onMsgVarEvent castles $ (\(VUpdated cs) -> checkVict cs) -concatMapM :: (Monad m) => (a -> m [b]) -> [a] -> m [b]-concatMapM f xs = liftM concat (mapM f xs)
src/Language/Nomyx/Expression.hs view
@@ -1,5 +1,12 @@-{-# LANGUAGE FlexibleInstances, GADTs, DeriveDataTypeable, MultiParamTypeClasses, - TemplateHaskell, ScopedTypeVariables, StandaloneDeriving, NamedFieldPuns, EmptyDataDecls #-} +{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-} -- | This module containt the type definitions necessary to build a Nomic rule. module Language.Nomyx.Expression where @@ -24,55 +31,75 @@ type OutputNumber = Int -- * Nomyx Expression ++data Eff = Effect | NoEffect+type Effect = 'Effect+type NoEffect = 'NoEffect -- | A Nomex (Nomyx Expression) allows the players to write rules.--- within the rules, you can access and modify the state of the game. -data Nomex a where - --Variable management- NewVar :: (Typeable a, Show a, Eq a) => VarName -> a -> Nomex (Maybe (V a)) - ReadVar :: (Typeable a, Show a, Eq a) => (V a) -> Nomex (Maybe a) - WriteVar :: (Typeable a, Show a, Eq a) => (V a) -> a -> Nomex Bool - DelVar :: (V a) -> Nomex Bool +-- within the rules, you can access and modify the state of the game.+type Nomex = Exp Effect++-- | A NomexNE (Nomyx Expression No Effect) is a specialisation of the type that guaranties+-- that the instructions will have no effects.+type NomexNE = Exp NoEffect+ +data Exp :: Eff -> * -> * where + --Variables management+ NewVar :: (Typeable a, Show a) => VarName -> a -> Nomex (Maybe (V a)) + ReadVar :: (Typeable a, Show a) => V a -> Exp NoEffect (Maybe a) + WriteVar :: (Typeable a, Show a) => V a -> a -> Nomex Bool + DelVar :: (V a) -> Nomex Bool --Events management- OnEvent :: (Typeable e, Show e, Eq e) => Event e -> ((EventNumber, EventData e) -> Nomex ()) -> Nomex EventNumber + OnEvent :: Typeable e => Event e -> ((EventNumber, EventData e) -> Nomex ()) -> Nomex EventNumber DelEvent :: EventNumber -> Nomex Bool - DelAllEvents :: (Typeable e, Show e, Eq e) => Event e -> Nomex () - SendMessage :: (Typeable a, Show a, Eq a) => Event (Message a) -> a -> Nomex () + DelAllEvents :: Typeable e => Event e -> Nomex () + SendMessage :: (Typeable a, Show a) => Event (Message a) -> a -> Nomex () --Rules management - ProposeRule :: Rule -> Nomex Bool + ProposeRule :: RuleInfo -> Nomex Bool ActivateRule :: RuleNumber -> Nomex Bool RejectRule :: RuleNumber -> Nomex Bool - AddRule :: Rule -> Nomex Bool - ModifyRule :: RuleNumber -> Rule -> Nomex Bool - GetRules :: Nomex [Rule] + AddRule :: RuleInfo -> Nomex Bool + ModifyRule :: RuleNumber -> RuleInfo -> Nomex Bool + GetRules :: NomexNE [RuleInfo] --Players management- GetPlayers :: Nomex [PlayerInfo]+ GetPlayers :: NomexNE [PlayerInfo] SetPlayerName :: PlayerNumber -> PlayerName -> Nomex Bool DelPlayer :: PlayerNumber -> Nomex Bool- --Output- NewOutput :: (Maybe PlayerNumber) -> String -> Nomex OutputNumber- GetOutput :: OutputNumber -> Nomex (Maybe String)- UpdateOutput :: OutputNumber -> String -> Nomex Bool+ --Outputs+ NewOutput :: Maybe PlayerNumber -> NomexNE String -> Nomex OutputNumber+ GetOutput :: OutputNumber -> NomexNE (Maybe String)+ UpdateOutput :: OutputNumber -> NomexNE String -> Nomex Bool DelOutput :: OutputNumber -> Nomex Bool --Mileacenous- SetVictory :: [PlayerNumber] -> Nomex () - CurrentTime :: Nomex UTCTime - SelfRuleNumber :: Nomex RuleNumber+ SetVictory :: NomexNE [PlayerNumber] -> Nomex () + CurrentTime :: NomexNE UTCTime + SelfRuleNumber :: NomexNE RuleNumber --Monadic bindings- Return :: a -> Nomex a - Bind :: Nomex a -> (a -> Nomex b) -> Nomex b- ThrowError :: String -> Nomex a- CatchError :: Nomex a -> (String -> Nomex a) -> Nomex a - deriving (Typeable) - -instance Monad Nomex where + Return :: a -> Exp e a + Bind :: Exp e a -> (a -> Exp e b) -> Exp e b+ ThrowError :: String -> Exp Effect a+ CatchError :: Nomex a -> (String -> Nomex a) -> Nomex a+ LiftEffect :: NomexNE a -> Nomex a+ Simu :: Nomex a -> NomexNE Bool -> NomexNE Bool++instance Typeable1 (Exp NoEffect) where+ typeOf1 _ = mkTyConApp (mkTyCon3 "main" "Language.Nomyx.Expression" "Exp NoEffect") []++instance Typeable1 (Exp Effect) where+ typeOf1 _ = mkTyConApp (mkTyCon3 "main" "Language.Nomyx.Expression" "Exp Effect") []++liftEffect :: NomexNE a -> Nomex a+liftEffect = LiftEffect + +instance Monad (Exp a) where return = Return (>>=) = Bind -instance Functor Nomex where +instance Functor (Exp a) where fmap f e = Bind e $ Return . f -instance Applicative Nomex where +instance Applicative (Exp a) where pure = Return f <*> a = do f' <- f @@ -83,14 +110,19 @@ throwError = ThrowError catchError = CatchError -instance Typeable a => Show (Nomex a) where - show e = '<' : (show . typeOf) e ++ ">" +instance Typeable a => Show (Exp NoEffect a) where + show e = "<" ++ (show $ typeOf e) ++ ">" - +instance Typeable a => Show (Exp Effect a) where + show e = "<" ++ (show $ typeOf e) ++ ">"+ +instance (Typeable a, Typeable b) => Show (a -> b) where+ show e = '<' : (show . typeOf) e ++ ">"+ -- * Variables -- | a container for a variable name and type -data V a = V {varName :: String} deriving (Typeable) +data V a = V {varName :: String} deriving Typeable -- * Events @@ -101,12 +133,13 @@ data EvRule deriving Typeable data Message m deriving Typeable data Victory deriving Typeable-data Input a = Input PlayerNumber String (InputForm a)+data Input a = Input PlayerNumber String (InputForm a) deriving Typeable data InputForm a = Radio [(a, String)] | Text | TextArea | Button | Checkbox [(a, String)]+ deriving Typeable -- | events names data Event a where @@ -114,8 +147,9 @@ RuleEv :: RuleEvent -> Event RuleEvent Time :: UTCTime -> Event Time Message :: String -> Event (Message m) - InputEv :: (Eq a, Show a, Typeable a) => Input a -> Event (Input a) - Victory :: Event Victory + InputEv :: (Typeable a, Show a, Eq a) => Input a -> Event (Input a) + Victory :: Event Victory+ deriving (Typeable) -- data sent back by inputs data InputData a = RadioData a@@ -128,29 +162,26 @@ -- | data associated with each events data EventData a where PlayerData :: {playerData :: PlayerInfo} -> EventData Player - RuleData :: {ruleData :: Rule} -> EventData RuleEvent + RuleData :: {ruleData :: RuleInfo} -> EventData RuleEvent TimeData :: {timeData :: UTCTime} -> EventData Time MessageData :: (Show m) => {messageData :: m} -> EventData (Message m) InputData :: (Show a) => {inputData :: InputData a} -> EventData (Input a) - VictoryData :: {victoryData :: [PlayerInfo]} -> EventData Victory + VictoryData :: {victoryData :: VictoryCond} -> EventData Victory+ deriving (Typeable) -deriving instance Typeable1 EventData -deriving instance Typeable1 Event-deriving instance Typeable1 Input-deriving instance Typeable1 InputForm -deriving instance (Show a) => Show (Event a)+deriving instance Show (Event a) deriving instance (Show a) => Show (InputForm a) deriving instance (Show a) => Show (Input a) -deriving instance (Show a) => Show (EventData a)+deriving instance Show (EventData a) deriving instance (Show a) => Show (InputData a) deriving instance (Show a) => Show (Message a) -deriving instance Show Time -deriving instance Show Victory +deriving instance Show Victory+deriving instance Show Time deriving instance Eq Time deriving instance Eq Victory deriving instance Eq EvRule deriving instance Eq (Message m) -deriving instance (Eq e) => Eq (Event e)+deriving instance Eq (Event e) deriving instance (Eq e) => Eq (Input e) deriving instance (Eq e) => Eq (InputForm e) @@ -161,37 +192,24 @@ -- * Rule -- | Type of a rule function.-type RuleFunc = Nomex RuleResp---- | Return type of a rule function.--- it can be either nothing or another rule. -data RuleResp = - Void - | Meta (Rule -> Nomex BoolResp) - deriving (Typeable)---An extended type for booleans supporting immediate or delayed response (through a message) -data BoolResp = BoolResp Bool - | MsgResp (Msg Bool) - -instance Show RuleResp where - show _ = "RuleResp" +type Rule = Nomex () -- | 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) +data RuleInfo = RuleInfo { _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 + _rRule :: Rule, -- 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 Eq RuleInfo where + (RuleInfo {_rNumber=r1}) == (RuleInfo {_rNumber=r2}) = r1 == r2 -instance Ord Rule where - (Rule {_rNumber=r1}) <= (Rule {_rNumber=r2}) = r1 <= r2 +instance Ord RuleInfo where + (RuleInfo {_rNumber=r1}) <= (RuleInfo {_rNumber=r2}) = r1 <= r2 -- | the status of a rule. data RuleStatus = Active -- Active rules forms the current Constitution @@ -203,19 +221,26 @@ -- | informations on players data PlayerInfo = PlayerInfo { _playerNumber :: PlayerNumber, - _playerName :: String} + _playerName :: String,+ _playAs :: Maybe PlayerNumber} deriving (Eq, Typeable, Show) instance Ord PlayerInfo where h <= g = (_playerNumber h) <= (_playerNumber g) +-- * Victory +data VictoryCond = VictoryCond RuleNumber (NomexNE [PlayerNumber]) deriving (Show, Typeable)+ partial :: String -> Nomex (Maybe a) -> Nomex a partial s nm = do m <- nm case m of Just a -> return a Nothing -> throwError s- -$( makeLenses [''Rule, ''PlayerInfo] ) ++concatMapM :: (Monad m) => (a -> m [b]) -> [a] -> m [b]+concatMapM f xs = liftM concat (mapM f xs) ++$( makeLenses [''RuleInfo, ''PlayerInfo] )
src/Language/Nomyx/Inputs.hs view
@@ -1,168 +1,124 @@-{-# LANGUAGE ScopedTypeVariables, GADTs #-}+{-# LANGUAGE GADTs #-} --- | All the building blocks to allow rules to get inputs. -module Language.Nomyx.Inputs where --- Input(..),--- InputForm(..),--- inputRadio, inputRadioHead, inputRadioEnum, --- inputRadioData, --- onInputRadio, onInputRadio_, --- onInputRadioOnce, onInputRadioOnce_, --- onInputRadioEnum, onInputRadioEnum_, --- onInputRadioEnumOnce_, --- inputText, --- inputTextData, --- onInputText, onInputText_, --- onInputTextOnce, onInputTextOnce_, --- inputCheckboxData,--- inputCheckbox, --- onInputCheckbox, onInputCheckbox_, --- onInputCheckboxOnce, onInputCheckboxOnce_,--- inputButtonData, --- inputButton, --- onInputButton, onInputButton_, --- onInputButtonOnce, onInputButtonOnce_, --- inputTextareaData,--- inputTextarea, --- onInputTextarea, onInputTextarea_,--- onInputTextareaOnce, onInputTextareaOnce_,+-- | All the building blocks to allow rules to get inputs.+-- for example, you can create a button that will display a message like this:+-- do+-- void $ onInputButton_ "Click here:" (const $ outputAll_ "Bravo!") 1 +module Language.Nomyx.Inputs ( + Input(..),+ InputForm(..),+ onInputRadio, onInputRadio_, onInputRadioOnce, + onInputText, onInputText_, onInputTextOnce, + onInputCheckbox, onInputCheckbox_, onInputCheckboxOnce,+ onInputButton, onInputButton_, onInputButtonOnce, + onInputTextarea, onInputTextarea_, onInputTextareaOnce,+ -- Internals+ inputRadio, inputText, inputCheckbox, inputButton, inputTextarea+ ) where+ import Language.Nomyx.Expression import Language.Nomyx.Events import Data.Typeable import Control.Applicative - -- * Inputs -- ** Radio inputs -inputRadio :: (Eq c, Show c, Typeable c) => PlayerNumber -> String -> [c] -> c -> Event (Input c) -inputRadio pn title cs _ = InputEv (Input pn title (Radio (zip cs (show <$> cs)))) - -inputRadioHead :: (Eq c, Show c, Typeable c) => PlayerNumber -> String -> [c] -> Event (Input c) -inputRadioHead pn title choices = inputRadio pn title choices (head choices) - -inputRadioEnum :: forall c. (Enum c, Bounded c, Typeable c, Eq c, Show c) => PlayerNumber -> String -> c -> Event (Input c) -inputRadioEnum pn title defaultChoice = inputRadio pn title (enumFrom (minBound::c)) defaultChoice - -inputRadioData :: (Show c) => EventData (Input c) -> c -inputRadioData (InputData (RadioData a)) = a -inputRadioData a = error $ "Not a Radio Data: " ++ (show a) - -- | triggers a choice input to the user. The result will be sent to the callback onInputRadio :: (Typeable a, Eq a, Show a) => String -> [a] -> (EventNumber -> a -> Nomex ()) -> PlayerNumber -> Nomex EventNumber onInputRadio title choices handler pn = onEvent (inputRadioHead pn title choices) (\(en, InputData (RadioData a)) -> handler en a) -- | the same, disregard the event number -onInputRadio_ :: (Typeable a, Eq a, Show a) => String -> [a] -> (a -> Nomex ()) -> PlayerNumber -> Nomex () +onInputRadio_ :: (Typeable a, Eq a, Show a) => String -> [a] -> (a -> Nomex ()) -> PlayerNumber -> Nomex EventNumber onInputRadio_ title choices handler pn = onEvent_ (inputRadioHead pn title choices) (handler . inputRadioData) -- | the same, suppress the event after first trigger onInputRadioOnce :: (Typeable a, Eq a, Show a) => String -> [a] -> (a -> Nomex ()) -> PlayerNumber -> Nomex EventNumber onInputRadioOnce title choices handler pn = onEventOnce (inputRadioHead pn title choices) (handler . inputRadioData) --- | the same, disregard the event number -onInputRadioOnce_ :: (Typeable a, Eq a, Show a) => String -> [a] -> (a -> Nomex ()) -> PlayerNumber -> Nomex () -onInputRadioOnce_ title choices handler pn = onEventOnce_ (inputRadioHead pn title choices) (handler . inputRadioData) - --- | triggers a choice input to the user, using an enumerate as input -onInputRadioEnum :: forall a. (Enum a, Bounded a, Typeable a, Eq a, Show a) => String -> a -> (EventNumber -> a -> Nomex ()) -> PlayerNumber -> Nomex EventNumber -onInputRadioEnum title defaultChoice handler pn = onEvent (inputRadioEnum pn title defaultChoice) (\(en, a) -> handler en (inputRadioData a)) - --- | the same, disregard the event number -onInputRadioEnum_ :: forall a. (Enum a, Bounded a, Typeable a, Eq a, Show a) => String -> a -> (a -> Nomex ()) -> PlayerNumber -> Nomex () -onInputRadioEnum_ title defaultChoice handler pn = onEvent_ (inputRadioEnum pn title defaultChoice) (handler . inputRadioData) +inputRadio :: (Eq c, Show c, Typeable c) => PlayerNumber -> String -> [c] -> c -> Event (Input c) +inputRadio pn title cs _ = InputEv (Input pn title (Radio (zip cs (show <$> cs)))) --- | the same, suppress the event after first trigger -onInputRadioEnumOnce_ :: forall a. (Enum a, Bounded a, Typeable a, Eq a, Show a) => String -> a -> (a -> Nomex ()) -> PlayerNumber -> Nomex () -onInputRadioEnumOnce_ title defaultChoice handler pn = onEventOnce_ (inputRadioEnum pn title defaultChoice) (handler . inputRadioData) +inputRadioHead :: (Eq c, Show c, Typeable c) => PlayerNumber -> String -> [c] -> Event (Input c) +inputRadioHead pn title choices = inputRadio pn title choices (head choices) +inputRadioData :: (Show c) => EventData (Input c) -> c +inputRadioData (InputData (RadioData a)) = a +inputRadioData a = error $ "Not a Radio Data: " ++ show a -- ** Text inputs -inputText :: PlayerNumber -> String -> Event (Input String) -inputText pn title = InputEv (Input pn title Text) - -inputTextData :: EventData (Input String) -> String -inputTextData (InputData (TextData a)) = a -inputTextData a = error $ "Not a Text Data: " ++ (show a) - -- | triggers a string input to the user. The result will be sent to the callback onInputText :: String -> (EventNumber -> String -> Nomex ()) -> PlayerNumber -> Nomex EventNumber onInputText title handler pn = onEvent (inputText pn title) (\(en, a) -> handler en (inputTextData a)) -- | asks the player pn to answer a question, and feed the callback with this data. -onInputText_ :: String -> (String -> Nomex ()) -> PlayerNumber -> Nomex () +onInputText_ :: String -> (String -> Nomex ()) -> PlayerNumber -> Nomex EventNumber onInputText_ title handler pn = onEvent_ (inputText pn title) (handler . inputTextData) -- | asks the player pn to answer a question, and feed the callback with this data. onInputTextOnce :: String -> (String -> Nomex ()) -> PlayerNumber -> Nomex EventNumber onInputTextOnce title handler pn = onEventOnce (inputText pn title) (handler . inputTextData) ++inputText :: PlayerNumber -> String -> Event (Input String) +inputText pn title = InputEv (Input pn title Text) -onInputTextOnce_ :: String -> (String -> Nomex ()) -> PlayerNumber -> Nomex () -onInputTextOnce_ title handler pn = onEventOnce_ (inputText pn title) (handler . inputTextData) +inputTextData :: EventData (Input String) -> String +inputTextData (InputData (TextData a)) = a +inputTextData a = error $ "Not a Text Data: " ++ (show a) + -- ** Checkbox inputs -inputCheckboxData :: (Show c) => EventData (Input c) -> [c] -inputCheckboxData (InputData (CheckboxData a)) = a -inputCheckboxData a = error $ "Not a Checkbox Data: " ++ (show a) - -inputCheckbox :: (Eq c, Show c, Typeable c) => PlayerNumber -> String -> [(c, String)] -> Event (Input c) -inputCheckbox pn title cs = InputEv (Input pn title (Checkbox cs)) - onInputCheckbox :: (Typeable a, Eq a, Show a) => String -> [(a, String)] -> (EventNumber -> [a] -> Nomex ()) -> PlayerNumber -> Nomex EventNumber onInputCheckbox title choices handler pn = onEvent (inputCheckbox pn title choices) (\(en, InputData (CheckboxData a)) -> handler en a) -onInputCheckbox_ :: (Typeable a, Eq a, Show a) => String -> [(a, String)] -> ([a] -> Nomex ()) -> PlayerNumber -> Nomex () +onInputCheckbox_ :: (Typeable a, Eq a, Show a) => String -> [(a, String)] -> ([a] -> Nomex ()) -> PlayerNumber -> Nomex EventNumber onInputCheckbox_ title choices handler pn = onEvent_ (inputCheckbox pn title choices) (handler . inputCheckboxData) onInputCheckboxOnce :: (Typeable a, Eq a, Show a) => String -> [(a, String)] -> ([a] -> Nomex ()) -> PlayerNumber -> Nomex EventNumber onInputCheckboxOnce title choices handler pn = onEventOnce (inputCheckbox pn title choices) (handler . inputCheckboxData) - -onInputCheckboxOnce_ :: (Typeable a, Eq a, Show a) => String -> [(a, String)] -> ([a] -> Nomex ()) -> PlayerNumber -> Nomex () -onInputCheckboxOnce_ title choices handler pn = onEventOnce_ (inputCheckbox pn title choices) (handler . inputCheckboxData) ++inputCheckboxData :: (Show c) => EventData (Input c) -> [c] +inputCheckboxData (InputData (CheckboxData a)) = a +inputCheckboxData a = error $ "Not a Checkbox Data: " ++ show a +inputCheckbox :: (Eq c, Show c, Typeable c) => PlayerNumber -> String -> [(c, String)] -> Event (Input c) +inputCheckbox pn title cs = InputEv (Input pn title (Checkbox cs)) -- ** Button inputs -inputButtonData :: EventData (Input ()) -> () -inputButtonData (InputData ButtonData) = () -inputButtonData a = error $ "Not a Button Data: " ++ (show a) - -inputButton :: PlayerNumber -> String -> Event (Input ()) -inputButton pn title = InputEv (Input pn title Button) - onInputButton :: String -> (EventNumber -> () -> Nomex ()) -> PlayerNumber -> Nomex EventNumber onInputButton title handler pn = onEvent (inputButton pn title) (\(en, InputData ButtonData) -> handler en ()) -onInputButton_ :: String -> (() -> Nomex ()) -> PlayerNumber -> Nomex () +onInputButton_ :: String -> (() -> Nomex ()) -> PlayerNumber -> Nomex EventNumber onInputButton_ title handler pn = onEvent_ (inputButton pn title) (handler . inputButtonData) onInputButtonOnce :: String -> (() -> Nomex ()) -> PlayerNumber -> Nomex EventNumber onInputButtonOnce title handler pn = onEventOnce (inputButton pn title) (handler . inputButtonData) ++inputButtonData :: EventData (Input ()) -> () +inputButtonData (InputData ButtonData) = () +inputButtonData a = error $ "Not a Button Data: " ++ show a -onInputButtonOnce_ :: String -> (() -> Nomex ()) -> PlayerNumber -> Nomex () -onInputButtonOnce_ title handler pn = onEventOnce_ (inputButton pn title) (handler . inputButtonData) +inputButton :: PlayerNumber -> String -> Event (Input ()) +inputButton pn title = InputEv (Input pn title Button) -- ** Textarea inputs -inputTextareaData :: EventData (Input String) -> String -inputTextareaData (InputData (TextAreaData a)) = a -inputTextareaData a = error $ "Not a Textarea Data: " ++ (show a) - inputTextarea :: PlayerNumber -> String -> Event (Input String) inputTextarea pn title = InputEv (Input pn title TextArea) onInputTextarea :: String -> (EventNumber -> String -> Nomex ()) -> PlayerNumber -> Nomex EventNumber onInputTextarea title handler pn = onEvent (inputTextarea pn title) (\(en, a) -> handler en (inputTextareaData a)) -onInputTextarea_ :: String -> (String -> Nomex ()) -> PlayerNumber -> Nomex () +onInputTextarea_ :: String -> (String -> Nomex ()) -> PlayerNumber -> Nomex EventNumber onInputTextarea_ title handler pn = onEvent_ (inputTextarea pn title) (handler . inputTextareaData) onInputTextareaOnce :: String -> (String -> Nomex ()) -> PlayerNumber -> Nomex EventNumber onInputTextareaOnce title handler pn = onEventOnce (inputTextarea pn title) (handler . inputTextareaData) -onInputTextareaOnce_ :: String -> (String -> Nomex ()) -> PlayerNumber -> Nomex () -onInputTextareaOnce_ title handler pn = onEventOnce_ (inputTextarea pn title) (handler . inputTextareaData) - +inputTextareaData :: EventData (Input String) -> String +inputTextareaData (InputData (TextAreaData a)) = a +inputTextareaData a = error $ "Not a Textarea Data: " ++ show a
src/Language/Nomyx/Outputs.hs view
@@ -1,78 +1,82 @@+ +-- | All the building blocks to allow rules to produce outputs.+-- for example, you can display a message like this:+-- do+-- outputAll_ "hello, world!" --- | All the building blocks to allow rules to produce outputs. -module Language.Nomyx.Outputs where --- OutputNumber,--- newOutput, newOutput_,--- outputAll, outputAll_, outputAll', --- getOutput, getOutput_, --- updateOutput, updateOutput_, --- delOutput, delOutput_, --- displayVar, displaySimpleVar, --- displayArrayVar, showArrayVar,+module Language.Nomyx.Outputs ( + OutputNumber,+ newOutput, newOutput_,+ outputAll, outputAll_, + getOutput, getOutput_, + updateOutput, + delOutput, + displayVar, displayVar',+ displaySimpleVar, + displayArrayVar+ ) where import Language.Nomyx.Expression import Language.Nomyx.Variables import Data.Typeable -import Control.Monad.State +import Control.Monad.State+import Control.Applicative -- * Outputs -- | outputs a message to one player -newOutput :: Nomex String -> (Maybe PlayerNumber) -> Nomex OutputNumber -newOutput ns mpn = ns >>= NewOutput mpn - -newOutput_ :: Nomex String -> (Maybe PlayerNumber) -> Nomex () -newOutput_ ns pn = void $ newOutput ns pn +newOutput :: Maybe PlayerNumber -> NomexNE String -> Nomex OutputNumber +newOutput = NewOutput ++-- | outputs a message to one player +newOutput_ :: Maybe PlayerNumber -> String -> Nomex OutputNumber +newOutput_ ns mpn = NewOutput ns (return mpn) -- | output a message to all players -outputAll :: Nomex String -> Nomex OutputNumber -outputAll ns = newOutput ns Nothing - -outputAll_ :: Nomex String -> Nomex () -outputAll_ ns = newOutput_ ns Nothing - -outputAll' :: String -> Nomex () -outputAll' s = newOutput_ (return s) Nothing - -getOutput :: OutputNumber -> Nomex (Maybe String) -getOutput on = GetOutput on - +outputAll :: NomexNE String -> Nomex OutputNumber +outputAll = newOutput Nothing ++-- | output a constant message to all players +outputAll_ :: String -> Nomex () +outputAll_ s = void $ newOutput Nothing (return s) ++-- | get an output by number +getOutput :: OutputNumber -> NomexNE (Maybe String) +getOutput = GetOutput ++-- | get an output by number, partial version getOutput_ :: OutputNumber -> Nomex String -getOutput_ on = partial "getOutput_ : Output number not existing" $ getOutput on - -updateOutput :: OutputNumber -> Nomex String -> Nomex Bool -updateOutput on ns = ns >>= UpdateOutput on - -updateOutput_ :: OutputNumber -> Nomex String -> Nomex () -updateOutput_ on ns = void $ updateOutput on ns - +getOutput_ on = partial "getOutput_ : Output number not existing" $ liftEffect $ getOutput on ++-- | update an output +updateOutput :: OutputNumber -> NomexNE String -> Nomex Bool +updateOutput = UpdateOutput ++-- | delete an output delOutput :: OutputNumber -> Nomex Bool delOutput = DelOutput - -delOutput_ :: OutputNumber -> Nomex () -delOutput_ on = void $ delOutput on - --- permanently display a variable (update display when variable is updated) -displayVar :: (Typeable a, Show a, Eq a) => (Maybe PlayerNumber) -> MsgVar a -> (a -> Nomex String) -> Nomex () -displayVar mpn mv dis = onMsgVarEvent - mv - (\a -> newOutput (dis a) mpn) - (\a n -> updateOutput_ n (dis a)) - delOutput_ - -displaySimpleVar :: (Typeable a, Show a, Eq a) => (Maybe PlayerNumber) -> Nomex String -> MsgVar a -> Nomex () -displaySimpleVar mpn ntitle mv = do - let title a = do - t <- ntitle - return $ (t ++ ": " ++ (show a) ++ "\n") - displayVar mpn mv title - -displayArrayVar :: (Typeable a, Show a, Eq a, Typeable i, Show i, Eq i) => (Maybe PlayerNumber) -> Nomex String -> ArrayVar i a -> Nomex () -displayArrayVar mpn ntitle mv = displayVar mpn mv (showArrayVar ntitle) - -showArrayVar :: (Show a, Show i) => Nomex String -> [(i,a)] -> Nomex String -showArrayVar title l = do - t <- title - return $ t ++ "\n" ++ concatMap (\(i,a) -> (show i) ++ "\t" ++ (show a) ++ "\n") l + +-- permanently display a variable +displayVar :: (Typeable a, Show a, Eq a) => Maybe PlayerNumber -> MsgVar a -> (Maybe a -> NomexNE String) -> Nomex OutputNumber +displayVar mpn mv dis = do+ on <- newOutput mpn $ readMsgVar mv >>= dis+ onMsgVarDelete mv (void $ delOutput on)+ return on+++-- permanently display a variable +displayVar' :: (Typeable a, Show a, Eq a) => Maybe PlayerNumber -> MsgVar a -> (a -> NomexNE String) -> Nomex OutputNumber +displayVar' mpn mv dis = displayVar mpn mv dis' where+ dis' Nothing = return $ "Variable " ++ getMsgVarName mv ++ " deleted"+ dis' (Just a) = (++ "\n") <$> dis a+ +displaySimpleVar :: (Typeable a, Show a, Eq a) => Maybe PlayerNumber -> MsgVar a -> String -> Nomex OutputNumber +displaySimpleVar mpn mv title = displayVar' mpn mv showVar where+ showVar a = return $ title ++ ": " ++ (show a) ++ "\n" +displayArrayVar :: (Typeable a, Show a, Eq a, Typeable i, Show i, Eq i) => Maybe PlayerNumber -> ArrayVar i a -> String -> Nomex OutputNumber +displayArrayVar mpn mv title = displayVar' mpn mv (showArrayVar title) where++showArrayVar :: (Typeable a, Show a, Eq a, Typeable i, Show i, Eq i) => String -> [(i, a)] -> NomexNE String+showArrayVar title l = return $ title ++ "\n" ++ concatMap (\(i,a) -> show i ++ "\t" ++ show a ++ "\n") l
src/Language/Nomyx/Players.hs view
@@ -1,26 +1,33 @@-{-# LANGUAGE GADTs, ScopedTypeVariables, TupleSections #-} +{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-} --- | All the building blocks to allow rules to manage players. -module Language.Nomyx.Players where--- PlayerNumber,--- PlayerName,--- PlayerInfo(..),--- Player(..),--- playerNumber, playerName,--- getPlayers, getPlayer, getPlayerName, --- setPlayerName, --- modifyPlayerName, --- getPlayersNumber, getAllPlayerNumbers, --- delPlayer,--- forEachPlayer, forEachPlayer_,--- createValueForEachPlayer, createValueForEachPlayer_,--- getValueOfPlayer,--- modifyValueOfPlayer, modifyAllValues,--- showPlayer,--- getSelfProposedByPlayer,--- setVictory, --- giveVictory,+-- | All the building blocks to allow rules to manage players.+-- for example, you can change the name of player 1 with:+-- do+-- void $ modifyPlayerName 1 ("King " ++) +module Language.Nomyx.Players (+ PlayerNumber,+ PlayerName,+ PlayerInfo(..),+ Player(..),+ playerNumber, playerName,+ getPlayers, getPlayer, getPlayerName, + setPlayerName, + modifyPlayerName, + getPlayersNumber, getAllPlayerNumbers, + delPlayer,+ forEachPlayer, forEachPlayer_,+ createValueForEachPlayer, createValueForEachPlayer_,+ getValueOfPlayer,+ modifyValueOfPlayer, modifyAllValues,+ showPlayer,+ getProposerNumber, getProposerNumber_,+ setVictory, + giveVictory+ ) where+ import Language.Nomyx.Expression import Language.Nomyx.Events import Language.Nomyx.Variables@@ -30,21 +37,22 @@ import Data.Lens import Control.Applicative import Control.Arrow+import Control.Monad -- * Players -- | get all the players -getPlayers :: Nomex [PlayerInfo] +getPlayers :: NomexNE [PlayerInfo] getPlayers = GetPlayers -- | Get a specific player -getPlayer :: PlayerNumber -> Nomex (Maybe PlayerInfo) +getPlayer :: PlayerNumber -> NomexNE (Maybe PlayerInfo) getPlayer pn = do pls <- GetPlayers return $ find ((== pn) . getL playerNumber) pls -- | Set the name of a player -getPlayerName :: PlayerNumber -> Nomex (Maybe PlayerName) +getPlayerName :: PlayerNumber -> NomexNE (Maybe PlayerName) getPlayerName pn = do p <- getPlayer pn return $ _playerName <$> p @@ -55,18 +63,18 @@ modifyPlayerName :: PlayerNumber -> (PlayerName -> PlayerName) -> Nomex Bool modifyPlayerName pn f = do - mn <- getPlayerName pn + mn <- liftEffect $ getPlayerName pn case mn of Just name -> setPlayerName pn (f name) Nothing -> return False -- | Get the total number of players -getPlayersNumber :: Nomex Int +getPlayersNumber :: NomexNE Int getPlayersNumber = length <$> getPlayers -- | Get all the players number -getAllPlayerNumbers :: Nomex [PlayerNumber] +getAllPlayerNumbers :: NomexNE [PlayerNumber] getAllPlayerNumbers = map _playerNumber <$> getPlayers -- | Remove the player from the game (kick) @@ -75,61 +83,68 @@ -- | perform an action for each current players, new players and leaving players-forEachPlayer :: (PlayerNumber -> Nomex ()) -> (PlayerNumber -> Nomex ()) -> (PlayerNumber -> Nomex ()) -> Nomex ()+-- returns the event numbers for arriving players and leaving players+forEachPlayer :: (PlayerNumber -> Nomex ()) -> (PlayerNumber -> Nomex ()) -> (PlayerNumber -> Nomex ()) -> Nomex (EventNumber, EventNumber) forEachPlayer action actionWhenArrive actionWhenLeave = do- pns <- getAllPlayerNumbers+ pns <- liftEffect getAllPlayerNumbers mapM_ action pns- onEvent_ (Player Arrive) $ \(PlayerData p) -> actionWhenArrive $ _playerNumber p- onEvent_ (Player Leave) $ \(PlayerData p) -> actionWhenLeave $ _playerNumber p+ an <- onEvent_ (Player Arrive) $ \(PlayerData p) -> actionWhenArrive $ _playerNumber p+ ln <- onEvent_ (Player Leave) $ \(PlayerData p) -> actionWhenLeave $ _playerNumber p+ return (an, ln) -- | perform the same action for each players, including new players-forEachPlayer_ :: (PlayerNumber -> Nomex ()) -> Nomex ()+-- returns the event numbers for arriving players and leaving players+forEachPlayer_ :: (PlayerNumber -> Nomex ()) -> Nomex (EventNumber, EventNumber) forEachPlayer_ action = forEachPlayer action action (\_ -> return ()) -- | create a value initialized for each players --manages players joining and leaving-createValueForEachPlayer :: forall a. (Typeable a, Show a, Eq a) => a -> MsgVar [(PlayerNumber, a)] -> Nomex ()+createValueForEachPlayer :: forall a. (Typeable a, Show a, Eq a) => a -> MsgVar [(PlayerNumber, a)] -> Nomex (EventNumber, EventNumber) createValueForEachPlayer initialValue mv = do- pns <- getAllPlayerNumbers+ pns <- liftEffect getAllPlayerNumbers v <- newMsgVar_ (getMsgVarName mv) $ map (,initialValue::a) pns forEachPlayer (const $ return ())- (\p -> modifyMsgVar v ((p, initialValue) : ))- (\p -> modifyMsgVar v $ filter $ (/= p) . fst)+ (\p -> void $ modifyMsgVar v ((p, initialValue) : ))+ (\p -> void $ modifyMsgVar v $ filter $ (/= p) . fst) -- | create a value initialized for each players initialized to zero --manages players joining and leaving-createValueForEachPlayer_ :: MsgVar [(PlayerNumber, Int)] -> Nomex ()+createValueForEachPlayer_ :: MsgVar [(PlayerNumber, Int)] -> Nomex (EventNumber, EventNumber) createValueForEachPlayer_ = createValueForEachPlayer 0 -getValueOfPlayer :: forall a. (Typeable a, Show a, Eq a) => PlayerNumber -> MsgVar [(PlayerNumber, a)] -> Nomex (Maybe a)+getValueOfPlayer :: forall a. (Typeable a, Show a, Eq a) => PlayerNumber -> MsgVar [(PlayerNumber, a)] -> NomexNE (Maybe a) getValueOfPlayer pn var = do- value <- readMsgVar_ var- return $ lookup pn value+ mvalue <- readMsgVar var+ return $ do+ value <- mvalue+ lookup pn value -modifyValueOfPlayer :: (Eq a, Show a, Typeable a) => PlayerNumber -> MsgVar [(PlayerNumber, a)] -> (a -> a) -> Nomex ()-modifyValueOfPlayer pn var f = modifyMsgVar var $ map $ (\(a,b) -> if a == pn then (a, f b) else (a,b))+modifyValueOfPlayer :: (Eq a, Show a, Typeable a) => PlayerNumber -> MsgVar [(PlayerNumber, a)] -> (a -> a) -> Nomex Bool+modifyValueOfPlayer pn var f = modifyMsgVar var $ map (\(a,b) -> if a == pn then (a, f b) else (a,b)) modifyAllValues :: (Eq a, Show a, Typeable a) => MsgVar [(PlayerNumber, a)] -> (a -> a) -> Nomex ()-modifyAllValues var f = modifyMsgVar var $ map $ second f+modifyAllValues var f = void $ modifyMsgVar var $ map $ second f -- | show a player name based on his number-showPlayer :: PlayerNumber -> Nomex String+showPlayer :: PlayerNumber -> NomexNE String showPlayer pn = do mn <- getPlayerName pn case mn of Just name -> return name- Nothing -> return ("Player " ++ (show pn))+ Nothing -> return ("Player " ++ show pn) -- | set victory to a list of players -setVictory :: [PlayerNumber] -> Nomex () +setVictory :: NomexNE [PlayerNumber] -> Nomex () setVictory = SetVictory -- | give victory to one player giveVictory :: PlayerNumber -> Nomex () -giveVictory pn = SetVictory [pn] - - -getSelfProposedByPlayer :: Nomex PlayerNumber -getSelfProposedByPlayer = getSelfRule >>= return . _rProposedBy +giveVictory pn = SetVictory $ return [pn] +-- | get the player number of the proposer of the rule +getProposerNumber :: NomexNE PlayerNumber +getProposerNumber = _rProposedBy <$> getSelfRule ++getProposerNumber_ :: Nomex PlayerNumber +getProposerNumber_ = liftEffect getProposerNumber
src/Language/Nomyx/Rules.hs view
@@ -1,44 +1,48 @@+{-# LANGUAGE ScopedTypeVariables #-} --- | Basic rules examples.-module Language.Nomyx.Rules where--- RuleFunc,--- RuleResp(..),--- Rule(..),--- RuleNumber,--- RuleCode,--- RuleEvent(..),--- RuleStatus(..),--- voidRule,--- activateRule, activateRule_,--- rejectRule, rejectRule_,--- getRules, getActiveRules, getRule,--- getRulesByNumbers,--- getRuleFuncs,--- addRule, addRule_, addRuleParams,--- getFreeRuleNumber,--- suppressRule, suppressRule_, suppressAllRules,--- modifyRule,--- autoActivate,--- activateOrReject,--- noPlayPlayer,--- autoDelete,--- eraseAllRules,--- getSelfRuleNumber, getSelfRule,+-- | Basic rules building blocks.+-- for example, you can suppress rule 1 with:+--do+-- suppressRule 1 +module Language.Nomyx.Rules (+ RuleNumber,+ RuleCode,+ RuleEvent(..),+ RuleStatus(..),+ MetaRule,+ activateRule, activateRule_,+ rejectRule, rejectRule_,+ getRules, getActiveRules, getRule,+ getRulesByNumbers,+ getRuleFuncs,+ addRule, addRule_, addRuleParams,+ getFreeRuleNumber,+ suppressRule, suppressRule_, suppressAllRules,+ modifyRule,+ autoActivate,+ activateOrReject,+ simulate,+ metaruleVar, createMetaruleVar, addMetarule, testWithMetaRules,+ legal, illegal, noPlayPlayer, immutableRule,+ autoDelete,+ eraseAllRules,+ getSelfRuleNumber, getSelfRule,+ showRule+ ) where+ import Prelude hiding (foldr) import Language.Nomyx.Expression import Language.Nomyx.Events+import Language.Nomyx.Variables import Data.Lens import Control.Monad import Data.List import Data.Maybe---import Language.Nomyx.Utils+import Control.Applicative -- * Rule management -voidRule :: Nomex a -> Nomex RuleResp -voidRule e = e >> return Void- -- | activate a rule: change its state to Active and execute it activateRule :: RuleNumber -> Nomex Bool activateRule = ActivateRule@@ -54,39 +58,39 @@ rejectRule_ :: RuleNumber -> Nomex () rejectRule_ r = void $ rejectRule r -getRules :: Nomex [Rule]+getRules :: NomexNE [RuleInfo] getRules = GetRules -getActiveRules :: Nomex [Rule]-getActiveRules = return . (filter ((== Active) . _rStatus) ) =<< getRules+getActiveRules :: NomexNE [RuleInfo]+getActiveRules = filter ((== Active) . _rStatus) <$> getRules -getRule :: RuleNumber -> Nomex (Maybe Rule)+getRule :: RuleNumber -> NomexNE (Maybe RuleInfo) getRule rn = do rs <- GetRules return $ find ((== rn) . getL rNumber) rs -getRulesByNumbers :: [RuleNumber] -> Nomex [Rule]+getRulesByNumbers :: [RuleNumber] -> NomexNE [RuleInfo] getRulesByNumbers rns = mapMaybeM getRule rns -getRuleFuncs :: Nomex [RuleFunc]-getRuleFuncs = return . (map _rRuleFunc) =<< getRules+getRuleFuncs :: NomexNE [Nomex ()]+getRuleFuncs = map _rRule <$> getRules -- | add a rule to the game, it will have to be activated-addRule :: Rule -> Nomex Bool+addRule :: RuleInfo -> Nomex Bool addRule r = AddRule r -addRule_ :: Rule -> Nomex ()+addRule_ :: RuleInfo -> Nomex () addRule_ r = void $ AddRule r --TODO: too permissive. Should use SubmitRule instead.-addRuleParams :: RuleName -> RuleFunc -> RuleCode -> String -> Nomex RuleNumber-addRuleParams name func code desc = do- number <- getFreeRuleNumber- res <- addRule $ defaultRule {_rName = name, _rRuleFunc = func, _rRuleCode = code, _rNumber = number, _rDescription = desc}+addRuleParams :: RuleName -> Rule -> RuleCode -> String -> Nomex RuleNumber+addRuleParams name rule code desc = do+ number <- liftEffect getFreeRuleNumber+ res <- addRule $ defaultRule {_rName = name, _rRule = rule, _rRuleCode = code, _rNumber = number, _rDescription = desc} return $ if res then number else error "addRuleParams: cannot add rule" -getFreeRuleNumber :: Nomex RuleNumber+getFreeRuleNumber :: NomexNE RuleNumber getFreeRuleNumber = do rs <- getRules return $ getFreeNumber $ map _rNumber rs@@ -103,97 +107,103 @@ suppressAllRules :: Nomex Bool suppressAllRules = do- rs <- getRules+ rs <- liftEffect getRules res <- mapM (suppressRule . _rNumber) rs return $ and res -modifyRule :: RuleNumber -> Rule -> Nomex Bool+modifyRule :: RuleNumber -> RuleInfo -> Nomex Bool modifyRule rn r = ModifyRule rn r -- | This rule will activate automatically any new rule.-autoActivate :: RuleFunc-autoActivate = voidRule $ onEvent_ (RuleEv Proposed) (activateRule_ . _rNumber . ruleData)+autoActivate :: Nomex ()+autoActivate = void $ onEvent_ (RuleEv Proposed) (activateRule_ . _rNumber . ruleData) --- | This rule will forbid any new rule to delete the rule in parameter---immutableRule :: RuleNumber -> RuleFunc---immutableRule rn = return $ Meta f where--- f r = do--- protectedRule <- getRule rn--- case protectedRule of--- Just pr -> case _rRuleFunc r of--- RuleRule paramRule -> paramRule pr--- _ -> return $ BoolResp True--- Nothing -> return $ BoolResp True+-- * Meta Rules +type MetaRule = RuleInfo -> NomexNE Bool++metaruleVar :: MsgVar [MetaRule]+metaruleVar = msgVar "metarules"++createMetaruleVar :: Nomex ()+createMetaruleVar = void $ newMsgVar (getMsgVarName metaruleVar) ([] :: [MetaRule])++addMetarule :: MetaRule -> Nomex ()+addMetarule mr = void $ modifyMsgVar metaruleVar (mr:)++testWithMetaRules :: RuleInfo -> NomexNE Bool+testWithMetaRules r = do+ mmrs <- readMsgVar metaruleVar+ case mmrs of+ Just mrs -> do+ bs <- sequence $ map (\mr -> mr r) mrs+ return $ and bs+ Nothing -> return $ False+ -- | A rule will be always legal-legal :: RuleFunc-legal = return $ Meta (\_ -> return $ BoolResp True)+legal :: Nomex ()+legal = addMetarule (const $ return True) -- | A rule will be always illegal-illegal :: RuleFunc-illegal = return $ Meta (\_ -> return $ BoolResp False)+illegal :: Nomex ()+illegal = addMetarule (const $ return False) --- | active metarules are automatically used to evaluate a given rule---checkWithMetarules :: Rule -> Nomex (Event (Message ForAgainst)---checkWithMetarules rule = do--- rs <- getActiveRules--- (metas :: [Rule -> Nomex BoolResp]) <- mapMaybeM maybeMetaRule rs--- let (evals :: [Nomex BoolResp]) = map (\meta -> meta rule) metas--- foldr (&&*) true evals +-- | Player p cannot propose any more rules+noPlayPlayer :: PlayerNumber -> MetaRule+noPlayPlayer pn rule = return $ (_rProposedBy rule) /= pn -maybeMetaRule :: Rule -> Nomex (Maybe (Rule -> Nomex BoolResp))-maybeMetaRule Rule {_rRuleFunc = rule} = do- meta <- rule- case meta of- (Meta m) -> return $ Just m- _ -> return Nothing+-- | rule number rn cannot be deleted by any incoming rule+-- we simulate the execution of an incoming rule to make sure it doesn't delete the immutable rule+immutableRule :: RuleNumber -> MetaRule+immutableRule rn = \rule -> do+ immu <- getRule rn+ maybe (return True) (const $ simulate (_rRule rule) (isJust <$> getRule rn)) immu +-- | simulate the execution of rule "sim" and then run rule "test" over the result+simulate :: Nomex a -> NomexNE Bool -> NomexNE Bool+simulate sim test = Simu sim test -- | activate or reject a rule-activateOrReject :: Rule -> Bool -> Nomex ()+activateOrReject :: RuleInfo -> Bool -> Nomex () activateOrReject r b = if b then activateRule_ (_rNumber r) else rejectRule_ (_rNumber r) ---- | Player p cannot propose anymore rules-noPlayPlayer :: PlayerNumber -> RuleFunc-noPlayPlayer p = return $ Meta $ \r -> return $ BoolResp $ (_rProposedBy r) /= p- -- | a rule can autodelete itself (generaly after having performed some actions) autoDelete :: Nomex ()-autoDelete = getSelfRuleNumber >>= suppressRule_+autoDelete = liftEffect getSelfRuleNumber >>= suppressRule_ -- | All rules from player p are erased: eraseAllRules :: PlayerNumber -> Nomex Bool eraseAllRules p = do- rs <- getRules+ rs <- liftEffect $ getRules let myrs = filter ((== p) . getL rProposedBy) rs res <- mapM (suppressRule . _rNumber) myrs return $ and res -- | allows a rule to retrieve its own number (for auto-deleting for example) -getSelfRuleNumber :: Nomex RuleNumber +getSelfRuleNumber :: NomexNE RuleNumber getSelfRuleNumber = SelfRuleNumber -getSelfRule :: Nomex Rule +getSelfRule :: NomexNE RuleInfo getSelfRule = do srn <- getSelfRuleNumber rs:[] <- getRulesByNumbers [srn] return rs -- | a default rule -defaultRule = Rule { +defaultRule = RuleInfo { _rNumber = 1, _rName = "", _rDescription = "", _rProposedBy = 0, _rRuleCode = "", - _rRuleFunc = return Void, + _rRule = return (), _rStatus = Pending, _rAssessedBy = Nothing} mapMaybeM :: (Monad m) => (a -> m (Maybe b)) -> [a] -> m [b] mapMaybeM f = liftM catMaybes . mapM f - ++showRule x = void $ NewOutput Nothing (return $ show x)
src/Language/Nomyx/Variables.hs view
@@ -1,25 +1,30 @@-{-# LANGUAGE DeriveDataTypeable, GADTs, ScopedTypeVariables #-} +{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-} --- | All the building blocks to allow rules to build variables. -module Language.Nomyx.Variables where--- V(..),--- VEvent(..), --- MsgVar(..), --- msgVar,--- newMsgVar, newMsgVar_, newMsgVar', --- writeMsgVar, writeMsgVar_, --- readMsgVar, readMsgVar_,--- modifyMsgVar, --- delMsgVar, --- onMsgVarEvent, onMsgVarChange, --- getMsgVarMessage, --- getMsgVarData, getMsgVarData_,--- getMsgVarName, --- ArrayVar, --- newArrayVar, newArrayVar_, newArrayVar', --- cleanOnFull, --- isFullArrayVar_, --- putArrayVar, putArrayVar_+-- | All the building blocks to allow rules to build variables.+-- for example, you can create a variable with:+--do+-- newMsgVar_ "MyMoney" (0::Int)+ +module Language.Nomyx.Variables (+ V(..),+ VEvent(..), + MsgVar(..),+ newVar, newVar_, readVar, readVar_, writeVar, modifyVar, delVar, + newMsgVar, newMsgVar_, readMsgVar, readMsgVar_, writeMsgVar, modifyMsgVar, delMsgVar,+ msgVar,+ newMsgVarOnEvent, + onMsgVarEvent, onMsgVarChange, onMsgVarDelete, + getMsgVarMessage, + getMsgVarData, getMsgVarData_,+ getMsgVarName, + ArrayVar, + newArrayVar, newArrayVar_, newArrayVar', newArrayVarOnce, + cleanOnFull, + isFullArrayVar_, + putArrayVar, putArrayVar_+ ) where import Language.Nomyx.Expression@@ -29,60 +34,54 @@ import Data.Maybe import qualified Data.Map as M import Data.Map hiding (map, filter, insert, mapMaybe, null) - +import Data.Foldable as F (mapM_) -- * Variables -- | variable creation -newVar :: (Typeable a, Show a, Eq a) => VarName -> a -> Nomex (Maybe (V a)) +newVar :: (Typeable a, Show a) => VarName -> a -> Nomex (Maybe (V a)) newVar = NewVar -newVar_ :: (Typeable a, Show a, Eq a) => VarName -> a -> Nomex (V a) +newVar_ :: (Typeable a, Show a) => VarName -> a -> Nomex (V a) newVar_ s a = partial "newVar_: Variable existing" (newVar s a) -- | variable reading -readVar :: (Typeable a, Show a, Eq a) => (V a) -> Nomex (Maybe a) +readVar :: (Typeable a, Show a) => V a -> NomexNE (Maybe a) readVar = ReadVar -readVar_ :: forall a. (Typeable a, Show a, Eq a) => (V a) -> Nomex a -readVar_ v@(V a) = partial ("readVar_: Variable \"" ++ a ++ "\" with type \"" ++ (show $ typeOf v) ++ "\" not existing") (readVar v) +readVar_ :: (Typeable a, Show a) => V a -> Nomex a +readVar_ v@(V a) = partial ("readVar_: Variable \"" ++ a ++ "\" with type \"" ++ (show $ typeOf v) ++ "\" not existing") (liftEffect $ readVar v) -- | variable writing -writeVar :: (Typeable a, Show a, Eq a) => (V a) -> a -> Nomex Bool +writeVar :: (Typeable a, Show a) => V a -> a -> Nomex Bool writeVar = WriteVar -writeVar_ :: (Typeable a, Show a, Eq a) => (V a) -> a -> Nomex () -writeVar_ var val = void $ writeVar var val - -- | modify a variable using the provided function -modifyVar :: (Typeable a, Show a, Eq a) => (V a) -> (a -> a) -> Nomex () -modifyVar v f = writeVar_ v . f =<< readVar_ v +modifyVar :: (Typeable a, Show a) => V a -> (a -> a) -> Nomex Bool +modifyVar v f = writeVar v . f =<< readVar_ v -- | delete variable -delVar :: (V a) -> Nomex Bool +delVar :: V a -> Nomex Bool delVar = DelVar -delVar_ :: (V a) -> Nomex () -delVar_ v = void $ delVar v - -- * Message Variable -- | a MsgVar is a variable with a message attached, allowing to trigger registered functions anytime the var if modified data VEvent a = VUpdated a | VDeleted deriving (Typeable, Show, Eq) -data MsgVar a = MsgVar {message :: (Msg (VEvent a)), variable :: (V a) } +data MsgVar a = MsgVar {message :: Msg (VEvent a), variable :: V a } msgVar :: String -> MsgVar a msgVar a = MsgVar (Message a) (V a) -newMsgVar :: (Typeable a, Show a, Eq a) => VarName -> a -> Nomex (Maybe (MsgVar a)) +newMsgVar :: (Typeable a, Show a) => VarName -> a -> Nomex (Maybe (MsgVar a)) newMsgVar name a = do mv <- newVar name a return $ mv >>= Just . MsgVar (Message name) -newMsgVar_ :: (Typeable a, Show a, Eq a) => VarName -> a -> Nomex (MsgVar a) +newMsgVar_ :: (Typeable a, Show a) => VarName -> a -> Nomex (MsgVar a) newMsgVar_ name a = partial "newMsgVar_: Variable existing" (newMsgVar name a) - -newMsgVar' :: (Typeable a, Show a, Eq a) => VarName -> a -> (VEvent a -> Nomex()) -> Nomex (Maybe (MsgVar a)) -newMsgVar' name a f = do +-- | create a new MsgVar and register callback in case of change (update, delete) +newMsgVarOnEvent :: (Typeable a, Show a) => VarName -> a -> (VEvent a -> Nomex ()) -> Nomex (Maybe (MsgVar a)) +newMsgVarOnEvent name a f = do mv <- newMsgVar name a case mv of Just (MsgVar m _) -> do @@ -90,23 +89,20 @@ return mv Nothing -> return Nothing -writeMsgVar :: (Typeable a, Show a, Eq a) => MsgVar a -> a -> Nomex Bool +writeMsgVar :: (Typeable a, Show a) => MsgVar a -> a -> Nomex Bool writeMsgVar (MsgVar m v) a = do r <- writeVar v a sendMessage m (VUpdated a) return r -writeMsgVar_ :: (Typeable a, Show a, Eq a) => MsgVar a -> a -> Nomex () -writeMsgVar_ mv a = void $ writeMsgVar mv a - -readMsgVar :: (Typeable a, Show a, Eq a) => MsgVar a -> Nomex (Maybe a) +readMsgVar :: (Typeable a, Show a) => MsgVar a -> NomexNE (Maybe a) readMsgVar (MsgVar _ v) = readVar v -readMsgVar_ :: (Typeable a, Show a, Eq a) => MsgVar a -> Nomex a -readMsgVar_ mv = partial "readMsgVar_: variable not existing" (readMsgVar mv) +readMsgVar_ :: (Typeable a, Show a) => MsgVar a -> Nomex a +readMsgVar_ mv = partial "readMsgVar_: variable not existing" (liftEffect $ readMsgVar mv) -modifyMsgVar :: (Typeable a, Show a, Eq a) => MsgVar a -> (a -> a) -> Nomex () -modifyMsgVar mv f = writeMsgVar_ mv . f =<< readMsgVar_ mv +modifyMsgVar :: (Typeable a, Show a) => MsgVar a -> (a -> a) -> Nomex Bool +modifyMsgVar mv f = writeMsgVar mv . f =<< readMsgVar_ mv delMsgVar :: (Typeable a, Show a, Eq a) => MsgVar a -> Nomex Bool delMsgVar (MsgVar m v) = do @@ -114,36 +110,42 @@ delAllEvents m delVar v -onMsgVarChange :: (Typeable a, Show a, Eq a) => MsgVar a -> (VEvent a -> Nomex()) -> Nomex () -onMsgVarChange mv f = do - m <- getMsgVarMessage mv +onMsgVarEvent :: (Typeable a, Show a) => MsgVar a -> (VEvent a -> Nomex ()) -> Nomex EventNumber +onMsgVarEvent mv f = do + m <- liftEffect $ getMsgVarMessage mv onMessage m $ \(MessageData v) -> f v - -onMsgVarEvent :: (Typeable a, Show a, Eq a) - => MsgVar a - -> (a -> Nomex b) - -> (a -> b -> Nomex()) - -> (b -> Nomex()) - -> Nomex () -onMsgVarEvent mv create update delete = do ++-- | adds a callback for each of the MsgVar events: Create, Update, Delete +onMsgVarChange :: (Typeable a, Show a) + => MsgVar a -- ^ the MsgVar + -> (a -> Nomex b) -- ^ callback on creation (called immediatly) + -> (a -> b -> Nomex ()) -- ^ callback on update + -> (b -> Nomex ()) -- ^ callback on delete + -> Nomex EventNumber -- ^ event number generated for update and delete +onMsgVarChange mv create update delete = do val <- readMsgVar_ mv c <- create val - onMsgVarChange mv $ f c where + onMsgVarEvent mv $ f c where f c' (VUpdated v) = update v c' f c' VDeleted = delete c' ++onMsgVarDelete :: (Typeable a, Show a, Eq a) => MsgVar a -> Nomex () -> Nomex EventNumber+onMsgVarDelete mv f = onMsgVarEvent mv onMsgVarDel where+ onMsgVarDel VDeleted = f+ onMsgVarDel _ = return () -- | get the messsage triggered when the array is filled -getMsgVarMessage :: (Typeable a, Show a, Eq a) => (MsgVar a) -> Nomex (Msg (VEvent a)) +getMsgVarMessage :: (Typeable a, Show a) => MsgVar a -> NomexNE (Msg (VEvent a)) getMsgVarMessage (MsgVar m _) = return m -- | get the association array -getMsgVarData :: (Typeable a, Show a, Eq a) => (MsgVar a) -> Nomex (Maybe a) +getMsgVarData :: (Typeable a, Show a) => MsgVar a -> NomexNE (Maybe a) getMsgVarData (MsgVar _ v) = readVar v -getMsgVarData_ :: (Typeable a, Show a, Eq a) => (MsgVar a) -> Nomex a +getMsgVarData_ :: (Typeable a, Show a) => MsgVar a -> Nomex a getMsgVarData_ (MsgVar _ v) = readVar_ v -getMsgVarName :: (Typeable a, Show a, Eq a) => (MsgVar a) -> String +getMsgVarName :: (Typeable a, Show a) => MsgVar a -> String getMsgVarName (MsgVar _ (V varName)) = varName @@ -153,53 +155,52 @@ type ArrayVar i a = MsgVar [(i, Maybe a)] -- | initialize an empty ArrayVar -newArrayVar :: (Typeable a, Show a, Eq a, Typeable i, Show i, Eq i) => VarName -> [i] -> Nomex (Maybe (ArrayVar i a)) +newArrayVar :: (Typeable a, Show a, Typeable i, Show i) => VarName -> [i] -> Nomex (Maybe (ArrayVar i a)) newArrayVar name l = do let list = map (\i -> (i, Nothing)) l newMsgVar name list -newArrayVar_ :: (Typeable a, Show a, Eq a, Typeable i, Show i, Eq i) => VarName -> [i] -> Nomex (ArrayVar i a) +newArrayVar_ :: (Typeable a, Show a, Typeable i, Show i) => VarName -> [i] -> Nomex (ArrayVar i a) newArrayVar_ name l = partial "newArrayVar_: Variable existing" (newArrayVar name l) -- | initialize an empty ArrayVar, registering a callback that will be triggered at every change -newArrayVar' :: (Typeable a, Show a, Eq a, Typeable i, Show i, Eq i) => VarName -> [i] -> (VEvent [(i,Maybe a)] -> Nomex ()) -> Nomex (Maybe (ArrayVar i a)) +newArrayVar' :: (Typeable a, Show a, Typeable i, Show i) => VarName -> [i] -> (VEvent [(i,Maybe a)] -> Nomex ()) -> Nomex (Maybe (ArrayVar i a)) newArrayVar' name l f = do let list = map (\i -> (i, Nothing)) l - newMsgVar' name list f + newMsgVarOnEvent name list f -- | initialize an empty ArrayVar, registering a callback. -- the ArrayVar will be deleted when full -newArrayVarOnce :: (Ord i, Typeable a, Show a, Eq a, Typeable i, Show i) => VarName -> [i] -> (VEvent [(i, Maybe a)] -> Nomex ()) -> Nomex (Maybe (ArrayVar i a)) +newArrayVarOnce :: (Typeable a, Show a, Eq a, Typeable i, Show i, Ord i) => VarName -> [i] -> (VEvent [(i, Maybe a)] -> Nomex ()) -> Nomex (Maybe (ArrayVar i a)) newArrayVarOnce name l f = do - mv <- newArrayVar' name l f - when (isJust mv) $ cleanOnFull $ fromJust mv + mv <- newArrayVar' name l f+ F.mapM_ cleanOnFull mv return mv -cleanOnFull :: (Typeable a, Show a, Eq a, Ord i, Typeable i, Show i) => (ArrayVar i a) -> Nomex () +cleanOnFull :: (Typeable a, Show a, Eq a, Typeable i, Show i, Ord i) => ArrayVar i a -> Nomex () cleanOnFull ar = do - m <- getMsgVarMessage ar + m <- liftEffect $ getMsgVarMessage ar onMessage m $ \_ -> do - full <- (isFullArrayVar_ ar) + full <- liftEffect $ isFullArrayVar_ ar when full $ void $ delMsgVar ar return () return () -isFullArrayVar_ :: (Ord i, Typeable a, Show a, Eq a, Typeable i, Show i) => (ArrayVar i a) -> Nomex Bool +isFullArrayVar_ :: (Typeable a, Show a, Typeable i, Show i, Ord i) => ArrayVar i a -> NomexNE Bool isFullArrayVar_ av = do md <- getMsgVarData av - return $ and $ map isJust $ map snd $ fromJust md - + return $ all isJust (map snd $ fromJust md) -- | store one value and the given index. If this is the last filled element, the registered callbacks are triggered. -putArrayVar :: (Ord i, Typeable a, Show a, Eq a, Typeable i, Show i) => (ArrayVar i a) -> i -> a -> Nomex Bool +putArrayVar :: (Typeable a, Show a, Eq a, Typeable i, Show i, Eq i, Ord i) => ArrayVar i a -> i -> a -> Nomex Bool putArrayVar mv i a = do - ma <- readMsgVar mv + ma <- liftEffect $ readMsgVar mv case ma of Just ar -> do let ar2 = M.insert i (Just a) (fromList ar) writeMsgVar mv (toList ar2) Nothing -> return False -putArrayVar_ :: (Ord i, Typeable a, Show a, Eq a, Typeable i, Show i) => (ArrayVar i a) -> i -> a -> Nomex () +putArrayVar_ :: (Typeable a, Show a, Eq a, Typeable i, Show i, Ord i) => ArrayVar i a -> i -> a -> Nomex () putArrayVar_ mv i a = void $ putArrayVar mv i a
src/Language/Nomyx/Vote.hs view
@@ -1,5 +1,9 @@-{-# LANGUAGE ScopedTypeVariables, FlexibleInstances, TypeFamilies, FlexibleContexts,- DeriveDataTypeable, GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GADTs #-} -- | Voting system module Language.Nomyx.Vote where @@ -18,7 +22,6 @@ import Data.Time hiding (getCurrentTime) import Control.Arrow import Control.Applicative ---import Language.Nomyx.Utils import Data.List import Data.Function import qualified Data.Map as M@@ -36,9 +39,9 @@ exclusiveWinner :: a -> Maybe (Alts a, Alts a) --The Votable as only two alternatives, one excluding the other exclusiveWinner _ = Nothing -type ForAgainst = Alts Rule -instance Votable Rule where- data Alts Rule = For | Against deriving (Typeable, Enum, Show, Eq, Bounded, Read, Ord)+type ForAgainst = Alts RuleInfo +instance Votable RuleInfo where+ data Alts RuleInfo = For | Against deriving (Typeable, Enum, Show, Eq, Bounded, Read, Ord) alts = [For, Against] quota For q _ = q quota Against q vs = vs - q + 1@@ -54,9 +57,12 @@ data VoteData a = VoteData { msgEnd :: Msg [Alts a], -- message sent when the vote is finished with the winners voteVar :: ArrayVar PlayerNumber (Alts a),-- variable containing the votes inputNumbers :: [EventNumber], -- numbers of the toggle inputs of the players (to delete them at the end of vote) - assessFunction :: VoteResult a} -- function used to count the votes + assessFunction :: VoteResult a, -- function used to count the votes+ timeLimit :: Maybe UTCTime} -- end of the vote+ type Assessor a = StateT (VoteData a) Nomex () +--TODO: decorelate effects and non effects -- | Perform a vote. voteWith :: (Votable a) => VoteResult a -- ^ the function used to count the votes. -> Assessor a -- ^ assessors: when and how to perform the vote assessment (several assessors can be chained).@@ -64,7 +70,7 @@ -> [Alts a] -- ^ the vote alternatives. -> Nomex (Msg [Alts a]) -- ^ return value: a message containing the result of the vote. voteWith countVotes assessors toVote als = do - pns <- getAllPlayerNumbers + pns <- liftEffect getAllPlayerNumbers let toVoteName = name toVote let msgEnd = Message ("Result of votes for " ++ toVoteName) :: Msg [Alts a] --create an array variable to store the votes @@ -72,7 +78,7 @@ --create the voting buttons let askPlayer pn = onInputRadioOnce ("Vote for " ++ toVoteName ++ ":") als (putArrayVar_ voteVar pn) pn inputs <- mapM askPlayer pns - let voteData = VoteData msgEnd voteVar inputs countVotes + let voteData = VoteData msgEnd voteVar inputs countVotes Nothing --set the assessors evalStateT assessors voteData --display the vote@@ -90,56 +96,51 @@ -- | assess the vote on every new vote with the assess function, and as soon as the vote has an issue (positive of negative), sends a signal assessOnEveryVote :: (Votable a) => Assessor a assessOnEveryVote = do - (VoteData msgEnd voteVar _ assess) <- get - lift $ do - onMsgVarChange voteVar $ f assess msgEnd where- f assess msgEnd (VUpdated votes) = do- let res = assess $ getVoteStats votes False- when (not $ null res) $ sendMessage msgEnd res- f _ _ _ = return () + (VoteData msgEnd voteVar _ assess _) <- get + lift $ void $ onMsgVarEvent voteVar $ f assess msgEnd where+ f assess msgEnd (VUpdated votes) = do+ let res = assess $ getVoteStats votes False+ unless (null res) $ sendMessage msgEnd res+ f _ _ _ = return () -- | assess the vote with the assess function when time is reached, and sends a signal with the issue (positive of negative) assessOnTimeLimit :: (Votable a) => UTCTime -> Assessor a assessOnTimeLimit time = do - (VoteData msgEnd voteVar _ assess) <- get - lift $ do - onEvent_ (Time time) $ \_ -> do - votes <- getMsgVarData_ voteVar - sendMessage msgEnd (assess $ getVoteStats votes True) + (VoteData msgEnd voteVar i assess _) <- get+ put (VoteData msgEnd voteVar i assess (Just time)) + lift $ void $ onEvent_ (Time time) $ \_ -> do + votes <- getMsgVarData_ voteVar + sendMessage msgEnd (assess $ getVoteStats votes True) -- | assess the vote with the assess function when time is elapsed, and sends a signal with the issue (positive of negative) assessOnTimeDelay :: (Votable a) => NominalDiffTime -> Assessor a assessOnTimeDelay delay = do - t <- addUTCTime delay <$> lift getCurrentTime + t <- addUTCTime delay <$> lift (liftEffect getCurrentTime) assessOnTimeLimit t -- | assess the vote only when every body voted. An error is generated if the assessing function returns Nothing. assessWhenEverybodyVoted :: (Votable a) => Assessor a assessWhenEverybodyVoted = do - (VoteData msgEnd voteVar _ assess) <- get - lift $ do - onMsgVarChange voteVar $ f assess msgEnd where- f assess msgEnd (VUpdated votes) = when (all isJust (map snd votes)) $ sendMessage msgEnd $ assess $ getVoteStats votes True - f _ _ _ = return ()- + (VoteData msgEnd voteVar _ assess _) <- get + lift $ void $ onMsgVarEvent voteVar $ f assess msgEnd where+ f assess msgEnd (VUpdated votes) = when (all isJust (map snd votes)) $ sendMessage msgEnd $ assess $ getVoteStats votes True + f _ _ _ = return () -- | clean events and variables necessary for the vote -cleanVote :: (Votable a) => VoteData a -> Nomex () -cleanVote (VoteData msgEnd voteVar inputsNumber _) = onMessage msgEnd $ \_ -> do - delAllEvents msgEnd +cleanVote :: (Votable a) => VoteData a -> Nomex EventNumber +cleanVote (VoteData msgEnd voteVar inputsNumber _ _) = onMessageOnce msgEnd $ \_ -> do delMsgVar voteVar mapM_ delEvent inputsNumber - -- | a quorum is the neccessary number of voters for the validity of the vote quorum :: (Votable a) => Int -> VoteStats a -> Bool quorum q vs = (voted vs) >= q -- | adds a quorum to an assessing function withQuorum :: (Votable a) => VoteResult a -> Int -> VoteResult a -withQuorum assess q vs = if (quorum q vs) then assess vs else [] +withQuorum assess q vs = if quorum q vs then assess vs else [] -- | assess the vote results according to a unanimity (everybody votes for) unanimity :: (Votable a) => VoteStats a -> [Alts a] @@ -155,20 +156,20 @@ -- | assess the vote results according to a necessary number of positive votes numberVotes :: (Votable a) => Int -> VoteStats a -> [Alts a] -numberVotes i vs = voteQuota i vs +numberVotes = voteQuota -- | the winners are the x vote alternatives with the more votes firstXBest :: forall a. (Votable a) => Int -> VoteStats a -> [Alts a] -firstXBest x votes = map fst $ takeInGroups x $ sortedVotesWithExAequoGroups where+firstXBest x votes = map fst $ takeInGroups x sortedVotesWithExAequoGroups where voted (Just a, n) = Just (a, n) voted (Nothing, _) = Nothing sortedVotesWithExAequoGroups :: [[(Alts a, Int)]]- sortedVotesWithExAequoGroups = (groupBy ((==) `on` snd)) $ sortWith snd $ catMaybes $ map voted $ M.assocs (voteCounts votes)+ sortedVotesWithExAequoGroups = groupBy ((==) `on` snd) $ sortWith snd $ mapMaybe voted $ M.assocs (voteCounts votes) --take n elements from the first lists, but do not break groups takeInGroups :: Int -> [[a]] -> [a] takeInGroups 0 _ = []-takeInGroups n grps = if grpsSize <= n then (head grps) ++ takeInGroups (n - grpsSize) (tail grps) else (head grps) where+takeInGroups n grps = if grpsSize <= n then head grps ++ takeInGroups (n - grpsSize) (tail grps) else head grps where grpsSize = length $ head grps -- | the winner is the vote alternative with the more votes @@ -180,7 +181,7 @@ -- | return the vote alternatives that are above threshold voteQuota :: forall a. (Votable a) => Int -> VoteStats a -> [Alts a] -voteQuota q votes = case (exclusiveWinner (undefined :: a)) of+voteQuota q votes = case exclusiveWinner (undefined :: a) of Nothing -> catMaybes $ M.keys $ M.filter (>= q) (voteCounts votes) Just a -> maybeToList $ exclusiveVoteQuota q votes a @@ -215,48 +216,44 @@ counts as = map (head &&& length) (group $ sort as) -displayVoteVar :: (Votable a) => (Maybe PlayerNumber) -> String -> ArrayVar PlayerNumber (Alts a) -> Nomex ()-displayVoteVar mpn title mv = displayVar mpn mv (showOnGoingVote title)-+displayVoteVar :: (Votable a) => (Maybe PlayerNumber) -> String -> ArrayVar PlayerNumber (Alts a) -> Nomex EventNumber+displayVoteVar mpn title mv = displayVar' mpn mv (showOnGoingVote title) showChoice :: (Votable a) => Maybe (Alts a) -> String showChoice (Just a) = show a showChoice Nothing = "Not Voted" -showChoices :: (Votable a) => [(Alts a)] -> String+showChoices :: (Votable a) => [Alts a] -> String showChoices [] = "no result"-showChoices cs = concat $ intersperse ", " $ map show cs+showChoices cs = intercalate ", " $ map show cs -showOnGoingVote :: (Votable a) => String -> [(PlayerNumber, Maybe (Alts a))] -> Nomex String+showOnGoingVote :: (Votable a) => String -> [(PlayerNumber, Maybe (Alts a))] -> NomexNE String showOnGoingVote title listVotes = do list <- mapM showVote listVotes return $ title ++ "\n" ++ concatMap (\(name, vote) -> name ++ "\t" ++ vote ++ "\n") list -showFinishedVote :: (Votable a) => [(PlayerNumber, Maybe (Alts a))] -> Nomex String+showFinishedVote :: (Votable a) => [(PlayerNumber, Maybe (Alts a))] -> NomexNE String showFinishedVote l = do let voted = filter (\(_, r) -> isJust r) l votes <- mapM showVote voted- return $ concat $ intersperse ", " $ map (\(name, vote) -> name ++ ": " ++ vote) votes+ return $ intercalate ", " $ map (\(name, vote) -> name ++ ": " ++ vote) votes -showVote :: (Votable a) => (PlayerNumber, Maybe (Alts a)) -> Nomex (String, String)+showVote :: (Votable a) => (PlayerNumber, Maybe (Alts a)) -> NomexNE (String, String) showVote (pn, v) = do name <- showPlayer pn return (name, showChoice v) -displayVoteResult :: (Votable a) => String -> VoteData a -> Nomex ()-displayVoteResult toVoteName (VoteData msgEnd voteVar _ _) = onMessage msgEnd $ \(MessageData result) -> do +displayVoteResult :: (Votable a) => String -> VoteData a -> Nomex OutputNumber+displayVoteResult toVoteName (VoteData msgEnd voteVar _ _ _) = onMessage msgEnd $ \(MessageData result) -> do vs <- getMsgVarData_ voteVar- votes <- showFinishedVote vs- outputAll' $ "Vote result for " ++ toVoteName ++ ": " ++ (showChoices result) ++- " (" ++ votes ++ ")"+ votes <- liftEffect $ showFinishedVote vs+ void $ outputAll_ $ "Vote result for " ++ toVoteName ++ ": " ++ showChoices result ++ " (" ++ votes ++ ")" --- | any new rule will be activate if the rule in parameter returns True -onRuleProposed :: (Rule -> Nomex (Msg [ForAgainst]) ) -> RuleFunc -onRuleProposed f = voidRule $ onEvent_ (RuleEv Proposed) $ \(RuleData rule) -> do +-- | any new rule will be activate if the rule in parameter returns For +onRuleProposed :: (RuleInfo -> Nomex (Msg [ForAgainst]) ) -> Rule +onRuleProposed f = void $ onEvent_ (RuleEv Proposed) $ \(RuleData rule) -> do resp <- f rule- onMessageOnce resp $ (activateOrReject rule) . (== [For]) . messageData--+ void $ onMessageOnce resp $ (activateOrReject rule) . (== [For]) . messageData -- * Referendum & elections @@ -268,40 +265,40 @@ quota No q vs = vs - q + 1 name (Referendum n) = "referendum on " ++ n -referendum :: String -> Nomex () -> RuleFunc-referendum name action = voidRule $ do+referendum :: String -> Nomex () -> Rule+referendum name action = do msg <- voteWith_ (majority `withQuorum` 2) (assessOnEveryVote >> assessOnTimeDelay oneDay) (Referendum name)- onMessageOnce msg resolution where+ void $ onMessageOnce msg resolution where resolution (MessageData [Yes]) = do- outputAll' "Positive result of referendum"+ outputAll_ "Positive result of referendum" action- resolution (MessageData [No]) = outputAll' "Negative result of referendum"- resolution (MessageData []) = outputAll' "No result for referendum"+ resolution (MessageData [No]) = void $ outputAll_ "Negative result of referendum"+ resolution (MessageData []) = void $ outputAll_ "No result for referendum" resolution (MessageData _) = throwError "Impossible result for referendum" data Election = Election String deriving (Typeable) instance Votable Election where data Alts Election = Candidate {candidate :: PlayerInfo}- alts = map (\n -> Candidate (PlayerInfo n "")) [1..]+ alts = map (\n -> Candidate (PlayerInfo n "" Nothing)) [1..] quota _ q _ = q name (Election n) = "elections on " ++ n instance Show (Alts Election) where- show (Candidate (PlayerInfo _ name)) = name+ show (Candidate (PlayerInfo _ name _)) = name instance Eq (Alts Election) where- (Candidate (PlayerInfo pn1 _)) == (Candidate (PlayerInfo pn2 _)) = pn1 == pn2+ (Candidate (PlayerInfo pn1 _ _)) == (Candidate (PlayerInfo pn2 _ _)) = pn1 == pn2 instance Ord (Alts Election) where- compare (Candidate (PlayerInfo pn1 _)) (Candidate (PlayerInfo pn2 _)) = compare pn1 pn2+ compare (Candidate (PlayerInfo pn1 _ _)) (Candidate (PlayerInfo pn2 _ _)) = compare pn1 pn2 -elections :: String -> [PlayerInfo] -> (PlayerNumber -> Nomex()) -> Nomex ()+elections :: String -> [PlayerInfo] -> (PlayerNumber -> Nomex ()) -> Nomex () elections name pns action = do msg <- voteWith majority (assessOnTimeDelay oneDay) (Election name) (Candidate <$> pns)- onMessageOnce msg resolution where+ void $ onMessageOnce msg resolution where resolution (MessageData [Candidate pi]) = do- outputAll' $ "Result of elections: player(s) " ++ (show $ _playerName pi) ++ " won!"+ outputAll_ $ "Result of elections: player(s) " ++ (show $ _playerName pi) ++ " won!" action $ _playerNumber pi- resolution (MessageData []) = outputAll' "Result of elections: nobody won!"+ resolution (MessageData []) = void $ outputAll_ "Result of elections: nobody won!" resolution (MessageData _) = throwError "Impossible result for elections"