diff --git a/Nomyx-Language.cabal b/Nomyx-Language.cabal --- a/Nomyx-Language.cabal +++ b/Nomyx-Language.cabal @@ -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 diff --git a/README b/README --- a/README +++ b/README @@ -1,10 +1,8 @@ -[![Build Status](https://travis-ci.org/cdupont/Nomyx-Language.png?branch=master)](https://travis-ci.org/cdupont/Nomyx-Language) -[![Hackage](https://budueba.com/hackage/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 ============ diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,6 @@ +#!/usr/bin/runhaskell +> module Main where +> import Distribution.Simple +> main :: IO () +> main = defaultMain + diff --git a/src/Language/Nomyx.hs b/src/Language/Nomyx.hs --- a/src/Language/Nomyx.hs +++ b/src/Language/Nomyx.hs @@ -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 diff --git a/src/Language/Nomyx/Engine.hs b/src/Language/Nomyx/Engine.hs deleted file mode 100644 --- a/src/Language/Nomyx/Engine.hs +++ /dev/null @@ -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 - diff --git a/src/Language/Nomyx/Engine/Evaluation.hs b/src/Language/Nomyx/Engine/Evaluation.hs deleted file mode 100644 --- a/src/Language/Nomyx/Engine/Evaluation.hs +++ /dev/null @@ -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" diff --git a/src/Language/Nomyx/Engine/Game.hs b/src/Language/Nomyx/Engine/Game.hs deleted file mode 100644 --- a/src/Language/Nomyx/Engine/Game.hs +++ /dev/null @@ -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] ) - - - diff --git a/src/Language/Nomyx/Engine/GameEvents.hs b/src/Language/Nomyx/Engine/GameEvents.hs deleted file mode 100644 --- a/src/Language/Nomyx/Engine/GameEvents.hs +++ /dev/null @@ -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 - diff --git a/src/Language/Nomyx/Engine/Test.hs b/src/Language/Nomyx/Engine/Test.hs deleted file mode 100644 --- a/src/Language/Nomyx/Engine/Test.hs +++ /dev/null @@ -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 - - - diff --git a/src/Language/Nomyx/Engine/Utils.hs b/src/Language/Nomyx/Engine/Utils.hs deleted file mode 100644 --- a/src/Language/Nomyx/Engine/Utils.hs +++ /dev/null @@ -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 - diff --git a/src/Language/Nomyx/Events.hs b/src/Language/Nomyx/Events.hs --- a/src/Language/Nomyx/Events.hs +++ b/src/Language/Nomyx/Events.hs @@ -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 diff --git a/src/Language/Nomyx/Examples.hs b/src/Language/Nomyx/Examples.hs --- a/src/Language/Nomyx/Examples.hs +++ b/src/Language/Nomyx/Examples.hs @@ -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 diff --git a/src/Language/Nomyx/Expression.hs b/src/Language/Nomyx/Expression.hs --- a/src/Language/Nomyx/Expression.hs +++ b/src/Language/Nomyx/Expression.hs @@ -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. diff --git a/src/Language/Nomyx/Inputs.hs b/src/Language/Nomyx/Inputs.hs --- a/src/Language/Nomyx/Inputs.hs +++ b/src/Language/Nomyx/Inputs.hs @@ -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 diff --git a/src/Language/Nomyx/Outputs.hs b/src/Language/Nomyx/Outputs.hs --- a/src/Language/Nomyx/Outputs.hs +++ b/src/Language/Nomyx/Outputs.hs @@ -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 diff --git a/src/Language/Nomyx/Players.hs b/src/Language/Nomyx/Players.hs --- a/src/Language/Nomyx/Players.hs +++ b/src/Language/Nomyx/Players.hs @@ -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 diff --git a/src/Language/Nomyx/Rules.hs b/src/Language/Nomyx/Rules.hs --- a/src/Language/Nomyx/Rules.hs +++ b/src/Language/Nomyx/Rules.hs @@ -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 { diff --git a/src/Language/Nomyx/Variables.hs b/src/Language/Nomyx/Variables.hs --- a/src/Language/Nomyx/Variables.hs +++ b/src/Language/Nomyx/Variables.hs @@ -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 diff --git a/src/Language/Nomyx/Vote.hs b/src/Language/Nomyx/Vote.hs --- a/src/Language/Nomyx/Vote.hs +++ b/src/Language/Nomyx/Vote.hs @@ -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"