Nomyx-Language 0.5.0 → 0.6.0
raw patch · 20 files changed
+262/−1384 lines, 20 filessetup-changed
Files
- Nomyx-Language.cabal +2/−8
- README +1/−3
- Setup.hs +0/−2
- Setup.lhs +6/−0
- src/Language/Nomyx.hs +17/−9
- src/Language/Nomyx/Engine.hs +0/−59
- src/Language/Nomyx/Engine/Evaluation.hs +0/−402
- src/Language/Nomyx/Engine/Game.hs +0/−112
- src/Language/Nomyx/Engine/GameEvents.hs +0/−193
- src/Language/Nomyx/Engine/Test.hs +0/−321
- src/Language/Nomyx/Engine/Utils.hs +0/−51
- src/Language/Nomyx/Events.hs +42/−34
- src/Language/Nomyx/Examples.hs +5/−4
- src/Language/Nomyx/Expression.hs +56/−64
- src/Language/Nomyx/Inputs.hs +42/−47
- src/Language/Nomyx/Outputs.hs +5/−5
- src/Language/Nomyx/Players.hs +3/−2
- src/Language/Nomyx/Rules.hs +49/−42
- src/Language/Nomyx/Variables.hs +21/−14
- src/Language/Nomyx/Vote.hs +13/−12
Nomyx-Language.cabal view
@@ -1,5 +1,5 @@ name: Nomyx-Language-version: 0.5.0+version: 0.6.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)@@ -53,12 +53,6 @@ Language.Nomyx.Players Language.Nomyx.Rules Language.Nomyx.Vote- Language.Nomyx.Engine- Language.Nomyx.Engine.Evaluation- Language.Nomyx.Engine.Game- Language.Nomyx.Engine.GameEvents- Language.Nomyx.Engine.Test- Language.Nomyx.Engine.Utils Paths_Nomyx_Language exposed: True buildable: True@@ -67,5 +61,5 @@ source-repository head type: git- location: git://github.com/cdupont/Nomyx-Language.git+ location: https://github.com/cdupont/Nomyx-Language.git
README view
@@ -1,10 +1,8 @@-[](https://travis-ci.org/cdupont/Nomyx-Language)-[](https://hackage.haskell.org/package/Nomyx-Language) Introduction ============ -This library is defining the language to express rules in Nomic.+This library is defining the language that allows you to express rules in Nomic. Installation ============
− Setup.hs
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
+ Setup.lhs view
@@ -0,0 +1,6 @@+#!/usr/bin/runhaskell +> module Main where+> import Distribution.Simple+> main :: IO ()+> main = defaultMain+
src/Language/Nomyx.hs view
@@ -1,13 +1,21 @@ {-# LANGUAGE Trustworthy #-} -- | This module re-exports the elements necessary to compose a Nomyx rule.-module Language.Nomyx (module X) where+module Language.Nomyx (+ module Language.Nomyx.Expression,+ module Language.Nomyx.Outputs,+ module Language.Nomyx.Inputs,+ module Language.Nomyx.Events,+ module Language.Nomyx.Players,+ module Language.Nomyx.Variables,+ module Language.Nomyx.Rules,+ module Language.Nomyx.Vote) 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+import Language.Nomyx.Expression -- Nomyx Expression DSL+import Language.Nomyx.Outputs -- create outputs+import Language.Nomyx.Inputs -- create inputs+import Language.Nomyx.Events -- create events+import Language.Nomyx.Players -- manage players+import Language.Nomyx.Variables -- create variables+import Language.Nomyx.Rules -- manage rules+import Language.Nomyx.Vote -- create votations
− src/Language/Nomyx/Engine.hs
@@ -1,59 +0,0 @@---- | Warning: Nomyx internals (not required to compose rules and play the game)--- This module implements game engine.--- the module manages the effects of rules over each others.--- This module is not required-module Language.Nomyx.Engine(- -- * Game management- GameEvent(..),- LoggedGame(..),- GameName,- Game(..),- GameDesc(..),- execGameEvent, execGameEvent',- execWithGame, execWithGame',- game,- emptyGame,- getLoggedGame,- gameName,- players,- getVictorious,-- -- * Variables management- Var(..),-- -- * Rules management- SubmitRule(..),- activeRules, pendingRules, rejectedRules,-- -- * Events management- EventHandler(..),- Status(..),- getEventHandler,- events,- getChoiceEvents,- getTextEvents,-- -- * Inputs management- UInputData(..),-- -- * Outputs management- Output(..),- Log(..),- evalOutput,- isOutput,-- -- * Time- getTimes,- currentTime,-- -- * 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
@@ -1,402 +0,0 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Language.Nomyx.Engine.Evaluation where--import Prelude hiding ((.), log)-import Control.Monad-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-data UInputData = URadioData Int- | UCheckboxData [Int]- | UTextData String- | UTextAreaData String- | UButtonData- deriving (Show, Read, Eq, Ord)---- | evaluate an expression.--- The rule number passed is the number of the rule containing the expression.-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 : )- return $ Just (V name)- Just _ -> return Nothing--evalNomex (DelVar (V name)) _ = do- vars <- access variables- case find ((== name) . getL vName) vars of- Nothing -> return False- Just _ -> do- variables %= filter ((/= name) . getL vName)- return True--evalNomex (WriteVar (V name) val) _ = do- vars <- access variables- case find (\(Var _ myName _) -> myName == name) vars of- Nothing -> return False- Just (Var rn myName _) -> do- variables %= replaceWith ((== name) . getL vName) (Var rn myName val)- return True--evalNomex (OnEvent event handler) rn = do- evs <- access events- let en = getFreeNumber (map _eventNumber evs)- events %= (EH en rn event handler SActive : )- return en--evalNomex (DelEvent en) _ = evDelEvent en--evalNomex (DelAllEvents e) _ = do- evs <- access events- let filtered = filter (\EH {event} -> event === e) evs- mapM_ evDelEvent (_eventNumber <$> filtered)--evalNomex (SendMessage (Message id) myData) _ = triggerEvent_ (Message id) (MessageData myData)--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---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) => 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)- case filtered of- [] -> return False- xs -> do- mapM_ (triggerHandler dat) xs- return True---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)- (evalNomex exp _ruleNumber) `catchError` (errorHandler _ruleNumber _eventNumber)- Nothing -> logAll ("failed " ++ (show $ typeOf handler))--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---- trigger the input event with the input data-triggerInput :: EventNumber -> UInputData -> Evaluate ()-triggerInput en ir = do- evs <- access events- 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) = 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 = find ((== en) . getL 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 :: RuleInfo -> Evaluate Bool-evProposeRule rule = do- rs <- access rules- case find ((== (rNumber ^$ rule)) . getL rNumber) rs of- Nothing -> do- rules %= (rule:)- triggerEvent_ (RuleEv Proposed) (RuleData rule)- return True- Just _ -> return False----Sets the rule status to Active and execute it if possible-evActivateRule :: RuleNumber -> RuleNumber -> Evaluate Bool-evActivateRule rn by = do- rs <- access rules- case find (\r -> _rNumber r == rn && _rStatus r /= Active) rs of- Nothing -> return False- Just r -> do- let newrules = replaceWith ((== rn) . getL rNumber) r{_rStatus = Active, _rAssessedBy = Just by} rs- rules ~= newrules- --execute the rule- evalNomex (_rRule r) rn- triggerEvent_ (RuleEv Activated) (RuleData r)- return True--evRejectRule :: RuleNumber -> RuleNumber -> Evaluate Bool-evRejectRule rn by = do- rs <- access rules- case find (\r -> _rNumber r == rn && _rStatus r /= Reject) rs of- Nothing -> return False- Just r -> do- let newrules = replaceWith ((== rn) . getL rNumber) r{_rStatus = Reject, _rAssessedBy = Just by} rs- rules ~= newrules- triggerEvent_ (RuleEv Rejected) (RuleData r)- delVarsRule rn- delEventsRule rn- delOutputsRule rn- return True--evAddRule :: RuleInfo -> Evaluate Bool-evAddRule rule = do- rs <- access rules- case find ((== (rNumber ^$ rule)) . getL rNumber) rs of- Nothing -> do- rules %= (rule:)- triggerEvent_ (RuleEv Added) (RuleData rule)- return True- Just _ -> return False-----TODO: clean and execute new rule-evModifyRule :: RuleNumber -> RuleInfo -> Evaluate Bool-evModifyRule mod rule = do- rs <- access rules- let newRules = replaceWith ((== mod) . getL rNumber) rule rs- case find ((== mod) . getL rNumber) rs of- Nothing -> return False- Just r -> do- rules ~= newRules- triggerEvent_ (RuleEv Modified) (RuleData r)- return True--addPlayer :: PlayerInfo -> Evaluate Bool-addPlayer pi = do- pls <- access players- let exists = any (((==) `on` _playerNumber) pi) pls- unless exists $ do- players %= (pi:)- triggerEvent_ (Player Arrive) (PlayerData pi)- return $ not exists--evDelPlayer :: PlayerNumber -> Evaluate Bool-evDelPlayer pn = do- g <- get- case find ((== pn) . getL playerNumber) (_players g) of- Nothing -> do- tracePN pn "not in game!"- return False- Just pi -> do- players %= filter ((/= pn) . getL playerNumber)- triggerEvent_ (Player Leave) (PlayerData pi)- tracePN pn $ "leaving the game: " ++ _gameName g- return True--evChangeName :: PlayerNumber -> PlayerName -> Evaluate Bool-evChangeName pn name = do- pls <- access players- case find ((== pn) . getL playerNumber) pls of- Nothing -> return False- Just pi -> do- players ~= replaceWith ((== pn) . getL playerNumber) (pi {_playerName = name}) pls- return True--evDelEvent :: EventNumber -> Evaluate Bool-evDelEvent en = do- evs <- access events- case find ((== en) . getL eventNumber) evs of- 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-evTriggerTime t = triggerEvent (Time t) (TimeData t)-----delete all variables of a rule-delVarsRule :: RuleNumber -> Evaluate ()-delVarsRule rn = void $ variables %= filter ((/= rn) . getL vRuleNumber)----delete all events of a rule-delEventsRule :: RuleNumber -> Evaluate ()-delEventsRule rn = do- evs <- access events- let toDelete = filter ((== rn) . getL ruleNumber) evs- mapM_ (evDelEvent . _eventNumber) toDelete----delete all outputs of a rule-delOutputsRule :: RuleNumber -> Evaluate ()-delOutputsRule rn = do- os <- access outputs- let toDelete = filter ((== rn) . getL oRuleNumber) os- mapM_ (evDelOutput . _outputNumber) toDelete--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 : )- return on--evGetOutput :: OutputNumber -> Reader Game (Maybe String)-evGetOutput on = do- ops <- asks _outputs- case find (\(Output myOn _ _ _ s) -> myOn == on && s == SActive) ops of- Nothing -> return Nothing- Just (Output _ rn _ o _) -> do- out <- evalNomexNE o rn- return $ Just out--evUpdateOutput :: OutputNumber -> NomexNE String -> Evaluate Bool-evUpdateOutput on s = do- ops <- access outputs- case find (\(Output myOn _ _ _ s) -> myOn == on && s == SActive) ops of- Nothing -> return False- Just (Output _ rn pn _ _) -> do- outputs %= replaceWith ((== on) . getL outputNumber) (Output on rn pn s SActive)- return True--evDelOutput :: OutputNumber -> Evaluate Bool-evDelOutput on = do- ops <- access outputs- case find ((== on) . getL outputNumber) ops of- 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 = log (Just pn)--logAll :: String -> Evaluate ()-logAll = log Nothing--log :: Maybe PlayerNumber -> String -> Evaluate ()-log mpn s = do- time <- access currentTime- void $ logs %= (Log mpn time s : )----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 _ -> return ()- Left e -> do- 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
@@ -1,112 +0,0 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE DeriveDataTypeable #-}---- | This module implements game engine (for the nomyx language, see Language.Nomyx)-module Language.Nomyx.Engine.Game where--import Prelude hiding (log)-import Language.Nomyx.Expression-import Data.Lens.Template-import Data.Time-import Data.Typeable-import Data.Data---- * Game--type GameName = String---- | The state of the game:-data Game = Game { _gameName :: GameName,- _gameDesc :: GameDesc,- _rules :: [RuleInfo],- _players :: [PlayerInfo],- _variables :: [Var],- _events :: [EventHandler],- _outputs :: [Output],- _victory :: Maybe VictoryCond,- _logs :: [Log],- _currentTime :: UTCTime}- deriving (Typeable)--data GameDesc = GameDesc { _desc :: String, _agora :: String} deriving (Eq, Show, Read, Ord)--instance Eq Game where- (Game {_gameName=gn1}) == (Game {_gameName=gn2}) = gn1 == gn2--instance Ord Game where- compare (Game {_gameName=gn1}) (Game {_gameName=gn2}) = compare gn1 gn2--emptyGame name desc date = Game {- _gameName = name,- _gameDesc = desc,- _rules = [],- _players = [],- _variables = [],- _events = [],- _outputs = [],- _victory = Nothing,- _logs = [],- _currentTime = date}----- * Variables---- | stores the variable's data-data Var = forall a . (Typeable a, Show a) =>- Var { _vRuleNumber :: RuleNumber,- _vName :: String,- vData :: a}--instance Show Var where- show (Var a b c) = "Rule number = " ++ (show a) ++ ", Name = " ++ (show b) ++ ", Value = " ++ (show c) ++ "\n"---- * Events--data EventHandler where- EH :: (Typeable e) =>- {_eventNumber :: EventNumber,- _ruleNumber :: RuleNumber,- event :: Event e,- handler :: (EventNumber, EventData e) -> Nomex (),- _evStatus :: Status} -> EventHandler--data Status = SActive | SDeleted deriving (Eq, Show)--instance Show EventHandler where- show (EH en rn e _ s) = (show en) ++ " " ++ (show rn) ++ " (" ++ (show e) ++"), status = " ++ (show s)--instance Eq EventHandler where- (EH {_eventNumber=e1}) == (EH {_eventNumber=e2}) = e1 == e2--instance Ord EventHandler where- (EH {_eventNumber=e1}) <= (EH {_eventNumber=e2}) = e1 <= e2----- * Outputs--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 :: NomexNE String, -- output string- _oStatus :: Status} -- status of the output- deriving (Show)---- * Logs--data Log = Log { _lPlayerNumber :: Maybe PlayerNumber,- _lTime :: UTCTime,- _lMsg :: String}- deriving (Show)---- * Rules--data SubmitRule = SubmitRule RuleName RuleDesc RuleCode deriving (Show, Read, Eq, Ord, Data, Typeable)---$( makeLenses [''Game, ''GameDesc, ''EventHandler, ''Var, ''Output] )---
− src/Language/Nomyx/Engine/GameEvents.hs
@@ -1,193 +0,0 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE DoAndIfThenElse #-}---- | This module implements the events that can affect a game.-module Language.Nomyx.Engine.GameEvents where--import Prelude hiding (log)-import Control.Monad.State-import Data.List-import Language.Nomyx.Expression-import Language.Nomyx.Engine.Evaluation-import Language.Nomyx.Engine.Game-import Language.Nomyx.Engine.Utils-import Data.Lens-import Control.Category ((>>>))-import Data.Lens.Template-import Control.Exception as E-import Data.Maybe-import Data.Time----- | a list of possible events affecting a game-data GameEvent = GameSettings GameName GameDesc UTCTime- | JoinGame PlayerNumber PlayerName- | LeaveGame PlayerNumber- | ProposeRuleEv PlayerNumber SubmitRule- | InputResult PlayerNumber EventNumber UInputData- | GLog (Maybe PlayerNumber) String- | TimeEvent UTCTime- | SystemAddRule SubmitRule- deriving (Show, Read, Eq, Ord)--data TimedEvent = TimedEvent UTCTime GameEvent deriving (Show, Read, Eq, Ord)---- | 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 (Show)--instance Eq LoggedGame where- (LoggedGame {_game=g1}) == (LoggedGame {_game=g2}) = g1 == g2--instance Ord LoggedGame where- compare (LoggedGame {_game=g1}) (LoggedGame {_game=g2}) = compare g1 g2--$( makeLens ''LoggedGame)---- | perform a game event-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 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 Rule) -> TimedEvent -> StateT Game IO ()-enactTimedEvent inter (TimedEvent t ge) = flip stateCatch updateError $ do- currentTime ~= t- enactEvent ge inter- lg <- get- lift $ evaluate lg- return ()--updateError :: SomeException -> StateT Game IO ()-updateError e = do- liftIO $ putStrLn $ "IO error: " ++ show e- mapStateIO $ logGame ("IO error: " ++ show e) Nothing--execGameEvent :: GameEvent -> StateT LoggedGame IO ()-execGameEvent = execGameEvent' Nothing--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 Rule) -> [TimedEvent] -> IO LoggedGame-getLoggedGame g mInter tes = do- let a = mapM_ (enactTimedEvent (Just mInter)) tes- g' <- execStateT a g- return $ LoggedGame g' tes----- | initialize the game.-gameSettings :: GameName -> GameDesc -> UTCTime -> State Game ()-gameSettings name desc date = do- gameName ~= name- gameDesc ~= desc- currentTime ~= date- return ()----- | join the game.-joinGame :: PlayerName -> PlayerNumber -> State Game ()-joinGame name pn = do- g <- get- 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, _playAs = Nothing}- players %= (player : )- runEvalError (Just pn) $ triggerEvent_ (Player Arrive) (PlayerData player)----- | leave the game.-leaveGame :: PlayerNumber -> State Game ()-leaveGame pn = runEvalError (Just pn) $ void $ evDelPlayer pn---- | insert a rule in pending rules.-proposeRule :: SubmitRule -> PlayerNumber -> (RuleCode -> IO Rule) -> StateT Game IO ()-proposeRule sr pn inter = do- rule <- createRule sr pn inter- mapStateIO $ runEvalError (Just pn) $ do- r <- evProposeRule rule- 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 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 (Just 0) $ void $ evalNomex (_rRule rule) (_rNumber rule)---- | insert a log message.-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 (Just pn) $ triggerInput en ir---getEventHandler :: EventNumber -> LoggedGame -> EventHandler-getEventHandler en g = fromJust $ findEvent en (_events $ _game g)---getTimes :: EventHandler -> Maybe UTCTime-getTimes (EH _ _ (Time t) _ SActive) = Just t-getTimes _ = Nothing---- | 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' :: UTCTime -> StateT LoggedGame IO () -> LoggedGame -> IO LoggedGame-execWithGame' t gs g = execStateT gs ((game >>> currentTime) `setL` t $ g)---activeRules :: Game -> [RuleInfo]-activeRules = sort . filter ((==Active) . getL rStatus) . _rules--pendingRules :: Game -> [RuleInfo]-pendingRules = sort . filter ((==Pending) . getL rStatus) . _rules--rejectedRules :: Game -> [RuleInfo]-rejectedRules = sort . filter ((==Reject) . getL rStatus) . _rules---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 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-
− src/Language/Nomyx/Engine/Test.hs
@@ -1,321 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE GADTs #-}--module Language.Nomyx.Engine.Test where--import Language.Nomyx.Expression-import Language.Nomyx.Variables-import Language.Nomyx.Rules-import Language.Nomyx.Events-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---date1 = parse822Time "Tue, 02 Sep 1997 09:00:00 -0400"-date2 = parse822Time "Tue, 02 Sep 1997 10:00:00 -0400"-date3 = parse822Time "Tue, 02 Sep 1997 11:00:00 -0400"--testGame = Game { _gameName = "test",- _gameDesc = GameDesc "test" "test",- _rules = [],- _players = [PlayerInfo 1 "coco" Nothing],- _variables = [],- _events = [],- _outputs = [],- _victory = Nothing,- _logs = [],- _currentTime = date1}--testRule = RuleInfo { _rNumber = 0,- _rName = "test",- _rDescription = "test",- _rProposedBy = 0,- _rRuleCode = "",- _rRule = return (),- _rStatus = Pending,- _rAssessedBy = Nothing}--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 :: Rule -> RuleNumber -> Evaluate ()-addActivateRule rf rn = do- let rule = testRule {_rName = "testRule", _rRule = rf, _rNumber = rn, _rStatus = Pending}- evAddRule rule- evActivateRule (_rNumber rule) 0- return ()--tests = [("test var 1", testVarEx1),- ("test var 2", testVarEx2),- ("test var 3", testVarEx3),- ("test var 4", testVarEx4),- ("test var 5", testVarEx5),- ("test single input", testSingleInputEx),- ("test multiple input", testMultipleInputsEx),- ("test input string", testInputStringEx),- ("test send messsage", testSendMessageEx),- ("test send message 2", testSendMessageEx2),- ("test user input write", testUserInputWriteEx),- ("test activate rule", testActivateRuleEx),- ("test auto activate", testAutoActivateEx),- --("test meta rules vote", testApplicationMetaRuleEx),- ("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),- ("test assess on every vote 2", testVoteAssessOnEveryVote2),- ("test assess on every vote 3", testVoteAssessOnEveryVote3),- ("test assess on every vote 4", testVoteAssessOnEveryVote4),- ("test majority with", testVoteMajorityWith),- ("test number positive votes", testVoteNumberPositiveVotes),- ("test vote with quorum 1", testVoteWithQuorum1),- ("test vote with quorum 2", testVoteWithQuorum2),- ("test assess on time limit 1", testVoteAssessOnTimeLimit1),- ("test assess on time limit 2", testVoteAssessOnTimeLimit2),- ("test assess on time limit 3", testVoteAssessOnTimeLimit3),- ("test assess on time limit 4", testVoteAssessOnTimeLimit4),- ("test assess on time limit 5", testVoteAssessOnTimeLimit5)]--allTests = all snd tests----Test variable creation-testVar1 :: Rule-testVar1 = do- NewVar "toto" (1::Integer)- return ()--testVarEx1 = True --(variables ^$ execRuleFunc testVar1) == [(Var 0 "toto" (1::Integer))]----Test variable deleting-testVar2 :: Rule-testVar2 = do- var <- newVar_ "toto" (1::Int)- delVar var- return ()--testVarEx2 = True --_variables (execRuleFunc testVar2) == []----Test variable reading-testVar3 :: Rule-testVar3 = do- var <- newVar_ "toto" (1::Int)- a <- liftEffect $ readVar var- case a of- Just (1::Int) -> void $ newOutput (Just 1) (return "ok")- _ -> void $ newOutput (Just 1) (return "nok")--testVarEx3 = isOutput "ok" (execRuleFunc testVar3)----Test variable writing-testVar4 :: Rule-testVar4 = do- var <- newVar_ "toto" (1::Int)- writeVar var (2::Int)- a <- liftEffect $ readVar var- case a of- Just (2::Int) -> void $ newOutput (Just 1) (return "ok")- _ -> void $ newOutput (Just 1) (return "nok")--testVarEx4 = isOutput "ok" (execRuleFunc testVar4)----Test variable writing-testVar5 :: Rule-testVar5 = do- var <- newVar_ "toto" ([]::[Int])- writeVar var ([1]::[Int])- a <- liftEffect $ readVar var- case a of- Just (a::[Int]) -> void $ writeVar var (2:a)- Nothing -> void $ newOutput (Just 1) (return "nok")--testVarEx5 = True --_variables (execRuleFunc testVar5) == [(Var 0 "toto" ([2,1]::[Int]))]--data Choice = Holland | Sarkozy deriving (Enum, Typeable, Show, Eq, Bounded)---- Test input-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 (inputRadio 1 "Vote for Holland or Sarkozy" [Holland, Sarkozy] Holland) (InputData (RadioData Holland))--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 :: 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 :: Rule-testSendMessage = do- let msg = Message "msg" :: Event(Message String)- onEvent_ msg f- sendMessage msg "toto" where- f (MessageData a :: EventData(Message String)) = void $ newOutput (Just 1) (return a)--testSendMessageEx = isOutput "toto" (execRuleFunc testSendMessage)--testSendMessage2 :: Rule-testSendMessage2 = do- onEvent_ (Message "msg":: Event(Message ())) $ const $ void $ newOutput (Just 1) (return "Received")- sendMessage_ (Message "msg")---testSendMessageEx2 = isOutput "Received" (execRuleFunc testSendMessage2)--data Choice2 = Me | You deriving (Enum, Typeable, Show, Eq, Bounded)---- Test user input + variable read/write-testUserInputWrite :: Rule-testUserInputWrite = do- newVar_ "vote" (Nothing::Maybe Choice2)- onEvent_ (Message "voted" :: Event (Message ())) h2- 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 <- 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 :: 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--testAutoActivateEx = _rStatus (head $ _rules (execRuleFuncEventGame autoActivate (RuleEv Proposed) (RuleData testRule) (testGame {_rules=[testRule]}))) == Active----Time tests--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)--testTimeEventEx2 = isOutput (show date1) g && isOutput (show date2) g where- g = execState (runEvalError Nothing $ evalNomex testTimeEvent2 0 >> void gameEvs) testGame- gameEvs = do- evTriggerTime date1- evTriggerTime date2---- Test deletes-testDeleteRule :: Rule-testDeleteRule = do- newVar_ "toto" (1::Int)- onMessage (Message "msg":: Event(Message ())) (const $ return ())- void $ newOutput (Just 1) (return "toto")--testDeleteGame :: Game-testDeleteGame = flip execState testGame {_players = []} $ runEvalError Nothing $ do- addActivateRule testDeleteRule 1- addActivateRule (void $ suppressRule 1) 2--testDeleteRuleEx1 = (_rStatus $ head $ drop 1 $ _rules testDeleteGame) == Reject &&- --(_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 Nothing $ do- mapM_ (\x -> addPlayer (PlayerInfo x ("coco " ++ show x) Nothing)) [1..total]- actions- evProposeRule testRule- 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 -> Rule -> Game-voteGame' positives negatives notVoted timeEvent rf = voteGameActions positives negatives notVoted timeEvent $ addActivateRule rf 1--voteGame :: Int -> Int -> Int -> Rule -> Game-voteGame positives negatives notVoted = voteGame' positives negatives notVoted True--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}---applicationMetaRuleRule = testRule {_rName = "onRuleProposedUseMetaRules", _rRuleFunc = onRuleProposed checkWithMetarules, _rNumber = 2, _rStatus = Active}---testApplicationMetaRuleVote :: Game---testApplicationMetaRuleVote = voteGameActions 2 0 2 False $ do--- evAddRule unanimityRule--- evActivateRule (_rNumber unanimityRule) 0--- evAddRule applicationMetaRuleRule--- evActivateRule (_rNumber applicationMetaRuleRule) 0--- return ()----testApplicationMetaRuleEx = (_rStatus $ head $ _rules testApplicationMetaRuleVote) == Active---- 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-testVoteAssessOnTimeLimit1 = testVoteRule Active $ voteGameTimed 10 0 10 $ onRuleProposed $ voteWith_ unanimity $ assessOnTimeLimit date2-testVoteAssessOnTimeLimit2 = testVoteRule Active $ voteGameTimed 1 0 10 $ onRuleProposed $ voteWith_ unanimity $ assessOnTimeLimit date2-testVoteAssessOnTimeLimit3 = testVoteRule Reject $ voteGameTimed 1 0 10 $ onRuleProposed $ voteWith_ (unanimity `withQuorum` 5) $ assessOnTimeLimit date2-testVoteAssessOnTimeLimit4 = testVoteRule Reject $ voteGameTimed 0 0 10 $ onRuleProposed $ voteWith_ (unanimity `withQuorum` 1) $ assessOnTimeLimit date2-testVoteAssessOnTimeLimit5 = testVoteRule Pending $ voteGameTimed 10 0 10 $ onRuleProposed $ voteWith_ unanimity $ assessOnTimeLimit date3--testVoteRule s g = (_rStatus $ head $ _rules g) == s---
− src/Language/Nomyx/Engine/Utils.hs
@@ -1,51 +0,0 @@- -module Language.Nomyx.Engine.Utils where ---import Data.Time-import Data.Typeable (cast, Typeable)-import Debug.Trace.Helpers (traceM)-import Data.Maybe (fromJust)-import System.Locale (rfc822DateFormat, defaultTimeLocale)-import Control.Monad.State-import Control.Monad.Identity-import Debug.Trace (trace)---- | an equality that tests also the types. -(===) :: (Typeable a, Typeable b, Eq b) => a -> b -> Bool -(===) x y = cast x == Just y - --- | Replaces all instances of a value in a list by another value. -replaceWith :: (a -> Bool) -- ^ Value to search - -> a -- ^ Value to replace it with - -> [a] -- ^ Input list - -> [a] -- ^ Output list -replaceWith f y = map (\z -> if f z then y else z) --tracePN :: (Monad m ) => Int -> String -> m ()-tracePN pn s = traceM $ "Player " ++ (show pn) ++ " " ++ s--traceData :: (Show a) => String -> a -> a-traceData s a = trace (s ++ " " ++ (show a)) a- -parse822Time :: String -> UTCTime -parse822Time = zonedTimeToUTC - . fromJust - . parseTime defaultTimeLocale rfc822DateFormat - -sndMaybe :: (a, Maybe b) -> Maybe (a,b) -sndMaybe (a, Just b) = Just (a,b) -sndMaybe (_, Nothing) = Nothing--mapStateIO :: Show s => State s a -> StateT s IO a-mapStateIO = mapStateT $ return . runIdentity--getFreeNumber :: (Eq a, Num a, Enum a) => [a] -> a-getFreeNumber l = head [a| a <- [1..], not $ a `elem` l]---sel :: [a] -- ^ List of indices to select- -> [Int] -- ^ List of elements- -> [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
@@ -2,43 +2,39 @@ -- | All the building blocks to allow rules to build events. module Language.Nomyx.Events (- Event(..),- EventNumber,- EventData(..),- InputData(..),- Msg,- MsgData, onEvent, onEvent_, onEventOnce, - delEvent, delAllEvents, + delEvent, sendMessage, sendMessage_, onMessage, onMessageOnce, schedule, schedule_, schedule', schedule'_, getCurrentTime,- oneWeek, oneDay, oneHour, oneMinute+ oneWeek, oneDay, oneHour, oneMinute,+ timeEvent, messageEvent, victoryEvent, playerEvent, ruleEvent,+ baseEvent, baseInputEvent ) where import Language.Nomyx.Expression import Data.Typeable -import Control.Monad.State +import Control.Monad.State import Data.List import Data.Time hiding (getCurrentTime) import Data.Time.Recurrence hiding (filter) import Safe --- * Events +-- * Events -- | register a callback on an event -onEvent :: (Typeable e, Show e, Eq e) => Event e -> ((EventNumber, EventData e) -> Nomex ()) -> Nomex EventNumber +onEvent :: (Typeable e, Show e) => Event e -> ((EventNumber, e) -> Nomex ()) -> Nomex EventNumber onEvent = OnEvent -- | register a callback on an event, disregard the event number -onEvent_ :: forall e. (Typeable e, Show e, Eq e) => Event e -> (EventData e -> Nomex ()) -> Nomex EventNumber -onEvent_ e h = OnEvent e (\(_, d) -> h d) +onEvent_ :: (Typeable e, Show e) => Event e -> (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 :: (Typeable e, Show e) => Event e -> (e -> Nomex ()) -> Nomex EventNumber onEventOnce e h = do let handler (en, ed) = delEvent en >> h ed OnEvent e handler @@ -46,37 +42,33 @@ delEvent :: EventNumber -> Nomex Bool delEvent = DelEvent -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) => Msg a -> a -> Nomex () sendMessage = SendMessage -sendMessage_ :: Msg () -> Nomex () -sendMessage_ m = SendMessage m () +sendMessage_ :: String -> Nomex () +sendMessage_ m = SendMessage (Msg m) () -- | subscribe on a message -onMessage :: (Typeable m, Show m) => Msg m -> (MsgData m -> Nomex ()) -> Nomex EventNumber -onMessage = onEvent_ +onMessage :: (Typeable m, Show m) => Msg m -> (m -> Nomex ()) -> Nomex EventNumber +onMessage name = onEvent_ (messageEvent name) -onMessageOnce :: (Typeable m, Show m) => Msg m -> (MsgData m -> Nomex ()) -> Nomex EventNumber -onMessageOnce = onEventOnce +onMessageOnce :: (Typeable m, Show m) => Msg m -> (m -> Nomex ()) -> Nomex EventNumber +onMessageOnce name = onEventOnce (messageEvent name) -- | on the provided schedule, the supplied function will be called schedule :: Schedule Freq -> (UTCTime -> Nomex ()) -> Nomex () schedule sched f = do 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 + if next == now then executeAndScheduleNext f sched now + else void $ onEventOnce (timeEvent next) $ executeAndScheduleNext f sched -executeAndScheduleNext :: (EventData Time -> Nomex ()) -> Schedule Freq -> EventData Time -> Nomex () +executeAndScheduleNext :: (UTCTime -> Nomex ()) -> Schedule Freq -> UTCTime -> Nomex () executeAndScheduleNext f sched now = do f now - let rest = drop 1 $ starting (timeData now) sched - when (rest /= []) $ void $ onEventOnce (Time $ head rest) $ executeAndScheduleNext f sched - + let rest = drop 1 $ starting now sched + when (rest /= []) $ void $ onEventOnce (timeEvent $ head rest) $ executeAndScheduleNext f sched schedule_ :: Schedule Freq -> Nomex () -> Nomex () schedule_ ts f = schedule ts (const f) @@ -88,16 +80,16 @@ now <- liftEffect getCurrentTime let nextMay = headMay $ filter (>=now) sched' case nextMay of - Just next -> if next == now then executeAndScheduleNext' (f . timeData) sched' (TimeData now) - else void $ onEventOnce (Time next) $ executeAndScheduleNext' (f . timeData) sched' + Just next -> if next == now then executeAndScheduleNext' f sched' now + else void $ onEventOnce (timeEvent next) $ executeAndScheduleNext' f sched' Nothing -> return () - -executeAndScheduleNext' :: (EventData Time -> Nomex ()) -> [UTCTime] -> EventData Time -> Nomex () + +executeAndScheduleNext' :: (UTCTime -> Nomex ()) -> [UTCTime] -> UTCTime -> Nomex () executeAndScheduleNext' f sched now = do f now let rest = drop 1 sched - when (rest /= []) $ void $ onEventOnce (Time $ head rest) $ executeAndScheduleNext' f sched + when (rest /= []) $ void $ onEventOnce (timeEvent $ head rest) $ executeAndScheduleNext' f sched schedule'_ :: [UTCTime] -> Nomex () -> Nomex () @@ -112,3 +104,19 @@ oneDay = 24 * oneHour oneHour = 60 * oneMinute oneMinute = 60++baseEvent :: (Typeable a) => Field a -> Event a+baseEvent = BaseEvent++timeEvent :: UTCTime -> Event UTCTime+timeEvent = BaseEvent . Time+messageEvent :: (Typeable a) => Msg a -> Event a+messageEvent = BaseEvent . Message+victoryEvent = BaseEvent Victory+playerEvent :: Player -> Event PlayerInfo+playerEvent = BaseEvent . Player+ruleEvent :: RuleEvent -> Event RuleInfo+ruleEvent re = BaseEvent $ RuleEv re++baseInputEvent :: (Typeable a) => PlayerNumber -> String -> (InputForm a) -> Field a+baseInputEvent pn s iform = Input Nothing pn s iform
src/Language/Nomyx/Examples.hs view
@@ -78,7 +78,7 @@ -- | a player wins X Ecu if a rule proposed is accepted winXEcuOnRuleAccepted :: Int -> Rule-winXEcuOnRuleAccepted x = void $ onEvent_ (RuleEv Activated) $ \(RuleData rule) -> void $ modifyValueOfPlayer (_rProposedBy rule) accounts (+x)+winXEcuOnRuleAccepted x = void $ onEvent_ (ruleEvent Activated) $ \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@@ -110,7 +110,7 @@ -- | Monarchy: only the king decides which rules to accept or reject monarchy :: Rule-monarchy = void $ onEvent_ (RuleEv Proposed) $ \(RuleData rule) -> do+monarchy = void $ onEvent_ (ruleEvent Proposed) $ \rule -> do k <- readMsgVar_ king void $ onInputRadioOnce ("Your Royal Highness, do you accept rule " ++ (show $ _rNumber rule) ++ "?") [True, False] (activateOrReject rule) k @@ -128,7 +128,8 @@ victoryXRules :: Int -> Rule victoryXRules x = setVictory $ do rs <- getRules- let counts = map (_rProposedBy . head &&& length) $ groupBy ((==) `on` _rProposedBy) rs+ let counts :: [(PlayerNumber,Int)]+ counts = map (_rProposedBy . head &&& length) $ groupBy ((==) `on` _rProposedBy) rs let victorious = map fst $ filter ((>= x) . snd) counts return victorious @@ -174,7 +175,7 @@ banPlayer :: PlayerNumber -> Rule banPlayer pn = do delPlayer pn- void $ onEvent_ (Player Arrive) $ \(PlayerData _) -> void $ delPlayer pn+ void $ onEvent_ (playerEvent Arrive) $ const $ void $ delPlayer pn -- * Referendum & elections
src/Language/Nomyx/Expression.hs view
@@ -7,6 +7,7 @@ {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE KindSignatures #-}+{-# LANGUAGE ExistentialQuantification #-} -- | This module containt the type definitions necessary to build a Nomic rule. module Language.Nomyx.Expression where @@ -29,6 +30,7 @@ type VarName = String type Code = String type OutputNumber = Int+type InputNumber = Int -- * Nomyx Expression @@ -47,14 +49,13 @@ 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) + ReadVar :: (Typeable a, Show a) => V a -> NomexNE (Maybe a) WriteVar :: (Typeable a, Show a) => V a -> a -> Nomex Bool DelVar :: (V a) -> Nomex Bool --Events management- OnEvent :: Typeable e => Event e -> ((EventNumber, EventData e) -> Nomex ()) -> Nomex EventNumber + OnEvent :: (Typeable e, Show e) => Event e -> ((EventNumber, e) -> Nomex ()) -> Nomex EventNumber DelEvent :: EventNumber -> Nomex Bool - DelAllEvents :: Typeable e => Event e -> Nomex () - SendMessage :: (Typeable a, Show a) => Event (Message a) -> a -> Nomex () + SendMessage :: (Typeable a, Show a) => Msg a -> a -> Nomex () --Rules management ProposeRule :: RuleInfo -> Nomex Bool ActivateRule :: RuleNumber -> Nomex Bool @@ -125,70 +126,61 @@ data V a = V {varName :: String} deriving Typeable -- * Events - --- | events types -data Player = Arrive | Leave deriving (Typeable, Show, Eq) ++-- | Composable events+data Event a where+ SumEvent :: Event a -> Event a -> Event a -- The first event to fire will be returned+ AppEvent :: Event (a -> b) -> Event a -> Event b -- Both events should fire, and then the result is returned+ PureEvent :: a -> Event a -- Create a fake event. The result is useable with no delay.+ EmptyEvent :: Event a -- An event that is never fired.+ BaseEvent :: (Typeable a) => Field a -> Event a -- Embed a base event+ deriving Typeable++-- | Base events+data Field a where+ Input :: Maybe InputNumber -> PlayerNumber -> String -> (InputForm a) -> Field a+ Player :: Player -> Field PlayerInfo+ RuleEv :: RuleEvent -> Field RuleInfo+ Time :: UTCTime -> Field UTCTime+ Message :: Msg a -> Field a+ Victory :: Field VictoryCond+ deriving Typeable++-- | Type agnostic base event+data SomeField = forall a. (Typeable a) => SomeField (Field a)++-- | Events parameters +data Player = Arrive | Leave deriving (Typeable, Show, Eq) data RuleEvent = Proposed | Activated | Rejected | Added | Modified | Deleted deriving (Typeable, Show, Eq) -data Time deriving Typeable -data EvRule deriving Typeable -data Message m deriving Typeable -data Victory deriving Typeable-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 - Player :: Player -> Event Player - RuleEv :: RuleEvent -> Event RuleEvent - Time :: UTCTime -> Event Time - Message :: String -> Event (Message m) - InputEv :: (Typeable a, Show a, Eq a) => Input a -> Event (Input a) - Victory :: Event Victory- deriving (Typeable) +data Msg m = Msg String deriving (Typeable, Show) --- data sent back by inputs-data InputData a = RadioData a- | CheckboxData [a]- | TextData String- | TextAreaData String- | ButtonData+-- | Input forms+data InputForm a where+ Text :: InputForm String+ TextArea :: InputForm String+ Button :: InputForm ()+ Radio :: (Show a, Eq a) => [(a, String)] -> InputForm a+ Checkbox :: (Show a, Eq a) => [(a, String)] -> InputForm [a]+ deriving Typeable - --- | data associated with each events -data EventData a where - PlayerData :: {playerData :: PlayerInfo} -> EventData Player - 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 :: VictoryCond} -> EventData Victory- deriving (Typeable) - -deriving instance Show (Event a)-deriving instance (Show a) => Show (InputForm a)-deriving instance (Show a) => Show (Input a) -deriving instance Show (EventData a)-deriving instance (Show a) => Show (InputData a)-deriving instance (Show a) => Show (Message a) -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 (Event e)-deriving instance (Eq e) => Eq (Input e)-deriving instance (Eq e) => Eq (InputForm e) - +deriving instance Show (InputForm a)+deriving instance Show (Field a)+deriving instance Show SomeField+deriving instance Eq (Field e)+deriving instance Eq (InputForm e) +deriving instance Eq (Msg e) -type Msg a = Event (Message a)-type MsgData a = EventData (Message a)- +instance Functor Event where+ fmap f a = pure f <*> a++instance Applicative Event where+ pure = PureEvent+ (<*>) = AppEvent++instance Alternative Event where+ (<|>) = SumEvent+ empty = EmptyEvent+ -- * Rule -- | Type of a rule function.
src/Language/Nomyx/Inputs.hs view
@@ -6,7 +6,6 @@ -- void $ onInputButton_ "Click here:" (const $ outputAll_ "Bravo!") 1 module Language.Nomyx.Inputs ( - Input(..), InputForm(..), onInputRadio, onInputRadio_, onInputRadioOnce, onInputText, onInputText_, onInputTextOnce, @@ -14,6 +13,7 @@ onInputButton, onInputButton_, onInputButtonOnce, onInputTextarea, onInputTextarea_, onInputTextareaOnce, -- Internals+ baseInputRadio, baseInputText, baseInputCheckbox, baseInputButton, baseInputTextarea, inputRadio, inputText, inputCheckbox, inputButton, inputTextarea ) where @@ -28,97 +28,92 @@ -- | 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) +onInputRadio title choices handler pn = onEvent (inputRadioHead pn title choices) (\(en, a) -> handler en a) -- | the same, disregard the event number 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) +onInputRadio_ title choices handler pn = onEvent_ (inputRadioHead pn title choices) handler -- | 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) - -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)))) +onInputRadioOnce title choices handler pn = onEventOnce (inputRadioHead pn title choices) handler -inputRadioHead :: (Eq c, Show c, Typeable c) => PlayerNumber -> String -> [c] -> Event (Input c) +inputRadioHead :: (Eq c, Show c, Typeable c) => PlayerNumber -> String -> [c] -> Event c inputRadioHead pn title choices = inputRadio pn title choices (head choices) ++inputRadio :: (Eq c, Show c, Typeable c) => PlayerNumber -> String -> [c] -> c -> Event c +inputRadio pn title cs _ = baseEvent $ baseInputRadio pn title (zip cs (show <$> cs))++baseInputRadio :: (Eq c, Show c, Typeable c) => PlayerNumber -> String -> [(c, String)] -> Field c +baseInputRadio pn title cs = baseInputEvent pn title (Radio cs) -inputRadioData :: (Show c) => EventData (Input c) -> c -inputRadioData (InputData (RadioData a)) = a -inputRadioData a = error $ "Not a Radio Data: " ++ show a -- ** Text inputs -- | 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)) +onInputText title handler pn = onEvent (inputText pn title) (\(en, a) -> handler en a) -- | asks the player pn to answer a question, and feed the callback with this data. onInputText_ :: String -> (String -> Nomex ()) -> PlayerNumber -> Nomex EventNumber -onInputText_ title handler pn = onEvent_ (inputText pn title) (handler . inputTextData) +onInputText_ title handler pn = onEvent_ (inputText pn title) handler -- | 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) +onInputTextOnce title handler pn = onEventOnce (inputText pn title) handler -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) +inputText :: PlayerNumber -> String -> Event String +inputText pn title = baseEvent $ baseInputText pn title +baseInputText :: PlayerNumber -> String -> Field String +baseInputText pn title = baseInputEvent pn title Text -- ** Checkbox inputs 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 title choices handler pn = onEvent (inputCheckbox pn title choices) (\(en, a) -> handler en a) 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) +onInputCheckbox_ title choices handler pn = onEvent_ (inputCheckbox pn title choices) handler 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 title choices handler pn = onEventOnce (inputCheckbox pn title choices) handler -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)) +inputCheckbox :: (Eq c, Show c, Typeable c) => PlayerNumber -> String -> [(c, String)] -> Event [c] +inputCheckbox pn title cs = baseEvent $ baseInputCheckbox pn title cs++baseInputCheckbox :: (Eq c, Show c, Typeable c) => PlayerNumber -> String -> [(c, String)] -> Field [c] +baseInputCheckbox pn title cs = baseInputEvent pn title (Checkbox cs) -- ** Button inputs onInputButton :: String -> (EventNumber -> () -> Nomex ()) -> PlayerNumber -> Nomex EventNumber -onInputButton title handler pn = onEvent (inputButton pn title) (\(en, InputData ButtonData) -> handler en ()) +onInputButton title handler pn = onEvent (inputButton pn title) (\(en, ()) -> handler en ()) onInputButton_ :: String -> (() -> Nomex ()) -> PlayerNumber -> Nomex EventNumber -onInputButton_ title handler pn = onEvent_ (inputButton pn title) (handler . inputButtonData) +onInputButton_ title handler pn = onEvent_ (inputButton pn title) handler 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 title handler pn = onEventOnce (inputButton pn title) handler -inputButton :: PlayerNumber -> String -> Event (Input ()) -inputButton pn title = InputEv (Input pn title Button) +inputButton :: PlayerNumber -> String -> Event () +inputButton pn title = baseEvent $ baseInputButton pn title ++baseInputButton :: PlayerNumber -> String -> Field () +baseInputButton pn title = baseInputEvent pn title Button -- ** Textarea inputs -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 title handler pn = onEvent (inputTextarea pn title) (\(en, a) -> handler en a) onInputTextarea_ :: String -> (String -> Nomex ()) -> PlayerNumber -> Nomex EventNumber -onInputTextarea_ title handler pn = onEvent_ (inputTextarea pn title) (handler . inputTextareaData) +onInputTextarea_ title handler pn = onEvent_ (inputTextarea pn title) handler onInputTextareaOnce :: String -> (String -> Nomex ()) -> PlayerNumber -> Nomex EventNumber -onInputTextareaOnce title handler pn = onEventOnce (inputTextarea pn title) (handler . inputTextareaData) +onInputTextareaOnce title handler pn = onEventOnce (inputTextarea pn title) handler -inputTextareaData :: EventData (Input String) -> String -inputTextareaData (InputData (TextAreaData a)) = a -inputTextareaData a = error $ "Not a Textarea Data: " ++ show a +inputTextarea :: PlayerNumber -> String -> Event String +inputTextarea pn title = baseEvent $ baseInputTextarea pn title+ +baseInputTextarea :: PlayerNumber -> String -> Field String +baseInputTextarea pn title = baseInputEvent pn title TextArea
src/Language/Nomyx/Outputs.hs view
@@ -58,7 +58,7 @@ delOutput = DelOutput -- permanently display a variable -displayVar :: (Typeable a, Show a, Eq a) => Maybe PlayerNumber -> MsgVar a -> (Maybe a -> NomexNE String) -> Nomex OutputNumber +displayVar :: (Typeable a, Show 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)@@ -66,17 +66,17 @@ -- permanently display a variable -displayVar' :: (Typeable a, Show a, Eq a) => Maybe PlayerNumber -> MsgVar a -> (a -> NomexNE String) -> Nomex OutputNumber +displayVar' :: (Typeable a, Show 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 :: (Typeable a, Show 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 :: (Typeable a, Show a, Typeable i, Show 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 :: (Typeable a, Show a, Typeable i, Show 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
@@ -12,6 +12,7 @@ PlayerName, PlayerInfo(..), Player(..),+ playerEvent, playerNumber, playerName, getPlayers, getPlayer, getPlayerName, setPlayerName, @@ -88,8 +89,8 @@ forEachPlayer action actionWhenArrive actionWhenLeave = do pns <- liftEffect getAllPlayerNumbers mapM_ action pns- an <- onEvent_ (Player Arrive) $ \(PlayerData p) -> actionWhenArrive $ _playerNumber p- ln <- onEvent_ (Player Leave) $ \(PlayerData p) -> actionWhenLeave $ _playerNumber p+ an <- onEvent_ (playerEvent Arrive) $ actionWhenArrive . _playerNumber+ ln <- onEvent_ (playerEvent Leave) $ actionWhenLeave . _playerNumber return (an, ln) -- | perform the same action for each players, including new players
src/Language/Nomyx/Rules.hs view
@@ -23,7 +23,7 @@ autoActivate, activateOrReject, simulate,- metaruleVar, createMetaruleVar, addMetarule, testWithMetaRules,+ metaruleVar, createMetaruleVar, addMetarule, testWithMetaRules, displayMetarules, legal, illegal, noPlayPlayer, immutableRule, autoDelete, eraseAllRules,@@ -35,6 +35,7 @@ import Language.Nomyx.Expression import Language.Nomyx.Events import Language.Nomyx.Variables+import Language.Nomyx.Outputs import Data.Lens import Control.Monad import Data.List@@ -91,9 +92,7 @@ getFreeRuleNumber :: NomexNE RuleNumber-getFreeRuleNumber = do- rs <- getRules- return $ getFreeNumber $ map _rNumber rs+getFreeRuleNumber = getFreeNumber . map _rNumber <$> getRules getFreeNumber :: (Eq a, Num a, Enum a) => [a] -> a getFreeNumber l = head [a| a <- [1..], not $ a `elem` l]@@ -114,40 +113,73 @@ modifyRule :: RuleNumber -> RuleInfo -> Nomex Bool modifyRule rn r = ModifyRule rn r +-- | allows a rule to retrieve its own number (for auto-deleting for example) +getSelfRuleNumber :: NomexNE RuleNumber +getSelfRuleNumber = SelfRuleNumber + +getSelfRule :: NomexNE RuleInfo +getSelfRule = do + srn <- getSelfRuleNumber + rs:[] <- getRulesByNumbers [srn] + return rs +-- | activate or reject a rule+activateOrReject :: RuleInfo -> Bool -> Nomex ()+activateOrReject r b = if b then activateRule_ (_rNumber r) else rejectRule_ (_rNumber r)++-- | a rule can autodelete itself (generaly after having performed some actions)+autoDelete :: Nomex ()+autoDelete = liftEffect getSelfRuleNumber >>= suppressRule_++-- | All rules from player p are erased:+eraseAllRules :: PlayerNumber -> Nomex Bool+eraseAllRules p = do+ rs <- liftEffect $ getRules+ let myrs = filter ((== p) . getL rProposedBy) rs+ res <- mapM (suppressRule . _rNumber) myrs+ return $ and res+ -- | This rule will activate automatically any new rule. autoActivate :: Nomex ()-autoActivate = void $ onEvent_ (RuleEv Proposed) (activateRule_ . _rNumber . ruleData)+autoActivate = void $ onEvent_ (ruleEvent Proposed) (activateRule_ . _rNumber) -- * Meta Rules +-- | A meta rule is a rule that can juge the legality of another rule. type MetaRule = RuleInfo -> NomexNE Bool -metaruleVar :: MsgVar [MetaRule]+-- | The meta rules are stored in a list variable+metaruleVar :: MsgVar [(String, MetaRule)] metaruleVar = msgVar "metarules" +-- | create the meta rule variable createMetaruleVar :: Nomex ()-createMetaruleVar = void $ newMsgVar (getMsgVarName metaruleVar) ([] :: [MetaRule])+createMetaruleVar = void $ newMsgVar' metaruleVar [] -addMetarule :: MetaRule -> Nomex ()-addMetarule mr = void $ modifyMsgVar metaruleVar (mr:)+-- | add a new metarule to the list+addMetarule :: MetaRule -> String -> Nomex ()+addMetarule mr code = void $ modifyMsgVar metaruleVar ((code, mr):) +-- | use the list of meta rules to juge a new rule 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+ Just mrs -> and <$> mapM (($r) . snd) mrs+ Nothing -> return False +displayMetarules :: Nomex ()+displayMetarules = void $ displayVar Nothing metaruleVar dispAll where+ dispAll mvs = return $ maybe "No meta rules" (("Meta Rules:\n" ++) . concatMap disp) mvs+ disp (s, _) = s ++ "\n"+ -- | A rule will be always legal-legal :: Nomex ()-legal = addMetarule (const $ return True)+legal :: MetaRule+legal = const $ return True -- | A rule will be always illegal-illegal :: Nomex ()-illegal = addMetarule (const $ return False)+illegal :: MetaRule+illegal = const $ return False -- | Player p cannot propose any more rules@@ -165,32 +197,7 @@ simulate :: Nomex a -> NomexNE Bool -> NomexNE Bool simulate sim test = Simu sim test --- | activate or reject a rule-activateOrReject :: RuleInfo -> Bool -> Nomex ()-activateOrReject r b = if b then activateRule_ (_rNumber r) else rejectRule_ (_rNumber r) --- | a rule can autodelete itself (generaly after having performed some actions)-autoDelete :: Nomex ()-autoDelete = liftEffect getSelfRuleNumber >>= suppressRule_---- | All rules from player p are erased:-eraseAllRules :: PlayerNumber -> Nomex Bool-eraseAllRules p = do- 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 :: NomexNE RuleNumber -getSelfRuleNumber = SelfRuleNumber - -getSelfRule :: NomexNE RuleInfo -getSelfRule = do - srn <- getSelfRuleNumber - rs:[] <- getRulesByNumbers [srn] - return rs -- | a default rule defaultRule = RuleInfo {
src/Language/Nomyx/Variables.hs view
@@ -11,8 +11,8 @@ V(..), VEvent(..), MsgVar(..),- newVar, newVar_, readVar, readVar_, writeVar, modifyVar, delVar, - newMsgVar, newMsgVar_, readMsgVar, readMsgVar_, writeMsgVar, modifyMsgVar, delMsgVar,+ newVar, newVar_, newVar', readVar, readVar_, writeVar, modifyVar, delVar, + newMsgVar, newMsgVar_, newMsgVar', readMsgVar, readMsgVar_, writeMsgVar, modifyMsgVar, delMsgVar, msgVar, newMsgVarOnEvent, onMsgVarEvent, onMsgVarChange, onMsgVarDelete, @@ -30,7 +30,8 @@ import Language.Nomyx.Expression import Language.Nomyx.Events import Data.Typeable -import Control.Monad.State +import Control.Monad.State+import Control.Applicative import Data.Maybe import qualified Data.Map as M import Data.Map hiding (map, filter, insert, mapMaybe, null) @@ -43,10 +44,13 @@ newVar_ :: (Typeable a, Show a) => VarName -> a -> Nomex (V a) newVar_ s a = partial "newVar_: Variable existing" (newVar s a) ++newVar' :: (Typeable a, Show a) => V a -> a -> Nomex Bool +newVar' v a = maybe False (const True) <$> (newVar (varName v) a) -- | variable reading readVar :: (Typeable a, Show a) => V a -> NomexNE (Maybe a) -readVar = ReadVar +readVar = ReadVar 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) @@ -69,23 +73,26 @@ data MsgVar a = MsgVar {message :: Msg (VEvent a), variable :: V a } msgVar :: String -> MsgVar a -msgVar a = MsgVar (Message a) (V a) +msgVar a = MsgVar (Msg a) (V 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) + return $ mv >>= Just . MsgVar (Msg name) 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) => MsgVar a -> a -> Nomex Bool +newMsgVar' v a = maybe False (const True) <$> (newMsgVar (getMsgVarName v) a) -- | 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 :: (Typeable a, Show a, Eq 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 - onMessage m $ f . messageData + onMessage m f return mv Nothing -> return Nothing @@ -104,19 +111,19 @@ 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 :: (Typeable a, Show a) => MsgVar a -> Nomex Bool delMsgVar (MsgVar m v) = do sendMessage m VDeleted - delAllEvents m + --delAllEvents (messageEvent m) delVar v 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 + onMessage m f -- | adds a callback for each of the MsgVar events: Create, Update, Delete -onMsgVarChange :: (Typeable a, Show a) +onMsgVarChange :: (Typeable a, Show a, Eq a) => MsgVar a -- ^ the MsgVar -> (a -> Nomex b) -- ^ callback on creation (called immediatly) -> (a -> b -> Nomex ()) -- ^ callback on update @@ -129,7 +136,7 @@ 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 :: (Typeable a, Show a) => MsgVar a -> Nomex () -> Nomex EventNumber onMsgVarDelete mv f = onMsgVarEvent mv onMsgVarDel where onMsgVarDel VDeleted = f onMsgVarDel _ = return ()@@ -164,7 +171,7 @@ 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, Typeable i, Show i) => VarName -> [i] -> (VEvent [(i,Maybe a)] -> Nomex ()) -> Nomex (Maybe (ArrayVar i a)) +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' name l f = do let list = map (\i -> (i, Nothing)) l newMsgVarOnEvent name list f
src/Language/Nomyx/Vote.hs view
@@ -28,6 +28,7 @@ import Control.Monad.Error (MonadError(..)) + data VoteType a = ExclusiveVote (Maybe (Alts a)) | NonExclusiveVote [Alts a] @@ -72,7 +73,7 @@ voteWith countVotes assessors toVote als = do pns <- liftEffect getAllPlayerNumbers let toVoteName = name toVote - let msgEnd = Message ("Result of votes for " ++ toVoteName) :: Msg [Alts a] + let msgEnd = Msg ("Result of votes for " ++ toVoteName) :: Msg [Alts a] --create an array variable to store the votes (voteVar :: ArrayVar PlayerNumber (Alts a)) <- newArrayVar_ ("Votes for " ++ toVoteName) pns --create the voting buttons@@ -109,7 +110,7 @@ assessOnTimeLimit time = do (VoteData msgEnd voteVar i assess _) <- get put (VoteData msgEnd voteVar i assess (Just time)) - lift $ void $ onEvent_ (Time time) $ \_ -> do + lift $ void $ onEvent_ (timeEvent time) $ \_ -> do votes <- getMsgVarData_ voteVar sendMessage msgEnd (assess $ getVoteStats votes True) @@ -244,16 +245,16 @@ return (name, showChoice v) displayVoteResult :: (Votable a) => String -> VoteData a -> Nomex OutputNumber-displayVoteResult toVoteName (VoteData msgEnd voteVar _ _ _) = onMessage msgEnd $ \(MessageData result) -> do +displayVoteResult toVoteName (VoteData msgEnd voteVar _ _ _) = onMessage msgEnd $ \result -> do vs <- getMsgVarData_ voteVar 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 For onRuleProposed :: (RuleInfo -> Nomex (Msg [ForAgainst]) ) -> Rule -onRuleProposed f = void $ onEvent_ (RuleEv Proposed) $ \(RuleData rule) -> do +onRuleProposed f = void $ onEvent_ (ruleEvent Proposed) $ \rule -> do resp <- f rule- void $ onMessageOnce resp $ (activateOrReject rule) . (== [For]) . messageData+ void $ onMessageOnce resp $ (activateOrReject rule) . (== [For]) -- * Referendum & elections @@ -269,12 +270,12 @@ referendum name action = do msg <- voteWith_ (majority `withQuorum` 2) (assessOnEveryVote >> assessOnTimeDelay oneDay) (Referendum name) void $ onMessageOnce msg resolution where- resolution (MessageData [Yes]) = do+ resolution [Yes] = do outputAll_ "Positive result of referendum" action- resolution (MessageData [No]) = void $ outputAll_ "Negative result of referendum"- resolution (MessageData []) = void $ outputAll_ "No result for referendum"- resolution (MessageData _) = throwError "Impossible result for referendum"+ resolution [No] = void $ outputAll_ "Negative result of referendum"+ resolution [] = void $ outputAll_ "No result for referendum"+ resolution _ = throwError "Impossible result for referendum" data Election = Election String deriving (Typeable)@@ -297,8 +298,8 @@ elections name pns action = do msg <- voteWith majority (assessOnTimeDelay oneDay) (Election name) (Candidate <$> pns) void $ onMessageOnce msg resolution where- resolution (MessageData [Candidate pi]) = do+ resolution [Candidate pi] = do outputAll_ $ "Result of elections: player(s) " ++ (show $ _playerName pi) ++ " won!" action $ _playerNumber pi- resolution (MessageData []) = void $ outputAll_ "Result of elections: nobody won!"- resolution (MessageData _) = throwError "Impossible result for elections"+ resolution [] = void $ outputAll_ "Result of elections: nobody won!"+ resolution _ = throwError "Impossible result for elections"