diff --git a/Nomyx-Language.cabal b/Nomyx-Language.cabal --- a/Nomyx-Language.cabal +++ b/Nomyx-Language.cabal @@ -1,9 +1,9 @@ name: Nomyx-Language -version: 0.3.2 +version: 0.4.0 cabal-version: >=1.6 ----Warning: For using "cabal sdist", this patch is needed in cabal: https://github.com/haskell/cabal/pull/1110 ----To allow sdist to work with exported generated modules (Paths_Nomyx_Language) -build-type: Simple +---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) +build-type: Custom license: BSD3 license-file: LICENSE copyright: 2012 Corentin Dupont @@ -12,47 +12,53 @@ synopsis: Language to express rules for Nomic description: Provide a DSL to express rules for a Nomic game, with evaluation engine. See package Nomyx for a full game implementation. category: Language -Homepage: www.nomyx.net +Homepage: http://www.nomyx.net author: Corentin Dupont -data-files: src/Language/Nomyx/Definition.hs +data-files: src/Language/Nomyx.hs src/Language/Nomyx/Examples.hs src/Language/Nomyx/Expression.hs - src/Language/Nomyx/Rule.hs - src/Language/Nomyx/Test.hs + src/Language/Nomyx/Rules.hs + src/Language/Nomyx/Inputs.hs + src/Language/Nomyx/Outputs.hs + src/Language/Nomyx/Variables.hs + src/Language/Nomyx/Events.hs + src/Language/Nomyx/Players.hs src/Language/Nomyx/Vote.hs + data-dir: "" extra-source-files: AUTHORS README library - build-depends: base ==4.*, - containers -any, - ghc -any, - hint-server -any, - hslogger -any, - mtl -any, - old-locale -any, - safe -any, - stm -any, - template-haskell -any, - time -any, - time-recurrence -any, - DebugTraceHelpers -any, - data-lens -any, - data-lens-template -any, - data-lens-fd -any, - Boolean -any, - safecopy -any, - transformers -any + build-depends: DebugTraceHelpers == 0.12.*, + Boolean == 0.2.*, + base == 4.6.*, + containers == 0.5.*, + data-lens == 2.10.*, + data-lens-template == 2.1.*, + data-lens-fd == 2.0.*, + ghc == 7.6.*, + mtl == 2.1.*, + old-locale == 1.0.*, + safe == 0.3.*, + time == 1.4.*, + time-recurrence == 0.9.*, + transformers == 0.3.* exposed-modules: Language.Nomyx Language.Nomyx.Expression - Language.Nomyx.Definition - Language.Nomyx.Evaluation Language.Nomyx.Examples - Language.Nomyx.Rule + Language.Nomyx.Variables + Language.Nomyx.Events + Language.Nomyx.Inputs + Language.Nomyx.Outputs + Language.Nomyx.Players + Language.Nomyx.Rules Language.Nomyx.Vote - Language.Nomyx.Test - Language.Nomyx.Game - Language.Nomyx.Utils + 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 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,9 @@ +module Main where +import Distribution.Simple +import Paths_Nomyx_Language + +main :: IO () +main = do + putStrLn "toto" + defaultMain + diff --git a/Setup.lhs b/Setup.lhs deleted file mode 100644 --- a/Setup.lhs +++ /dev/null @@ -1,6 +0,0 @@ -#!/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,19 +1,24 @@ +-- | This module re-exports the elements necessary to compose a Nomyx rule. module Language.Nomyx ( - module Language.Nomyx.Expression, - module Language.Nomyx.Definition, - module Language.Nomyx.Rule, - module Language.Nomyx.Examples, - module Language.Nomyx.Evaluation, - module Language.Nomyx.Vote, - module Language.Nomyx.Utils) where + module Language.Nomyx.Expression, -- Nomyx Expression DSL + module Language.Nomyx.Outputs, -- create outputs + module Language.Nomyx.Inputs, -- create inputs + module Language.Nomyx.Events, -- create events + module Language.Nomyx.Players, -- manage players + module Language.Nomyx.Variables, -- create variables + module Language.Nomyx.Rules, -- manage rules + module Language.Nomyx.Vote -- create votations + ) where import Language.Nomyx.Expression -import Language.Nomyx.Definition -import Language.Nomyx.Rule -import Language.Nomyx.Examples -import Language.Nomyx.Evaluation +import Language.Nomyx.Outputs +import Language.Nomyx.Inputs +import Language.Nomyx.Events +import Language.Nomyx.Players +import Language.Nomyx.Variables +import Language.Nomyx.Rules import Language.Nomyx.Vote -import Language.Nomyx.Utils + diff --git a/src/Language/Nomyx/Definition.hs b/src/Language/Nomyx/Definition.hs deleted file mode 100644 --- a/src/Language/Nomyx/Definition.hs +++ /dev/null @@ -1,637 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable, GADTs, ScopedTypeVariables, TupleSections, QuasiQuotes, FlexibleInstances #-} - --- | All the building blocks to build rules. -module Language.Nomyx.Definition where - -import Language.Nomyx.Expression -import Data.Typeable -import Control.Monad.State -import Data.List -import Data.Maybe -import Data.Time hiding (getCurrentTime) -import qualified Data.Map as M -import Data.Map hiding (map, filter, insert, mapMaybe, null) -import Data.Time.Recurrence hiding (filter) -import Safe -import Data.Lens -import Control.Applicative -import Data.Boolean -import Control.Monad.Error -import Language.Nomyx.Utils - --- * Variables --- | variable creation -newVar :: (Typeable a, Show a, Eq a) => VarName -> a -> Nomex (Maybe (V a)) -newVar = NewVar - -newVar_ :: (Typeable a, Show a, Eq a) => VarName -> a -> Nomex (V a) -newVar_ s a = partial "newVar_: Variable existing" (newVar s a) - --- | variable reading -readVar :: (Typeable a, Show a, Eq a) => (V a) -> Nomex (Maybe a) -readVar = ReadVar - -readVar_ :: forall a. (Typeable a, Show a, Eq a) => (V a) -> Nomex a -readVar_ v@(V a) = partial ("readVar_: Variable \"" ++ a ++ "\" with type \"" ++ (show $ typeOf v) ++ "\" not existing") (readVar v) - --- | variable writing -writeVar :: (Typeable a, Show a, Eq a) => (V a) -> a -> Nomex Bool -writeVar = WriteVar - -writeVar_ :: (Typeable a, Show a, Eq a) => (V a) -> a -> Nomex () -writeVar_ var val = void $ writeVar var val - --- | modify a variable using the provided function -modifyVar :: (Typeable a, Show a, Eq a) => (V a) -> (a -> a) -> Nomex () -modifyVar v f = writeVar_ v . f =<< readVar_ v - --- | delete variable -delVar :: (V a) -> Nomex Bool -delVar = DelVar - -delVar_ :: (V a) -> Nomex () -delVar_ v = void $ delVar v - --- * Message Variable --- | a MsgVar is a variable with a message attached, allowing to trigger registered functions anytime the var if modified -data VEvent a = VUpdated a | VDeleted deriving (Typeable, Show, Eq) -data MsgVar a = MsgVar (Msg (VEvent a)) (V a) - -msgVar :: String -> MsgVar a -msgVar a = MsgVar (Message a) (V a) - -newMsgVar :: (Typeable a, Show a, Eq a) => VarName -> a -> Nomex (Maybe (MsgVar a)) -newMsgVar name a = do - mv <- newVar name a - return $ mv >>= Just . MsgVar (Message name) - -newMsgVar_ :: (Typeable a, Show a, Eq a) => VarName -> a -> Nomex (MsgVar a) -newMsgVar_ name a = partial "newMsgVar_: Variable existing" (newMsgVar name a) - - -newMsgVar' :: (Typeable a, Show a, Eq a) => VarName -> a -> (VEvent a -> Nomex()) -> Nomex (Maybe (MsgVar a)) -newMsgVar' name a f = do - mv <- newMsgVar name a - case mv of - Just (MsgVar m _) -> do - onMessage m $ f . messageData - return mv - Nothing -> return Nothing - -writeMsgVar :: (Typeable a, Show a, Eq a) => MsgVar a -> a -> Nomex Bool -writeMsgVar (MsgVar m v) a = do - r <- writeVar v a - sendMessage m (VUpdated a) - return r - -writeMsgVar_ :: (Typeable a, Show a, Eq a) => MsgVar a -> a -> Nomex () -writeMsgVar_ mv a = void $ writeMsgVar mv a - -readMsgVar :: (Typeable a, Show a, Eq a) => MsgVar a -> Nomex (Maybe a) -readMsgVar (MsgVar _ v) = readVar v - -readMsgVar_ :: (Typeable a, Show a, Eq a) => MsgVar a -> Nomex a -readMsgVar_ mv = partial "readMsgVar_: variable not existing" (readMsgVar mv) - -modifyMsgVar :: (Typeable a, Show a, Eq a) => MsgVar a -> (a -> a) -> Nomex () -modifyMsgVar mv f = writeMsgVar_ mv . f =<< readMsgVar_ mv - -delMsgVar :: (Typeable a, Show a, Eq a) => MsgVar a -> Nomex Bool -delMsgVar (MsgVar m v) = do - sendMessage m VDeleted - delAllEvents m - delVar v - -onMsgVarChange :: (Typeable a, Show a, Eq a) => MsgVar a -> (VEvent a -> Nomex()) -> Nomex () -onMsgVarChange mv f = do - m <- getMsgVarMessage mv - onMessage m $ \(MessageData v) -> f v - -onMsgVarEvent :: (Typeable a, Show a, Eq a) - => MsgVar a - -> (a -> Nomex b) - -> (a -> b -> Nomex()) - -> (b -> Nomex()) - -> Nomex () -onMsgVarEvent mv create update delete = do - val <- readMsgVar_ mv - c <- create val - onMsgVarChange mv $ f c where - f c' (VUpdated v) = update v c' - f c' VDeleted = delete c' - --- | get the messsage triggered when the array is filled -getMsgVarMessage :: (Typeable a, Show a, Eq a) => (MsgVar a) -> Nomex (Msg (VEvent a)) -getMsgVarMessage (MsgVar m _) = return m - --- | get the association array -getMsgVarData :: (Typeable a, Show a, Eq a) => (MsgVar a) -> Nomex (Maybe a) -getMsgVarData (MsgVar _ v) = readVar v - -getMsgVarData_ :: (Typeable a, Show a, Eq a) => (MsgVar a) -> Nomex a -getMsgVarData_ (MsgVar _ v) = readVar_ v - -getMsgVarName :: (Typeable a, Show a, Eq a) => (MsgVar a) -> String -getMsgVarName (MsgVar _ (V varName)) = varName - - --- * Variable arrays --- | ArrayVar is an indexed array with a signal attached triggered at every change. --- | each indexed elements starts empty (value=Nothing). -type ArrayVar i a = MsgVar [(i, Maybe a)] - --- | initialize an empty ArrayVar -newArrayVar :: (Typeable a, Show a, Eq a, Typeable i, Show i, Eq i) => VarName -> [i] -> Nomex (Maybe (ArrayVar i a)) -newArrayVar name l = do - let list = map (\i -> (i, Nothing)) l - newMsgVar name list - -newArrayVar_ :: (Typeable a, Show a, Eq a, Typeable i, Show i, Eq i) => VarName -> [i] -> Nomex (ArrayVar i a) -newArrayVar_ name l = partial "newArrayVar_: Variable existing" (newArrayVar name l) - --- | initialize an empty ArrayVar, registering a callback that will be triggered at every change -newArrayVar' :: (Typeable a, Show a, Eq a, Typeable i, Show i, Eq i) => VarName -> [i] -> (VEvent [(i,Maybe a)] -> Nomex ()) -> Nomex (Maybe (ArrayVar i a)) -newArrayVar' name l f = do - let list = map (\i -> (i, Nothing)) l - newMsgVar' name list f - --- | initialize an empty ArrayVar, registering a callback. --- the ArrayVar will be deleted when full -newArrayVarOnce :: (Ord i, Typeable a, Show a, Eq a, Typeable i, Show i) => VarName -> [i] -> (VEvent [(i, Maybe a)] -> Nomex ()) -> Nomex (Maybe (ArrayVar i a)) -newArrayVarOnce name l f = do - mv <- newArrayVar' name l f - when (isJust mv) $ cleanOnFull $ fromJust mv - return mv - -cleanOnFull :: (Typeable a, Show a, Eq a, Ord i, Typeable i, Show i) => (ArrayVar i a) -> Nomex () -cleanOnFull ar = do - m <- getMsgVarMessage ar - onMessage m $ \_ -> do - full <- (isFullArrayVar_ ar) - when full $ void $ delMsgVar ar - return () - return () - -isFullArrayVar_ :: (Ord i, Typeable a, Show a, Eq a, Typeable i, Show i) => (ArrayVar i a) -> Nomex Bool -isFullArrayVar_ av = do - md <- getMsgVarData av - return $ and $ map isJust $ map snd $ fromJust md - - --- | store one value and the given index. If this is the last filled element, the registered callbacks are triggered. -putArrayVar :: (Ord i, Typeable a, Show a, Eq a, Typeable i, Show i) => (ArrayVar i a) -> i -> a -> Nomex Bool -putArrayVar mv i a = do - ma <- readMsgVar mv - case ma of - Just ar -> do - let ar2 = M.insert i (Just a) (fromList ar) - writeMsgVar mv (toList ar2) - Nothing -> return False - -putArrayVar_ :: (Ord i, Typeable a, Show a, Eq a, Typeable i, Show i) => (ArrayVar i a) -> i -> a -> Nomex () -putArrayVar_ mv i a = void $ putArrayVar mv i a - - - - --- * Events - --- | register a callback on an event -onEvent :: (Typeable e, Show e, Eq e) => Event e -> ((EventNumber, EventData 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 () -onEvent_ e h = do - OnEvent e (\(_, d) -> h d) - return () - --- | set an handler for an event that will be triggered only once -onEventOnce :: (Typeable e, Show e, Eq e) => Event e -> (EventData e -> Nomex ()) -> Nomex EventNumber -onEventOnce e h = do - let handler (en, ed) = delEvent_ en >> h ed - n <- OnEvent e handler - return n - --- | set an handler for an event that will be triggered only once -onEventOnce_ :: (Typeable e, Show e, Eq e) => Event e -> (EventData e -> Nomex ()) -> Nomex () -onEventOnce_ e h = do - let handler (en, ed) = delEvent_ en >> h ed - OnEvent e handler - return () - -delEvent :: EventNumber -> Nomex Bool -delEvent = DelEvent - -delEvent_ :: EventNumber -> Nomex () -delEvent_ e = delEvent e >> return () - -delAllEvents :: (Typeable e, Show e, Eq e) => Event e -> Nomex () -delAllEvents = DelAllEvents - --- | broadcast a message that can be catched by another rule -sendMessage :: (Typeable a, Show a, Eq a) => Msg a -> a -> Nomex () -sendMessage = SendMessage - -sendMessage_ :: Msg () -> Nomex () -sendMessage_ m = SendMessage m () - --- | subscribe on a message -onMessage :: (Typeable m, Show m) => Msg m -> (MsgData m -> Nomex ()) -> Nomex () -onMessage m f = onEvent_ m f - -onMessageOnce :: (Typeable m, Show m) => Msg m -> (MsgData m -> Nomex ()) -> Nomex () -onMessageOnce m f = onEventOnce_ m f - --- | on the provided schedule, the supplied function will be called -schedule :: (Schedule Freq) -> (UTCTime -> Nomex ()) -> Nomex () -schedule sched f = do - now <- getCurrentTime - let next = head $ starting now $ sched - if (next == now) then executeAndScheduleNext (f . timeData) sched (TimeData now) - else onEventOnce_ (Time next) $ executeAndScheduleNext (f . timeData) sched where - -executeAndScheduleNext :: (EventData Time -> Nomex ()) -> (Schedule Freq) -> (EventData Time) -> Nomex () -executeAndScheduleNext f sched now = do - f now - let rest = drop 1 $ starting (timeData now) $ sched - when (rest /= []) $ onEventOnce_ (Time $ head rest) $ executeAndScheduleNext f sched - - -schedule_ :: (Schedule Freq) -> Nomex () -> Nomex () -schedule_ ts f = schedule ts (\_-> f) - ---at each time provided, the supplied function will be called -schedule' :: [UTCTime] -> (UTCTime -> Nomex ()) -> Nomex () -schedule' sched f = do - let sched' = sort sched - now <- getCurrentTime - let nextMay = headMay $ filter (>=now) $ sched' - case nextMay of - Just next -> do - if (next == now) then executeAndScheduleNext' (f . timeData) sched' (TimeData now) - else onEventOnce_ (Time next) $ executeAndScheduleNext' (f . timeData) sched' - Nothing -> return () - - -executeAndScheduleNext' :: (EventData Time -> Nomex ()) -> [UTCTime] -> (EventData Time) -> Nomex () -executeAndScheduleNext' f sched now = do - f now - let rest = drop 1 $ sched - when (rest /= []) $ onEventOnce_ (Time $ head rest) $ executeAndScheduleNext' f sched - - -schedule'_ :: [UTCTime] -> Nomex () -> Nomex () -schedule'_ ts f = schedule' ts (\_-> f) - --- * Rule management - --- | activate a rule: change its state to Active and execute it -activateRule :: RuleNumber -> Nomex Bool -activateRule = ActivateRule - -activateRule_ :: RuleNumber -> Nomex () -activateRule_ r = activateRule r >> return () - --- | reject a rule: change its state to Suppressed and suppresses all its environment (events, variables, inputs) --- the rule can be activated again later -rejectRule :: RuleNumber -> Nomex Bool -rejectRule = RejectRule - -rejectRule_ :: RuleNumber -> Nomex () -rejectRule_ r = void $ rejectRule r - -getRules :: Nomex [Rule] -getRules = GetRules - -getActiveRules :: Nomex [Rule] -getActiveRules = return . (filter ((== Active) . _rStatus) ) =<< getRules - -getRule :: RuleNumber -> Nomex (Maybe Rule) -getRule rn = do - rs <- GetRules - return $ find ((== rn) . getL rNumber) rs - -getRulesByNumbers :: [RuleNumber] -> Nomex [Rule] -getRulesByNumbers rns = mapMaybeM getRule rns - -getRuleFuncs :: Nomex [RuleFunc] -getRuleFuncs = return . (map _rRuleFunc) =<< getRules - --- | add a rule to the game, it will have to be activated -addRule :: Rule -> Nomex Bool -addRule r = AddRule r - -addRule_ :: Rule -> Nomex () -addRule_ r = void $ AddRule r - -addRuleParams :: RuleName -> RuleFunc -> RuleCode -> String -> Nomex RuleNumber -addRuleParams name func code desc = do - number <- getFreeRuleNumber - res <- addRule $ defaultRule {_rName = name, _rRuleFunc = func, _rRuleCode = code, _rNumber = number, _rDescription = desc} - return $ if res then number else error "addRuleParams: cannot add rule" - - -getFreeRuleNumber :: Nomex RuleNumber -getFreeRuleNumber = do - rs <- getRules - return $ getFreeNumber $ map _rNumber rs - - ---suppresses completly a rule and its environment from the system -suppressRule :: RuleNumber -> Nomex Bool -suppressRule rn = RejectRule rn - -suppressRule_ :: RuleNumber -> Nomex () -suppressRule_ rn = void $ RejectRule rn - -suppressAllRules :: Nomex Bool -suppressAllRules = do - rs <- getRules - res <- mapM (suppressRule . _rNumber) rs - return $ and res - -modifyRule :: RuleNumber -> Rule -> Nomex Bool -modifyRule rn r = ModifyRule rn r - - --- * Inputs - - --- ** Radio inputs - -inputRadio :: (Eq c, Show c, Typeable c) => PlayerNumber -> String -> [c] -> c -> Event (Input c) -inputRadio pn title cs _ = InputEv (Input pn title (Radio (zip cs (show <$> cs)))) - -inputRadioHead :: (Eq c, Show c, Typeable c) => PlayerNumber -> String -> [c] -> Event (Input c) -inputRadioHead pn title choices = inputRadio pn title choices (head choices) - -inputRadioEnum :: forall c. (Enum c, Bounded c, Typeable c, Eq c, Show c) => PlayerNumber -> String -> c -> Event (Input c) -inputRadioEnum pn title defaultChoice = inputRadio pn title (enumFrom (minBound::c)) defaultChoice - -inputRadioData :: (Show c) => EventData (Input c) -> c -inputRadioData (InputData (RadioData a)) = a -inputRadioData a = error $ "Not a Radio Data: " ++ (show a) - --- | triggers a choice input to the user. The result will be sent to the callback -onInputRadio :: (Typeable a, Eq a, Show a) => String -> [a] -> (EventNumber -> a -> Nomex ()) -> PlayerNumber -> Nomex EventNumber -onInputRadio title choices handler pn = onEvent (inputRadioHead pn title choices) (\(en, InputData (RadioData a)) -> handler en a) - --- | the same, disregard the event number -onInputRadio_ :: (Typeable a, Eq a, Show a) => String -> [a] -> (a -> Nomex ()) -> PlayerNumber -> Nomex () -onInputRadio_ title choices handler pn = onEvent_ (inputRadioHead pn title choices) (handler . inputRadioData) - --- | the same, suppress the event after first trigger -onInputRadioOnce :: (Typeable a, Eq a, Show a) => String -> [a] -> (a -> Nomex ()) -> PlayerNumber -> Nomex EventNumber -onInputRadioOnce title choices handler pn = onEventOnce (inputRadioHead pn title choices) (handler . inputRadioData) - --- | the same, disregard the event number -onInputRadioOnce_ :: (Typeable a, Eq a, Show a) => String -> [a] -> (a -> Nomex ()) -> PlayerNumber -> Nomex () -onInputRadioOnce_ title choices handler pn = onEventOnce_ (inputRadioHead pn title choices) (handler . inputRadioData) - --- | triggers a choice input to the user, using an enumerate as input -onInputRadioEnum :: forall a. (Enum a, Bounded a, Typeable a, Eq a, Show a) => String -> a -> (EventNumber -> a -> Nomex ()) -> PlayerNumber -> Nomex EventNumber -onInputRadioEnum title defaultChoice handler pn = onEvent (inputRadioEnum pn title defaultChoice) (\(en, a) -> handler en (inputRadioData a)) - --- | the same, disregard the event number -onInputRadioEnum_ :: forall a. (Enum a, Bounded a, Typeable a, Eq a, Show a) => String -> a -> (a -> Nomex ()) -> PlayerNumber -> Nomex () -onInputRadioEnum_ title defaultChoice handler pn = onEvent_ (inputRadioEnum pn title defaultChoice) (handler . inputRadioData) - --- | the same, suppress the event after first trigger -onInputRadioEnumOnce_ :: forall a. (Enum a, Bounded a, Typeable a, Eq a, Show a) => String -> a -> (a -> Nomex ()) -> PlayerNumber -> Nomex () -onInputRadioEnumOnce_ title defaultChoice handler pn = onEventOnce_ (inputRadioEnum pn title defaultChoice) (handler . inputRadioData) - --- ** Text inputs - -inputText :: PlayerNumber -> String -> Event (Input String) -inputText pn title = InputEv (Input pn title Text) - -inputTextData :: EventData (Input String) -> String -inputTextData (InputData (TextData a)) = a -inputTextData a = error $ "Not a Text Data: " ++ (show a) - --- | triggers a string input to the user. The result will be sent to the callback -onInputText :: String -> (EventNumber -> String -> Nomex ()) -> PlayerNumber -> Nomex EventNumber -onInputText title handler pn = onEvent (inputText pn title) (\(en, a) -> handler en (inputTextData a)) - --- | asks the player pn to answer a question, and feed the callback with this data. -onInputText_ :: String -> (String -> Nomex ()) -> PlayerNumber -> Nomex () -onInputText_ title handler pn = onEvent_ (inputText pn title) (handler . inputTextData) - --- | asks the player pn to answer a question, and feed the callback with this data. -onInputTextOnce_ :: String -> (String -> Nomex ()) -> PlayerNumber -> Nomex () -onInputTextOnce_ title handler pn = onEventOnce_ (inputText pn title) (handler . inputTextData) - --- ** Checkbox inputs - -inputCheckboxData :: (Show c) => EventData (Input c) -> [c] -inputCheckboxData (InputData (CheckboxData a)) = a -inputCheckboxData a = error $ "Not a Checkbox Data: " ++ (show a) - -inputCheckbox :: (Eq c, Show c, Typeable c) => PlayerNumber -> String -> [(c, String)] -> Event (Input c) -inputCheckbox pn title cs = InputEv (Input pn title (Checkbox cs)) - -onInputCheckbox :: (Typeable a, Eq a, Show a) => String -> [(a, String)] -> (EventNumber -> [a] -> Nomex ()) -> PlayerNumber -> Nomex EventNumber -onInputCheckbox title choices handler pn = onEvent (inputCheckbox pn title choices) (\(en, InputData (CheckboxData a)) -> handler en a) - -onInputCheckbox_ :: (Typeable a, Eq a, Show a) => String -> [(a, String)] -> ([a] -> Nomex ()) -> PlayerNumber -> Nomex () -onInputCheckbox_ title choices handler pn = onEvent_ (inputCheckbox pn title choices) (handler . inputCheckboxData) - --- ** Button inputs - -inputButtonData :: EventData (Input ()) -> () -inputButtonData (InputData ButtonData) = () -inputButtonData a = error $ "Not a Button Data: " ++ (show a) - -inputButton :: PlayerNumber -> String -> Event (Input ()) -inputButton pn title = InputEv (Input pn title Button) - -onInputButton :: String -> (EventNumber -> () -> Nomex ()) -> PlayerNumber -> Nomex EventNumber -onInputButton title handler pn = onEvent (inputButton pn title) (\(en, InputData ButtonData) -> handler en ()) - -onInputButton_ :: String -> (() -> Nomex ()) -> PlayerNumber -> Nomex () -onInputButton_ title handler pn = onEvent_ (inputButton pn title) (handler . inputButtonData) - --- ** Textarea inputs - -inputTextareaData :: EventData (Input String) -> String -inputTextareaData (InputData (TextAreaData a)) = a -inputTextareaData a = error $ "Not a Textarea Data: " ++ (show a) - -inputTextarea :: PlayerNumber -> String -> Event (Input String) -inputTextarea pn title = InputEv (Input pn title TextArea) - -onInputTextarea :: String -> (EventNumber -> String -> Nomex ()) -> PlayerNumber -> Nomex EventNumber -onInputTextarea title handler pn = onEvent (inputTextarea pn title) (\(en, a) -> handler en (inputTextareaData a)) - -onInputTextarea_ :: String -> (String -> Nomex ()) -> PlayerNumber -> Nomex () -onInputTextarea_ title handler pn = onEvent_ (inputTextarea pn title) (handler . inputTextareaData) - -onInputTextareaOnce_ :: String -> (String -> Nomex ()) -> PlayerNumber -> Nomex () -onInputTextareaOnce_ title handler pn = onEventOnce_ (inputTextarea pn title) (handler . inputTextareaData) - --- * Players - --- | get all the players -getPlayers :: Nomex [PlayerInfo] -getPlayers = GetPlayers - --- | Get a specific player -getPlayer :: PlayerNumber -> Nomex (Maybe PlayerInfo) -getPlayer pn = do - pls <- GetPlayers - return $ find ((== pn) . getL playerNumber) pls - --- | Set the name of a player -getPlayerName :: PlayerNumber -> Nomex (Maybe PlayerName) -getPlayerName pn = do - p <- getPlayer pn - return $ _playerName <$> p - --- | Set the name of a player -setPlayerName :: PlayerNumber -> PlayerName -> Nomex Bool -setPlayerName = SetPlayerName - -modifyPlayerName :: PlayerNumber -> (PlayerName -> PlayerName) -> Nomex Bool -modifyPlayerName pn f = do - mn <- getPlayerName pn - case mn of - Just name -> setPlayerName pn (f name) - Nothing -> return False - - --- | Get the total number of players getPlayersNumber :: Nomex Int -getPlayersNumber = length <$> getPlayers - --- | Get all the players number -getAllPlayerNumbers :: Nomex [PlayerNumber] -getAllPlayerNumbers = map _playerNumber <$> getPlayers - --- | Remove the player from the game (kick) -delPlayer :: PlayerNumber -> Nomex Bool -delPlayer = DelPlayer - --- * Outputs - --- | outputs a message to one player -newOutput :: String -> PlayerNumber -> Nomex OutputNumber -newOutput s pn = NewOutput pn s - -newOutput_ :: String -> PlayerNumber -> Nomex () -newOutput_ s pn = void $ NewOutput pn s - -outputAll :: String -> Nomex () -outputAll s = getPlayers >>= mapM_ ((newOutput s) . _playerNumber) - -updateOutput :: OutputNumber -> String -> Nomex Bool -updateOutput = UpdateOutput - -updateOutput_ :: OutputNumber -> String -> Nomex () -updateOutput_ on s = void $ updateOutput on s - -delOutput :: OutputNumber -> Nomex Bool -delOutput = DelOutput - -delOutput_ :: OutputNumber -> Nomex () -delOutput_ on = void $ delOutput on - --- permanently display a variable (update display when variable is updated) -displayVar :: (Typeable a, Show a, Eq a) => PlayerNumber -> MsgVar a -> (a -> String) -> Nomex () -displayVar pn mv dis = onMsgVarEvent - mv - (\a -> newOutput (dis a) pn) - (\a n -> updateOutput_ n (dis a)) - delOutput_ - -displaySimpleVar :: (Typeable a, Show a, Eq a) => PlayerNumber -> String -> MsgVar a -> Nomex () -displaySimpleVar pn title mv = displayVar pn mv (\a -> title ++ ": " ++ (show a) ++ "\n") - -displayArrayVar :: (Typeable a, Show a, Eq a, Typeable i, Show i, Eq i) => PlayerNumber -> String -> ArrayVar i a -> Nomex () -displayArrayVar pn title mv = displayVar pn mv (showArrayVar title) - -showArrayVar :: (Show a, Show i) => String -> [(i,a)] -> String -showArrayVar title l = title ++ "\n" ++ - concatMap (\(i,a) -> (show i) ++ "\t" ++ (show a) ++ "\n") l - --- * Victory, time and self-number - --- | set victory to a list of players -setVictory :: [PlayerNumber] -> Nomex () -setVictory = SetVictory - --- | give victory to one player -giveVictory :: PlayerNumber -> Nomex () -giveVictory pn = SetVictory [pn] - -getCurrentTime :: Nomex UTCTime -getCurrentTime = CurrentTime - --- | allows a rule to retrieve its own number (for auto-deleting for example) -getSelfRuleNumber :: Nomex RuleNumber -getSelfRuleNumber = SelfRuleNumber - -getSelfRule :: Nomex Rule -getSelfRule = do - srn <- getSelfRuleNumber - rs:[] <- getRulesByNumbers [srn] - return rs - -getSelfProposedByPlayer :: Nomex PlayerNumber -getSelfProposedByPlayer = getSelfRule >>= return . _rProposedBy - --- * Miscellaneous - -voidRule :: Nomex a -> Nomex RuleResp -voidRule e = e >> return Void - - -instance Boolean (Nomex BoolResp) where - true = return $ BoolResp True - false = return $ BoolResp False - notB = undefined - (||*) = undefined - (&&*) na nb = do - a <- na - b <- nb - case a of - (BoolResp a') -> case b of - (BoolResp b') -> return $ BoolResp $ a' && b' - (MsgResp b') -> andMsgBool a' b' >>= (return . MsgResp) - (MsgResp a') -> case b of - (BoolResp b') -> andMsgBool b' a' >>= (return . MsgResp) - (MsgResp b') -> andMsgMsg a' b' >>= (return . MsgResp) - -andMsgBool :: Bool -> (Msg Bool) -> Nomex (Msg Bool) -andMsgBool a b = do - let m = Message ((show a) ++ " &&* " ++ (show b)) - onMessageOnce b (f m) - return m where - f m (MessageData b1) = sendMessage m $ a && b1 - -andMsgMsg :: Msg Bool -> Msg Bool -> Nomex (Msg Bool) -andMsgMsg a b = do - let m = Message ((show a) ++ " &&* " ++ (show b)) - newArrayVarOnce ((show a) ++ ", " ++ (show b)) [1::Integer, 2] (f m) - return m where - f m (VUpdated ((_, Just a):(_, Just b):[])) = sendMessage m $ a && b - f _ _ = return () - - -partial :: String -> Nomex (Maybe a) -> Nomex a -partial s nm = do - m <- nm - case m of - Just a -> return a - Nothing -> throwError s - - --- | a default rule -defaultRule = Rule { - _rNumber = 1, - _rName = "", - _rDescription = "", - _rProposedBy = 0, - _rRuleCode = "", - _rRuleFunc = return Void, - _rStatus = Pending, - _rAssessedBy = Nothing} diff --git a/src/Language/Nomyx/Engine.hs b/src/Language/Nomyx/Engine.hs new file mode 100644 --- /dev/null +++ b/src/Language/Nomyx/Engine.hs @@ -0,0 +1,51 @@ + +-- | 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, + + -- * Variables management + Var(..), + + -- * Rules management + SubmitRule(..), + activeRules, pendingRules, rejectedRules, + + -- * Events management + EventHandler(..), + Status(..), + getEventHandler, + events, + + -- Inputs management + UInputData(..), + + -- Outputs management + Output(..), + displayGame, + Log(..), + + -- Time + getTimes, + currentTime, + + tracePN + ) 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 new file mode 100644 --- /dev/null +++ b/src/Language/Nomyx/Engine/Evaluation.hs @@ -0,0 +1,354 @@ +{-# LANGUAGE GADTs, NamedFieldPuns, ScopedTypeVariables #-} + +module Language.Nomyx.Engine.Evaluation where + +import Prelude hiding ((.), log) +import Language.Nomyx.Engine.Utils +import Control.Monad +import Control.Monad.State.Lazy +import Data.List +import Data.Typeable +import Data.Function hiding ((.)) +import Data.Time +import Data.Lens +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 + +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. +evalExp :: Nomex a -> RuleNumber -> Evaluate a +evalExp (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 + +evalExp (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 + +evalExp (ReadVar (V name)) _ = do + vars <- access variables + let var = find ((== name) . getL vName) vars + case var of + Nothing -> return Nothing + Just (Var _ _ val) -> case cast val of + Just v -> return $ Just v + Nothing -> return Nothing + +evalExp (WriteVar (V name) val) _ = do + 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 + +evalExp (OnEvent event handler) rn = do + evs <- access events + let en = getFreeNumber (map _eventNumber evs) + events %= ((EH en rn event handler SActive) : ) + return en + +evalExp (DelEvent en) _ = evDelEvent en + +evalExp (DelAllEvents e) _ = do + evs <- access events + let filtered = filter (\EH {event} -> event === e) evs + mapM_ (\e -> evDelEvent e) (_eventNumber <$> filtered) + +evalExp (SendMessage (Message id) myData) _ = triggerEvent_ (Message id) (MessageData myData) + +evalExp (NewOutput pn s) rn = evNewOutput pn rn s +evalExp (GetOutput on) _ = evGetOutput on +evalExp (UpdateOutput on s) _ = evUpdateOutput on s +evalExp (DelOutput on) _ = evDelOutput on +evalExp (ProposeRule rule) _ = evProposeRule rule +evalExp (ActivateRule rule) rn = evActivateRule rule rn +evalExp (RejectRule rule) rn = evRejectRule rule rn +evalExp (AddRule rule) _ = evAddRule rule +evalExp (ModifyRule mod rule) _ = evModifyRule mod rule +evalExp GetRules _ = access rules +evalExp GetPlayers _ = access players +evalExp (SetPlayerName pn n) _ = evChangeName pn n +evalExp (DelPlayer pn) _ = evDelPlayer pn +evalExp SelfRuleNumber rn = return rn +evalExp (CurrentTime) _ = access currentTime +evalExp (Return a) _ = return a +evalExp (ThrowError s) _ = throwError s +evalExp (CatchError n h) rn = catchError (evalExp n rn) (\a -> evalExp (h a) rn) +evalExp (SetVictory ps) _ = do + victory ~= ps + pls <- access players + let victorious = filter (\pl -> _playerNumber pl `elem` ps) pls + triggerEvent_ Victory (VictoryData victorious) + +evalExp (Bind exp f) rn = do + a <- evalExp exp rn + evalExp (f a) rn + + +--execute all the handlers of the specified event with the given data +triggerEvent :: (Typeable e, Show e, Eq e) => Event e -> EventData e -> 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, Show e, Eq e) => EventData e -> EventHandler -> Evaluate () +triggerHandler dat (EH {_ruleNumber, _eventNumber, handler}) = case cast handler of + Just castedH -> do + let (exp :: Nomex ()) = castedH (_eventNumber, dat) + (evalExp exp _ruleNumber) `catchError` (errorHandler _ruleNumber _eventNumber) + Nothing -> logAll ("failed " ++ (show $ typeOf handler)) + +triggerEvent_ :: (Typeable e, Show e, Eq 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) = evalExp (h (en, InputData $ TextData s)) rn +execInputHandler (UTextAreaData s) (EH en rn (InputEv (Input _ _ TextArea)) h SActive) = evalExp (h (en, InputData $ TextAreaData s)) rn +execInputHandler (UButtonData) (EH en rn (InputEv (Input _ _ Button)) h SActive) = evalExp (h (en, InputData $ ButtonData)) rn +execInputHandler (URadioData i) (EH en rn (InputEv (Input _ _ (Radio cs))) h SActive) = evalExp (h (en, InputData $ RadioData $ fst $ cs!!i)) rn +execInputHandler (UCheckboxData is) (EH en rn (InputEv (Input _ _ (Checkbox cs))) h SActive) = evalExp (h (en, InputData $ CheckboxData $ fst <$> cs `sel` is)) rn +execInputHandler _ _ = return () + +findEvent :: EventNumber -> [EventHandler] -> Maybe (EventHandler) +findEvent en evs = find ((== en) . getL eventNumber) evs + +getChoiceEvents :: Evaluate [EventNumber] +getChoiceEvents = do + evs <- access events + return $ map _eventNumber $ filter choiceEvent evs + where choiceEvent (EH _ _ (InputEv (Input _ _ (Radio _))) _ _) = True + choiceEvent _ = False + + +evProposeRule :: Rule -> 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 + evalExp (_rRuleFunc 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 :: Rule -> 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 -> Rule -> 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 + when (not 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 _ -> do + players ~= replaceWith ((== pn) . getL playerNumber) (PlayerInfo pn name) pls + return True + +evDelEvent :: EventNumber -> Evaluate Bool +evDelEvent en = do + --traceM ("DelEvent: called with en=" ++ (show en)) + evs <- access events + case find ((== en) . getL eventNumber) evs of + Nothing -> do + --traceM ("DelEvent: event number not found! en=" ++ (show en) ++ " rn=" ++ (show rn)) + return False + Just eh -> do + case (_evStatus eh) of + SActive -> do + --traceM ("DelEvent: deleting event en=" ++ (show en) ++ " rn=" ++ (show rn)) + let newEvents = replaceWith ((== en) . getL eventNumber) eh{_evStatus = SDeleted} evs + events ~= newEvents + return True + SDeleted -> do + --traceM ("DelEvent: Event already deleted! en=" ++ (show en) ++ "rn event=" ++ (show $ _ruleNumber eh) ++ " rn=" ++ (show rn)) + return False + + +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 -> 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 -> Evaluate (Maybe String) +evGetOutput on = do + ops <- access outputs + case find (\(Output myOn _ _ _ s) -> myOn == on && s == SActive) ops of + Nothing -> return Nothing + Just (Output _ _ _ o _) -> return (Just o) + +evUpdateOutput :: OutputNumber -> 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 -> do + return False + Just o -> do + case (_oStatus o) of + SActive -> do + let newOutputs = replaceWith ((== on) . getL outputNumber) o{_oStatus = SDeleted} ops + outputs ~= newOutputs + return True + SDeleted -> do + return False + +logPlayer :: PlayerNumber -> String -> Evaluate () +logPlayer pn s = log (Just pn) s + +logAll :: String -> Evaluate () +logAll s = log Nothing s + +log :: Maybe PlayerNumber -> String -> Evaluate () +log mpn s = do + time <- access currentTime + void $ logs %= (Log mpn time s : ) + +runEvalError :: PlayerNumber -> Evaluate () -> State Game () +runEvalError pn egs = do + e <- runErrorT egs + case e of + Right gs -> return gs + Left e -> do + tracePN pn $ "Error: " ++ e + void $ runErrorT (logPlayer pn "Error: ") diff --git a/src/Language/Nomyx/Engine/Game.hs b/src/Language/Nomyx/Engine/Game.hs new file mode 100644 --- /dev/null +++ b/src/Language/Nomyx/Engine/Game.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE GADTs, TemplateHaskell, ScopedTypeVariables, NamedFieldPuns, DeriveDataTypeable #-} + +-- | This module implements game engine. +module Language.Nomyx.Engine.Game where + +import Prelude hiding (log) +import Data.List +import Language.Nomyx.Expression +import Language.Nomyx.Engine.Utils +import Data.Lens.Template +import Data.Time +import Data.Typeable +import GHC.Show (showList__) +import GHC.Read (readListPrecDefault, readListDefault, Read(..), lexP, parens) +import qualified Text.ParserCombinators.ReadPrec as ReadPrec (prec) +import Text.Read.Lex (Lexeme(..)) +import Text.ParserCombinators.ReadPrec (reset) +import Data.Data + +-- * Game + +type GameName = String + +-- | The state of the game: +data Game = Game { _gameName :: GameName, + _gameDesc :: GameDesc, + _rules :: [Rule], + _players :: [PlayerInfo], + _variables :: [Var], + _events :: [EventHandler], + _outputs :: [Output], + _victory :: [PlayerNumber], + _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 + +--Game is not serializable in its entierety. We serialize only the adequate parts. +instance Read Game where + readPrec = parens $ ReadPrec.prec 11 $ do + Ident "Game" <- lexP; + Punc "{" <- lexP; + Ident "_gameName" <- lexP; + Punc "=" <- lexP; + name <- reset readPrec; + Punc "," <- lexP; + Ident "_gameDesc" <- lexP; + Punc "=" <- lexP; + desc <- reset readPrec; + Punc "," <- lexP; + Ident "_currentTime" <- lexP; + Punc "=" <- lexP; + time <- reset readPrec; + Punc "}" <- lexP; + return $ Game name desc [] [] [] [] [] [] [] time + readList = readListDefault + readListPrec = readListPrecDefault + +instance Show Game where + showsPrec p(Game name desc _ _ _ _ _ _ _ time) = showParen (p >= 11) $ + showString "Game {" . + showString "_gameName = " . + showsPrec 0 name . + showString ", " . + showString "_gameDesc = " . + showsPrec 0 desc . + showString ", " . + showString "_currentTime = " . + showsPrec 0 time . + showString "}" + showList = showList__ (showsPrec 0) + + +displayGame :: Game -> String +displayGame (Game { _gameName, _rules, _players, _variables, _events, _outputs, _victory, _currentTime}) = + "Game Name = " ++ (show _gameName) ++ "\n Rules = " ++ (concat $ intersperse "\n " $ map show _rules) ++ "\n Players = " ++ (show _players) ++ "\n Variables = " ++ + (show _variables) ++ "\n Events = " ++ (show _events) ++ "\n Outputs = " ++ (show _outputs) ++ "\n Victory = " ++ (show _victory) ++ "\n currentTime = " ++ (show _currentTime) ++ "\n" + +emptyGame name desc date = Game { + _gameName = name, + _gameDesc = desc, + _rules = [], + _players = [], + _variables = [], + _events = [], + _outputs = [], + _victory = [], + _logs = [], + _currentTime = date} + + +-- * Variables + +-- | stores the variable's data +data Var = forall a . (Typeable a, Show a, Eq 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" + +instance Eq Var where + Var a b c == Var d e f = (a,b,c) === (d,e,f) + +-- * Events + +data EventHandler where + EH :: (Typeable e, Show e, Eq e) => + {_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 :: String, -- output string + _oStatus :: Status} -- status of the output + deriving (Eq, 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 new file mode 100644 --- /dev/null +++ b/src/Language/Nomyx/Engine/GameEvents.hs @@ -0,0 +1,190 @@ +{-# LANGUAGE GADTs, TemplateHaskell, 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 Control.Monad.Trans.State hiding (get) +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 (Read, 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 RuleFunc) -> StateT Game IO () +enactEvent (GameSettings name desc date) _ = mapStateIO $ gameSettings name desc date +enactEvent (JoinGame pn name) _ = mapStateIO $ joinGame name pn +enactEvent (LeaveGame pn) _ = mapStateIO $ leaveGame pn +enactEvent (ProposeRuleEv pn sr) (Just inter) = void $ proposeRule sr pn inter +enactEvent (InputResult pn en ir) _ = mapStateIO $ inputResult pn en ir +enactEvent (GLog mpn s) _ = mapStateIO $ logGame s mpn +enactEvent (TimeEvent t) _ = mapStateIO $ runEvalError 0 $ void $ evTriggerTime t +enactEvent (SystemAddRule r) (Just inter) = systemAddRule r inter +enactEvent (ProposeRuleEv _ _) Nothing = error "ProposeRuleEv: interpreter function needed" +enactEvent (SystemAddRule _) Nothing = error "SystemAddRule: interpreter function needed" + +enactTimedEvent :: Maybe (RuleCode -> IO RuleFunc) -> TimedEvent -> StateT Game IO () +enactTimedEvent 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 ge = execGameEvent' Nothing ge + +execGameEvent' :: Maybe (RuleCode -> IO RuleFunc) -> GameEvent -> StateT LoggedGame IO () +execGameEvent' inter ge = do + t <- access $ game >>> currentTime + let te = TimedEvent t ge + gameLog %= \gl -> gl ++ [te] + focus game $ enactTimedEvent inter te + +getLoggedGame :: Game -> (RuleCode -> IO RuleFunc) -> [TimedEvent] -> IO LoggedGame +getLoggedGame 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} + players %= (player : ) + runEvalError pn $ triggerEvent_ (Player Arrive) (PlayerData player) + + +-- | leave the game. +leaveGame :: PlayerNumber -> State Game () +leaveGame pn = runEvalError pn $ void $ evDelPlayer pn + +-- | insert a rule in pending rules. +proposeRule :: SubmitRule -> PlayerNumber -> (RuleCode -> IO RuleFunc) -> StateT Game IO () +proposeRule sr pn inter = do + rule <- createRule sr pn inter + mapStateIO $ runEvalError pn $ do + r <- evProposeRule rule + if r == True then tracePN pn $ "Your rule has been added to pending rules." + else tracePN pn $ "Error: Rule could not be proposed" + +-- | add a rule forcefully (no votes etc.) +systemAddRule :: SubmitRule -> (RuleCode -> IO RuleFunc) -> StateT Game IO () +systemAddRule sr inter = do + rule <- createRule sr 0 inter + let sysRule = (rStatus ^= Active) >>> (rAssessedBy ^= Just 0) + rules %= (sysRule rule : ) + mapStateIO $ runEvalError 0 $ void $ evalExp (_rRuleFunc rule) (_rNumber rule) + +-- | 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 +inputResult :: PlayerNumber -> EventNumber -> UInputData -> State Game () +inputResult pn en ir = do + tracePN pn $ "input result: Event " ++ (show en) ++ ", choice " ++ (show ir) + runEvalError pn $ triggerInput en ir + + +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 -> [Rule] +activeRules = sort . filter ((==Active) . getL rStatus) . _rules + +pendingRules :: Game -> [Rule] +pendingRules = sort . filter ((==Pending) . getL rStatus) . _rules + +rejectedRules :: Game -> [Rule] +rejectedRules = sort . filter ((==Reject) . getL rStatus) . _rules + + +createRule :: SubmitRule -> PlayerNumber -> (RuleCode -> IO RuleFunc) -> StateT Game IO Rule +createRule (SubmitRule name desc code) pn inter = do + rs <- access rules + let rn = getFreeNumber $ map _rNumber rs + rf <- lift $ inter code + tracePN pn $ "Creating rule n=" ++ (show rn) ++ " code=" ++ code + return $ Rule {_rNumber = rn, + _rName = name, + _rDescription = desc, + _rProposedBy = pn, + _rRuleCode = code, + _rRuleFunc = rf, + _rStatus = Pending, + _rAssessedBy = Nothing} + + +stateCatch = liftCatch E.catch diff --git a/src/Language/Nomyx/Engine/Test.hs b/src/Language/Nomyx/Engine/Test.hs new file mode 100644 --- /dev/null +++ b/src/Language/Nomyx/Engine/Test.hs @@ -0,0 +1,321 @@ +{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable, 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.Engine.Evaluation +import Language.Nomyx.Engine.Game +import Language.Nomyx.Engine.Utils +import Control.Monad.State +import Data.Typeable +import Data.Lens + + +date1 = parse822Time "Tue, 02 Sep 1997 09:00:00 -0400" +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"], + _variables = [], + _events = [], + _outputs = [], + _victory = [], + _logs = [], + _currentTime = date1} + +testRule = Rule { _rNumber = 0, + _rName = "test", + _rDescription = "test", + _rProposedBy = 0, + _rRuleCode = "", + _rRuleFunc = return Void, + _rStatus = Pending, + _rAssessedBy = Nothing} + +evalRuleFunc f = evalState (runEvalError 0 $ evalExp f 0) testGame +execRuleFuncEvent f e d = execState (runEvalError 0 $ evalExp f 0 >> (triggerEvent_ e d)) testGame +execRuleFuncGame f g = execState (runEvalError 0 $ void $ evalExp f 0) g +execRuleFuncEventGame f e d g = execState (runEvalError 0 $ evalExp f 0 >> (triggerEvent_ e d)) g +execRuleFunc f = execRuleFuncGame f testGame + +addActivateRule :: RuleFunc -> RuleNumber -> Evaluate () +addActivateRule rf rn = do + let rule = testRule {_rName = "testRule", _rRuleFunc = 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 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 = and $ map snd tests + +--Test variable creation +testVar1 :: RuleFunc +testVar1 = voidRule $ do + NewVar "toto" (1::Integer) + return () + +testVarEx1 = (variables ^$ execRuleFunc testVar1) == [(Var 0 "toto" (1::Integer))] + +--Test variable deleting +testVar2 :: RuleFunc +testVar2 = voidRule $ do + var <- newVar_ "toto" (1::Int) + delVar var + return () + +testVarEx2 = _variables (execRuleFunc testVar2) == [] + +--Test variable reading +testVar3 :: RuleFunc +testVar3 = voidRule $ do + var <- newVar_ "toto" (1::Int) + a <- readVar var + case a of + Just (1::Int) -> newOutput_ (return "ok") (Just 1) + _ -> newOutput_ (return "nok") (Just 1) + +testVarEx3 = isOutput "ok" (execRuleFunc testVar3) + +--Test variable writing +testVar4 :: RuleFunc +testVar4 = voidRule $ do + var <- newVar_ "toto" (1::Int) + writeVar var (2::Int) + a <- readVar var + case a of + Just (2::Int) -> newOutput_ (return "ok") (Just 1) + _ -> newOutput_ (return "nok") (Just 1) + +testVarEx4 = isOutput "ok" (execRuleFunc testVar4) + +--Test variable writing +testVar5 :: RuleFunc +testVar5 = voidRule $ do + var <- newVar_ "toto" ([]::[Int]) + writeVar var ([1]::[Int]) + a <- readVar var + case a of + Just (a::[Int]) -> do + writeVar var (2:a) + return () + Nothing -> newOutput_ (return "nok") (Just 1) + +testVarEx5 = _variables (execRuleFunc testVar5) == [(Var 0 "toto" ([2,1]::[Int]))] + +data Choice = Holland | Sarkozy deriving (Enum, Typeable, Show, Eq, Bounded) + +-- Test input +testSingleInput :: RuleFunc +testSingleInput = voidRule $ do + onInputRadioEnum_ "Vote for Holland or Sarkozy" Holland h 1 where + h a = newOutput_ (return $ "voted for " ++ (show a)) (Just 1) + +testSingleInputEx = isOutput "voted for Holland" g where + g = execRuleFuncEvent testSingleInput (inputRadioEnum 1 "Vote for Holland or Sarkozy" Holland) (InputData (RadioData Holland)) + +testMultipleInputs :: RuleFunc +testMultipleInputs = voidRule $ do + onInputCheckbox_ "Vote for Holland and Sarkozy" [(Holland, "Holland"), (Sarkozy, "Sarkozy")] h 1 where + h a = newOutput_ (return $ "voted for " ++ (show a)) (Just 1) + +testMultipleInputsEx = isOutput "voted for [Holland,Sarkozy]" g where + g = execRuleFuncEvent testMultipleInputs (inputCheckbox 1 "Vote for Holland and Sarkozy" [(Holland, "Holland"), (Sarkozy, "Sarkozy")]) (InputData (CheckboxData [Holland, Sarkozy])) + + +testInputString :: RuleFunc +testInputString = voidRule $ do + onInputText_ "Enter a number:" h 1 where + h a = newOutput_ (return $ "You entered: " ++ a) (Just 1) + +testInputStringEx = isOutput "You entered: 1" g where + g = execRuleFuncEvent testInputString (inputText 1 "Enter a number:") (InputData (TextData "1")) + +-- Test message +testSendMessage :: RuleFunc +testSendMessage = voidRule $ do + let msg = Message "msg" :: Event(Message String) + onEvent_ msg f + sendMessage msg "toto" where + f (MessageData a :: EventData(Message String)) = newOutput_ (return a) (Just 1) + +testSendMessageEx = isOutput "toto" (execRuleFunc testSendMessage) + +testSendMessage2 :: RuleFunc +testSendMessage2 = voidRule $ do + onEvent_ (Message "msg":: Event(Message ())) $ const $ newOutput_ (return "Received") (Just 1) + 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 :: RuleFunc +testUserInputWrite = voidRule $ do + newVar_ "vote" (Nothing::Maybe Choice2) + onEvent_ (Message "voted" :: Event (Message ())) h2 + onEvent_ (InputEv (Input 1 "Vote for" (Radio [(Me, "Me"), (You, "You")]))) h1 where + h1 (InputData (RadioData a) :: EventData (Input Choice2)) = do + writeVar (V "vote") (Just a) + SendMessage (Message "voted") () + h1 _ = undefined + h2 (MessageData _) = do + a <- readVar (V "vote") + case a of + Just (Just Me) -> newOutput_ (return "voted Me") (Just 1) + _ -> newOutput_ (return "problem") (Just 1) + h2 _ = undefined + +testUserInputWriteEx = isOutput "voted Me" g where + g = execRuleFuncEvent testUserInputWrite (InputEv (Input 1 "Vote for" (Radio [(Me, "Me"), (You, "You")]))) (InputData (RadioData Me)) + +-- Test rule activation +testActivateRule :: RuleFunc +testActivateRule = voidRule $ do + a <- GetRules + if (_rStatus (head a) == Pending) then do + ActivateRule $ _rNumber (head a) + return () + else return () + + +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 :: RuleFunc +testTimeEvent = voidRule $ do + 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 = flip execState testGame (runEvalError 0 $ evalExp testTimeEvent2 0 >> void gameEvs) + gameEvs = do + evTriggerTime date1 + evTriggerTime date2 + +-- Test deletes +testDeleteRule :: RuleFunc +testDeleteRule = voidRule $ do + newVar_ "toto" (1::Int) + onMessage (Message "msg":: Event(Message ())) (const $ return ()) + newOutput_ (return "toto") (Just 1) + +testDeleteGame :: Game +testDeleteGame = flip execState testGame {_players = []} $ runEvalError 0 $ do + addActivateRule testDeleteRule 1 + addActivateRule (voidRule $ suppressRule 1) 2 + +testDeleteRuleEx1 = (_rStatus $ head $ drop 1 $ _rules testDeleteGame) == Reject && + (_variables testDeleteGame == []) && + (_oStatus $ head $ _outputs testDeleteGame) == SDeleted && + (_evStatus $ head $ _events testDeleteGame) == SDeleted +-- Test votes + +voteGameActions :: Int -> Int -> Int -> Bool -> Evaluate () -> Game +voteGameActions positives negatives total timeEvent actions = flip execState testGame {_players = []} $ runEvalError 0 $ do + mapM_ (\x -> addPlayer (PlayerInfo x $ "coco " ++ (show x))) [1..total] + actions + evProposeRule testRule + evs <- getChoiceEvents + let pos = take positives evs + let neg = take negatives $ drop positives evs + mapM_ (\x -> triggerInput x (URadioData $ fromEnum For)) pos + mapM_ (\x -> triggerInput x (URadioData $ fromEnum Against)) neg + when timeEvent $ void $ evTriggerTime date2 + +voteGame' :: Int -> Int -> Int -> Bool -> RuleFunc -> Game +voteGame' positives negatives notVoted timeEvent rf = voteGameActions positives negatives notVoted timeEvent $ addActivateRule rf 1 + +voteGame :: Int -> Int -> Int -> RuleFunc -> Game +voteGame positives negatives notVoted rf = voteGame' positives negatives notVoted True rf + +voteGameTimed :: Int -> Int -> Int -> RuleFunc -> Game +voteGameTimed positives negatives notVoted rf = voteGame' positives negatives notVoted True rf + +-- 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 + +isOutput :: String -> Game -> Bool +isOutput s g = any (\(Output _ _ _ mys SActive) -> mys == s) (_outputs g) + + diff --git a/src/Language/Nomyx/Engine/Utils.hs b/src/Language/Nomyx/Engine/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Language/Nomyx/Engine/Utils.hs @@ -0,0 +1,52 @@ + +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/Evaluation.hs b/src/Language/Nomyx/Evaluation.hs deleted file mode 100644 --- a/src/Language/Nomyx/Evaluation.hs +++ /dev/null @@ -1,330 +0,0 @@ -{-# LANGUAGE FlexibleInstances, NoMonomorphismRestriction, GADTs, NamedFieldPuns, ScopedTypeVariables, DoAndIfThenElse #-} - -module Language.Nomyx.Evaluation where - -import Prelude hiding ((.), log) -import Language.Nomyx.Utils -import Control.Monad -import Control.Monad.State.Lazy -import Data.List -import Data.Typeable -import Data.Function hiding ((.)) -import Data.Time -import Data.Lens -import Control.Category -import Control.Monad.Error (ErrorT(..)) -import Control.Monad.Error.Class (MonadError(..)) -import Control.Applicative ((<$>)) -import Language.Nomyx.Expression - -type Evaluate a = ErrorT String (State Game) a - --- | evaluate an expression. --- The rule number passed is the number of the rule containing the expression. -evalExp :: Nomex a -> RuleNumber -> Evaluate a -evalExp (NewVar name def) rn = do - vars <- access variables - case find ((== name) . getL vName) vars of - Nothing -> do - variables %= ((Var rn name def) : ) - return $ Just (V name) - Just _ -> return Nothing - -evalExp (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 - -evalExp (ReadVar (V name)) _ = do - vars <- access variables - let var = find ((== name) . getL vName) vars - case var of - Nothing -> return Nothing - Just (Var _ _ val) -> case cast val of - Just v -> return $ Just v - Nothing -> return Nothing - -evalExp (WriteVar (V name) val) _ = do - 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 - -evalExp (OnEvent event handler) rn = do - evs <- access events - let en = getFreeNumber (map _eventNumber evs) - events %= ((EH en rn event handler SActive) : ) - return en - -evalExp (DelEvent en) _ = evDelEvent en - -evalExp (DelAllEvents e) _ = do - evs <- access events - let filtered = filter (\EH {event} -> event === e) evs - mapM_ (\e -> evDelEvent e) (_eventNumber <$> filtered) - -evalExp (SendMessage (Message id) myData) _ = triggerEvent_ (Message id) (MessageData myData) - -evalExp (NewOutput pn s) rn = evNewOutput pn rn s -evalExp (UpdateOutput on s) _ = evUpdateOutput on s -evalExp (DelOutput on) _ = evDelOutput on -evalExp (ProposeRule rule) _ = evProposeRule rule -evalExp (ActivateRule rule) rn = evActivateRule rule rn -evalExp (RejectRule rule) rn = evRejectRule rule rn -evalExp (AddRule rule) _ = evAddRule rule -evalExp (ModifyRule mod rule) _ = evModifyRule mod rule -evalExp GetRules _ = access rules -evalExp GetPlayers _ = access players -evalExp (SetPlayerName pn n) _ = evChangeName pn n -evalExp (DelPlayer pn) _ = evDelPlayer pn -evalExp SelfRuleNumber rn = return rn -evalExp (CurrentTime) _ = access currentTime -evalExp (Return a) _ = return a -evalExp (ThrowError s) _ = throwError s -evalExp (CatchError n h) rn = catchError (evalExp n rn) (\a -> evalExp (h a) rn) -evalExp (SetVictory ps) _ = do - victory ~= ps - pls <- access players - let victorious = filter (\pl -> _playerNumber pl `elem` ps) pls - triggerEvent_ Victory (VictoryData victorious) - -evalExp (Bind exp f) rn = do - a <- evalExp exp rn - evalExp (f a) rn - - ---execute all the handlers of the specified event with the given data -triggerEvent :: (Typeable e, Show e, Eq e) => Event e -> EventData e -> 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, Show e, Eq e) => EventData e -> EventHandler -> Evaluate () -triggerHandler dat (EH {_ruleNumber, _eventNumber, handler}) = case cast handler of - Just castedH -> do - let (exp :: Nomex ()) = castedH (_eventNumber, dat) - (evalExp exp _ruleNumber) `catchError` (errorHandler _ruleNumber _eventNumber) - Nothing -> logAll ("failed " ++ (show $ typeOf handler)) - -triggerEvent_ :: (Typeable e, Show e, Eq 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) = evalExp (h (en, InputData $ TextData s)) rn -execInputHandler (UTextAreaData s) (EH en rn (InputEv (Input _ _ TextArea)) h SActive) = evalExp (h (en, InputData $ TextAreaData s)) rn -execInputHandler (UButtonData) (EH en rn (InputEv (Input _ _ Button)) h SActive) = evalExp (h (en, InputData $ ButtonData)) rn -execInputHandler (URadioData i) (EH en rn (InputEv (Input _ _ (Radio cs))) h SActive) = evalExp (h (en, InputData $ RadioData $ fst $ cs!!i)) rn -execInputHandler (UCheckboxData is) (EH en rn (InputEv (Input _ _ (Checkbox cs))) h SActive) = evalExp (h (en, InputData $ CheckboxData $ fst <$> cs `sel` is)) rn -execInputHandler _ _ = return () - -findEvent :: EventNumber -> [EventHandler] -> Maybe (EventHandler) -findEvent en evs = find ((== en) . getL eventNumber) evs - -getChoiceEvents :: Evaluate [EventNumber] -getChoiceEvents = do - evs <- access events - return $ map _eventNumber $ filter choiceEvent evs - where choiceEvent (EH _ _ (InputEv (Input _ _ (Radio _))) _ _) = True - choiceEvent _ = False - - -evProposeRule :: Rule -> 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 - evalExp (_rRuleFunc 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 - return True - -evAddRule :: Rule -> 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 -> Rule -> 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 - when (not 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 _ -> do - players ~= replaceWith ((== pn) . getL playerNumber) (PlayerInfo pn name) pls - return True - -evDelEvent :: EventNumber -> Evaluate Bool -evDelEvent en = do - --traceM ("DelEvent: called with en=" ++ (show en)) - evs <- access events - case find ((== en) . getL eventNumber) evs of - Nothing -> do - --traceM ("DelEvent: event number not found! en=" ++ (show en) ++ " rn=" ++ (show rn)) - return False - Just eh -> do - case (_evStatus eh) of - SActive -> do - --traceM ("DelEvent: deleting event en=" ++ (show en) ++ " rn=" ++ (show rn)) - let newEvents = replaceWith ((== en) . getL eventNumber) eh{_evStatus = SDeleted} evs - events ~= newEvents - return True - SDeleted -> do - --traceM ("DelEvent: Event already deleted! en=" ++ (show en) ++ "rn event=" ++ (show $ _ruleNumber eh) ++ " rn=" ++ (show rn)) - return False - - -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 - - -evNewOutput :: PlayerNumber -> RuleNumber -> 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 - -evUpdateOutput :: OutputNumber -> 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 -> do - return False - Just o -> do - case (_oStatus o) of - SActive -> do - let newOutputs = replaceWith ((== on) . getL outputNumber) o{_oStatus = SDeleted} ops - outputs ~= newOutputs - return True - SDeleted -> do - return False - -logPlayer :: PlayerNumber -> String -> Evaluate () -logPlayer pn s = log (Just pn) s - -logAll :: String -> Evaluate () -logAll s = log Nothing s - -log :: Maybe PlayerNumber -> String -> Evaluate () -log mpn s = do - time <- access currentTime - void $ logs %= (Log mpn time s : ) - - -runEvalError :: PlayerNumber -> Evaluate () -> State Game () -runEvalError pn egs = do - e <- runErrorT egs - case e of - Right gs -> return gs - Left e -> do - tracePN pn $ "Error: " ++ e - void $ runErrorT (logPlayer pn "Error: ") diff --git a/src/Language/Nomyx/Events.hs b/src/Language/Nomyx/Events.hs new file mode 100644 --- /dev/null +++ b/src/Language/Nomyx/Events.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +-- | All the building blocks to allow rules to build events. +module Language.Nomyx.Events where +-- Event(..), +-- EventNumber, +-- EventData(..), +-- InputData(..), +-- Msg, +-- MsgData, +-- onEvent, onEvent_, +-- onEventOnce, onEventOnce_, +-- delEvent, delEvent_, delAllEvents, +-- sendMessage, sendMessage_, +-- onMessage, onMessageOnce, +-- schedule, schedule_, schedule', schedule'_, +-- getCurrentTime, +-- oneWeek, oneDay, oneHour, oneMinute, + +import Language.Nomyx.Expression +import Data.Typeable +import Control.Monad.State +import Data.List +import Data.Time hiding (getCurrentTime) +import Data.Time.Recurrence hiding (filter) +import Safe + + +-- * Events + +-- | register a callback on an event +onEvent :: (Typeable e, Show e, Eq e) => Event e -> ((EventNumber, EventData 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 () +onEvent_ e h = do + OnEvent e (\(_, d) -> h d) + return () + +-- | set an handler for an event that will be triggered only once +onEventOnce :: (Typeable e, Show e, Eq e) => Event e -> (EventData e -> Nomex ()) -> Nomex EventNumber +onEventOnce e h = do + let handler (en, ed) = delEvent_ en >> h ed + n <- OnEvent e handler + return n + +-- | set an handler for an event that will be triggered only once +onEventOnce_ :: (Typeable e, Show e, Eq e) => Event e -> (EventData e -> Nomex ()) -> Nomex () +onEventOnce_ e h = do + let handler (en, ed) = delEvent_ en >> h ed + OnEvent e handler + return () + +delEvent :: EventNumber -> Nomex Bool +delEvent = DelEvent + +delEvent_ :: EventNumber -> Nomex () +delEvent_ e = delEvent e >> return () + +delAllEvents :: (Typeable e, Show e, Eq e) => Event e -> Nomex () +delAllEvents = DelAllEvents + +-- | broadcast a message that can be catched by another rule +sendMessage :: (Typeable a, Show a, Eq a) => Msg a -> a -> Nomex () +sendMessage = SendMessage + +sendMessage_ :: Msg () -> Nomex () +sendMessage_ m = SendMessage m () + +-- | subscribe on a message +onMessage :: (Typeable m, Show m) => Msg m -> (MsgData m -> Nomex ()) -> Nomex () +onMessage m f = onEvent_ m f + +onMessageOnce :: (Typeable m, Show m) => Msg m -> (MsgData m -> Nomex ()) -> Nomex () +onMessageOnce m f = onEventOnce_ m f + +-- | on the provided schedule, the supplied function will be called +schedule :: (Schedule Freq) -> (UTCTime -> Nomex ()) -> Nomex () +schedule sched f = do + now <- getCurrentTime + let next = head $ starting now $ sched + if (next == now) then executeAndScheduleNext (f . timeData) sched (TimeData now) + else onEventOnce_ (Time next) $ executeAndScheduleNext (f . timeData) sched where + +executeAndScheduleNext :: (EventData Time -> Nomex ()) -> (Schedule Freq) -> (EventData Time) -> Nomex () +executeAndScheduleNext f sched now = do + f now + let rest = drop 1 $ starting (timeData now) $ sched + when (rest /= []) $ onEventOnce_ (Time $ head rest) $ executeAndScheduleNext f sched + + +schedule_ :: (Schedule Freq) -> Nomex () -> Nomex () +schedule_ ts f = schedule ts (\_-> f) + +--at each time provided, the supplied function will be called +schedule' :: [UTCTime] -> (UTCTime -> Nomex ()) -> Nomex () +schedule' sched f = do + let sched' = sort sched + now <- getCurrentTime + let nextMay = headMay $ filter (>=now) $ sched' + case nextMay of + Just next -> do + if (next == now) then executeAndScheduleNext' (f . timeData) sched' (TimeData now) + else onEventOnce_ (Time next) $ executeAndScheduleNext' (f . timeData) sched' + Nothing -> return () + + +executeAndScheduleNext' :: (EventData Time -> Nomex ()) -> [UTCTime] -> (EventData Time) -> Nomex () +executeAndScheduleNext' f sched now = do + f now + let rest = drop 1 $ sched + when (rest /= []) $ onEventOnce_ (Time $ head rest) $ executeAndScheduleNext' f sched + + +schedule'_ :: [UTCTime] -> Nomex () -> Nomex () +schedule'_ ts f = schedule' ts (\_-> f) + +getCurrentTime :: Nomex UTCTime +getCurrentTime = CurrentTime + +-- | durations +oneWeek, oneDay, oneHour, oneMinute :: NominalDiffTime +oneWeek = 7 * oneDay +oneDay = 24 * oneHour +oneHour = 60 * oneMinute +oneMinute = 60 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 @@ -1,5 +1,4 @@ -{-# LANGUAGE TupleSections, GADTs, EmptyDataDecls, TypeFamilies, DeriveDataTypeable, - ScopedTypeVariables, TypeSynonymInstances #-} +{-# LANGUAGE GADTs, DeriveDataTypeable #-} -- | This file gives a list of example rules that the players can submit. --You can copy-paste them in the field "Code" of the web GUI. @@ -11,18 +10,15 @@ enterHaiku, displayBankAccount, module Data.Time.Recurrence, module Control.Monad, module Data.List, module Data.Time.Clock) where -import Language.Nomyx.Definition -import Language.Nomyx.Rule -import Language.Nomyx.Expression -import Language.Nomyx.Vote +import Language.Nomyx import Data.Function import Data.Time.Clock hiding (getCurrentTime) import Data.Time.Recurrence hiding (filter) import Control.Arrow import Data.List import Control.Monad -import Language.Nomyx.Utils (oneDay) import Safe (readDef) +import Data.Typeable -- | A rule that does nothing nothing :: RuleFunc @@ -30,7 +26,7 @@ -- | A rule that says hello to all players helloWorld :: RuleFunc -helloWorld = voidRule $ outputAll "hello, world!" +helloWorld = voidRule $ outputAll' "hello, world!" -- | account variable name and type accounts :: MsgVar [(PlayerNumber, Int)] @@ -42,8 +38,16 @@ -- | Permanently display the bank accounts displayBankAccount :: RuleFunc -displayBankAccount = voidRule $ forEachPlayer_ displayPlayerAccount +displayBankAccount = voidRule $ do + let displayOneAccount (account_pn, a) = do + name <- showPlayer account_pn + return $ name ++ "\t" ++ (show a) ++ "\n" + let displayAccounts l = do + d <- concatMapM displayOneAccount l + return $ "Accounts:\n" ++ d + displayVar Nothing accounts displayAccounts + -- | each player wins X Ecu each day -- you can also try with "minutly" or "monthly" instead of "daily" and everything in the "time-recurrence" package winXEcuPerDay :: Int -> RuleFunc @@ -64,8 +68,8 @@ transfer src dst amount = do modifyValueOfPlayer dst accounts (\a -> a + (readDef 0 amount)) modifyValueOfPlayer src accounts (\a -> a - (readDef 0 amount)) - newOutput_ ("You gave " ++ amount ++ " ecus to player " ++ show dst) src - newOutput_ ("Player " ++ show src ++ " gaved you " ++ amount ++ "ecus") dst + newOutput_ (return $ "You gave " ++ amount ++ " ecus to player " ++ show dst) (Just src) + newOutput_ (return $ "Player " ++ show src ++ " gaved you " ++ amount ++ "ecus") (Just dst) -- | delete a rule @@ -76,16 +80,16 @@ -- and we prefix his name with "King" makeKing :: PlayerNumber -> RuleFunc makeKing pn = voidRule $ do - voidRule $ newVar_ "King" pn + voidRule $ newMsgVar_ "King" pn modifyPlayerName pn ("King " ++) -king :: V PlayerNumber -king = V "King" +king :: MsgVar PlayerNumber +king = msgVar "King" -- | Monarchy: only the king decides which rules to accept or reject monarchy :: RuleFunc monarchy = voidRule $ onEvent_ (RuleEv Proposed) $ \(RuleData rule) -> do - k <- readVar_ king + k <- readMsgVar_ king onInputRadioEnumOnce_ ("Your Royal Highness, do you accept rule " ++ (show $ _rNumber rule) ++ "?") True (activateOrReject rule) k @@ -117,7 +121,7 @@ displayTime :: RuleFunc displayTime = voidRule $ do t <- getCurrentTime - onEventOnce_ (Time $ addUTCTime 5 t) $ \(TimeData t) -> outputAll $ show t + onEventOnce_ (Time $ addUTCTime 5 t) $ \(TimeData t) -> outputAll' $ show t -- | Only one player can achieve victory: No group victory. -- Forbidding group victory usually becomes necessary when lowering the voting quorum: @@ -165,20 +169,41 @@ makeGM :: PlayerNumber -> Nomex() makeGM pn = do - newVar "GameMaster" pn + newMsgVar "GameMaster" pn void $ modifyPlayerName pn ("GameMaster " ++) -gameMaster :: V PlayerNumber -gameMaster = V "GameMaster" +gameMaster :: MsgVar PlayerNumber +gameMaster =msgVar "GameMaster" -- | display a button and greets you when pressed (for player 1) bravoButton :: RuleFunc -bravoButton = voidRule $ voidRule $ onInputButton_ "Click here:" (const $ outputAll "Bravo!") 1 +bravoButton = voidRule $ voidRule $ onInputButton_ "Click here:" (const $ outputAll' "Bravo!") 1 enterHaiku :: RuleFunc -enterHaiku = voidRule $ onInputTextarea_ "Enter a haiku:" outputAll 1 +enterHaiku = voidRule $ onInputTextarea_ "Enter a haiku:" outputAll' 1 -displayPlayerAccount :: PlayerNumber -> Nomex () -displayPlayerAccount pn = do - sp <- showPlayer - displayVar pn accounts (\l -> "Accounts:\n" ++ concatMap (\(i,a) -> (sp i) ++ "\t" ++ (show a) ++ "\n") l) +tournamentMasterCandidates :: RuleFunc +tournamentMasterCandidates = voidRule $ do + let tournamentMasterCandidates = msgVar "tournamentMasterCandidates" :: MsgVar [PlayerNumber] + let candidate pn = void $ modifyMsgVar tournamentMasterCandidates (pn : ) + let displayCandidates pns = return $ "Candidates for the election of Tournament Master: Players #" ++ (concat $ intersperse ", " $ map show pns) + newMsgVar_ (getMsgVarName tournamentMasterCandidates) ([] :: [PlayerNumber]) + forEachPlayer_ (\pn -> onInputButtonOnce_ "I am candidate for the next Tournament Master elections " (const $ candidate pn) pn) + displayVar Nothing tournamentMasterCandidates displayCandidates + +-- | castle structure +data Castle = Castle { towers :: Int, dungeon :: Bool } + deriving (Typeable, Show, Eq) + +castles :: MsgVar [(PlayerNumber, Castle)] +castles = msgVar "Castles" + +castleVictory :: RuleFunc +castleVictory = voidRule $ do + let checkVict cs = do + let vict = map fst $ filter ((== (Castle 4 True)) . snd) cs + when (length vict > 0) $ setVictory vict + onMsgVarChange castles $ (\(VUpdated cs) -> checkVict cs) + +concatMapM :: (Monad m) => (a -> m [b]) -> [a] -> m [b] +concatMapM f xs = liftM concat (mapM f xs) 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 @@ -1,10 +1,5 @@ - -{-# LANGUAGE NoMonomorphismRestriction, FlexibleInstances, GADTs, - UndecidableInstances, DeriveDataTypeable, FlexibleContexts, - GeneralizedNewtypeDeriving, MultiParamTypeClasses, TypeFamilies, - TypeSynonymInstances, TemplateHaskell, ExistentialQuantification, - TypeFamilies, ScopedTypeVariables, StandaloneDeriving, NamedFieldPuns, - EmptyDataDecls, QuasiQuotes #-} +{-# LANGUAGE FlexibleInstances, GADTs, DeriveDataTypeable, MultiParamTypeClasses, + TemplateHaskell, ScopedTypeVariables, StandaloneDeriving, NamedFieldPuns, EmptyDataDecls #-} -- | This module containt the type definitions necessary to build a Nomic rule. module Language.Nomyx.Expression where @@ -13,15 +8,7 @@ import Data.Time import Control.Applicative hiding (Const) import Data.Lens.Template -import Data.Data (Data) -import GHC.Read (readListPrecDefault, readListDefault, Read(..), lexP, parens) -import qualified Text.ParserCombinators.ReadPrec as ReadPrec (prec) -import Text.Read.Lex (Lexeme(..)) -import Text.ParserCombinators.ReadPrec (reset) -import GHC.Show (showList__) import Control.Monad.Error -import Language.Nomyx.Utils ((===)) -import Data.List (intersperse) type PlayerNumber = Int type PlayerName = String @@ -33,51 +20,49 @@ type EventNumber = Int type EventName = String type VarName = String -type GameName = String type Code = String type OutputNumber = Int - -- * Nomyx Expression -- | A Nomex (Nomyx Expression) allows the players to write rules. --- | within the rules, you can access and modify the state of the game. --- | It is a compositional algebra defined with a GADT. +-- within the rules, you can access and modify the state of the game. data Nomex a where --Variable management - NewVar :: (Typeable a, Show a, Eq a) => VarName -> a -> Nomex (Maybe (V a)) - ReadVar :: (Typeable a, Show a, Eq a) => (V a) -> Nomex (Maybe a) - WriteVar :: (Typeable a, Show a, Eq a) => (V a) -> a -> Nomex Bool - DelVar :: (V a) -> Nomex Bool + NewVar :: (Typeable a, Show a, Eq a) => VarName -> a -> Nomex (Maybe (V a)) + ReadVar :: (Typeable a, Show a, Eq a) => (V a) -> Nomex (Maybe a) + WriteVar :: (Typeable a, Show a, Eq a) => (V a) -> a -> Nomex Bool + DelVar :: (V a) -> Nomex Bool --Events management - OnEvent :: (Typeable e, Show e, Eq e) => Event e -> ((EventNumber, EventData e) -> Nomex ()) -> Nomex EventNumber - DelEvent :: EventNumber -> Nomex Bool - DelAllEvents :: (Typeable e, Show e, Eq e) => Event e -> Nomex () - SendMessage :: (Typeable a, Show a, Eq a) => Event (Message a) -> a -> Nomex () + OnEvent :: (Typeable e, Show e, Eq e) => Event e -> ((EventNumber, EventData e) -> Nomex ()) -> Nomex EventNumber + DelEvent :: EventNumber -> Nomex Bool + DelAllEvents :: (Typeable e, Show e, Eq e) => Event e -> Nomex () + SendMessage :: (Typeable a, Show a, Eq a) => Event (Message a) -> a -> Nomex () --Rules management - ProposeRule :: Rule -> Nomex Bool - ActivateRule :: RuleNumber -> Nomex Bool - RejectRule :: RuleNumber -> Nomex Bool - AddRule :: Rule -> Nomex Bool - ModifyRule :: RuleNumber -> Rule -> Nomex Bool - GetRules :: Nomex [Rule] + ProposeRule :: Rule -> Nomex Bool + ActivateRule :: RuleNumber -> Nomex Bool + RejectRule :: RuleNumber -> Nomex Bool + AddRule :: Rule -> Nomex Bool + ModifyRule :: RuleNumber -> Rule -> Nomex Bool + GetRules :: Nomex [Rule] --Players management - GetPlayers :: Nomex [PlayerInfo] - SetPlayerName:: PlayerNumber -> PlayerName -> Nomex Bool - DelPlayer :: PlayerNumber -> Nomex Bool + GetPlayers :: Nomex [PlayerInfo] + SetPlayerName :: PlayerNumber -> PlayerName -> Nomex Bool + DelPlayer :: PlayerNumber -> Nomex Bool --Output - NewOutput :: PlayerNumber -> String -> Nomex OutputNumber - UpdateOutput :: OutputNumber -> String -> Nomex Bool - DelOutput :: OutputNumber -> Nomex Bool + NewOutput :: (Maybe PlayerNumber) -> String -> Nomex OutputNumber + GetOutput :: OutputNumber -> Nomex (Maybe String) + UpdateOutput :: OutputNumber -> String -> Nomex Bool + DelOutput :: OutputNumber -> Nomex Bool --Mileacenous - SetVictory :: [PlayerNumber] -> Nomex () - CurrentTime :: Nomex UTCTime - SelfRuleNumber :: Nomex RuleNumber + SetVictory :: [PlayerNumber] -> Nomex () + CurrentTime :: Nomex UTCTime + SelfRuleNumber :: Nomex RuleNumber --Monadic bindings - Return :: a -> Nomex a - Bind :: Nomex a -> (a -> Nomex b) -> Nomex b - ThrowError :: String -> Nomex a - CatchError :: Nomex a -> (String -> Nomex a) -> Nomex a + Return :: a -> Nomex a + Bind :: Nomex a -> (a -> Nomex b) -> Nomex b + ThrowError :: String -> Nomex a + CatchError :: Nomex a -> (String -> Nomex a) -> Nomex a deriving (Typeable) instance Monad Nomex where @@ -107,18 +92,6 @@ -- | a container for a variable name and type data V a = V {varName :: String} deriving (Typeable) --- | stores the variable's data -data Var = forall a . (Typeable a, Show a, Eq 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" - -instance Eq Var where - Var a b c == Var d e f = (a,b,c) === (d,e,f) - -- * Events -- | events types @@ -150,13 +123,7 @@ | TextData String | TextAreaData String | ButtonData --- an untyped version of InputData for serialization -data UInputData = URadioData Int - | UCheckboxData [Int] - | UTextData String - | UTextAreaData String - | UButtonData - deriving (Show, Read, Eq, Ord) + -- | data associated with each events data EventData a where @@ -187,43 +154,9 @@ deriving instance (Eq e) => Eq (Input e) deriving instance (Eq e) => Eq (InputForm e) -data Status = SActive | SDeleted deriving (Eq, Show) -data EventHandler where - EH :: (Typeable e, Show e, Eq e) => - {_eventNumber :: EventNumber, - _ruleNumber :: RuleNumber, - event :: Event e, - handler :: (EventNumber, EventData e) -> Nomex (), - _evStatus :: Status} -> EventHandler - -instance Show EventHandler where - show (EH en rn e _ _) = (show en) ++ " " ++ (show rn) ++ " (" ++ (show e) ++"),\n" - -instance Eq EventHandler where - (EH {_eventNumber=e1}) == (EH {_eventNumber=e2}) = e1 == e2 - -instance Ord EventHandler where - (EH {_eventNumber=e1}) <= (EH {_eventNumber=e2}) = e1 <= e2 - type Msg a = Event (Message a) type MsgData a = EventData (Message a) - --- * Outputs - -data Output = Output { _outputNumber :: OutputNumber, - _oRuleNumber :: PlayerNumber, - _oPlayerNumber :: PlayerNumber, - _output :: String, - _oStatus :: Status} - deriving (Show) - --- * Logs - -data Log = Log { _lPlayerNumber :: Maybe PlayerNumber, - _lTime :: UTCTime, - _lMsg :: String} - deriving (Show) -- * Rule @@ -265,10 +198,7 @@ | Pending -- Proposed rules | Reject -- Rejected rules deriving (Eq, Show, Typeable) - -data SubmitRule = SubmitRule RuleName RuleDesc RuleCode deriving (Show, Read, Eq, Ord, Data, Typeable) - - + -- * Player -- | informations on players @@ -276,70 +206,16 @@ _playerName :: String} deriving (Eq, Typeable, Show) --- * Game +instance Ord PlayerInfo where + h <= g = (_playerNumber h) <= (_playerNumber g) - --- | The state of the game: -data Game = Game { _gameName :: GameName, - _gameDesc :: GameDesc, - _rules :: [Rule], - _players :: [PlayerInfo], - _variables :: [Var], - _events :: [EventHandler], - _outputs :: [Output], - _victory :: [PlayerNumber], - _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 ---Game is not serializable in its entierety. We serialize only the adequate parts. -instance Read Game where - readPrec = parens $ ReadPrec.prec 11 $ do - Ident "Game" <- lexP; - Punc "{" <- lexP; - Ident "_gameName" <- lexP; - Punc "=" <- lexP; - name <- reset readPrec; - Punc "," <- lexP; - Ident "_gameDesc" <- lexP; - Punc "=" <- lexP; - desc <- reset readPrec; - Punc "," <- lexP; - Ident "_currentTime" <- lexP; - Punc "=" <- lexP; - time <- reset readPrec; - Punc "}" <- lexP; - return $ Game name desc [] [] [] [] [] [] [] time - readList = readListDefault - readListPrec = readListPrecDefault - -instance Show Game where - showsPrec p(Game name desc _ _ _ _ _ _ _ time) = showParen (p >= 11) $ - showString "Game {" . - showString "_gameName = " . - showsPrec 0 name . - showString ", " . - showString "_gameDesc = " . - showsPrec 0 desc . - showString ", " . - showString "_currentTime = " . - showsPrec 0 time . - showString "}" - showList = showList__ (showsPrec 0) - -displayGame :: Game -> String -displayGame (Game { _gameName, _rules, _players, _variables, _events, _outputs, _victory, _currentTime}) = - "Game Name = " ++ (show _gameName) ++ "\n Rules = " ++ (concat $ intersperse "\n " $ map show _rules) ++ "\n Players = " ++ (show _players) ++ "\n Variables = " ++ - (show _variables) ++ "\n Events = " ++ (show _events) ++ "\n Outputs = " ++ (show _outputs) ++ "\n Victory = " ++ (show _victory) ++ "\n currentTime = " ++ (show _currentTime) ++ "\n" +partial :: String -> Nomex (Maybe a) -> Nomex a +partial s nm = do + m <- nm + case m of + Just a -> return a + Nothing -> throwError s -$( makeLenses [''Game, ''GameDesc, ''Rule, ''PlayerInfo, ''EventHandler, ''Var, ''Output] ) +$( makeLenses [''Rule, ''PlayerInfo] ) diff --git a/src/Language/Nomyx/Game.hs b/src/Language/Nomyx/Game.hs deleted file mode 100644 --- a/src/Language/Nomyx/Game.hs +++ /dev/null @@ -1,198 +0,0 @@ -{-# LANGUAGE StandaloneDeriving, GADTs, DeriveDataTypeable, - FlexibleContexts, GeneralizedNewtypeDeriving, ScopedTypeVariables, - MultiParamTypeClasses, TemplateHaskell, TypeFamilies, - TypeOperators, FlexibleInstances, NoMonomorphismRestriction, - TypeSynonymInstances, DoAndIfThenElse, RecordWildCards #-} - --- | This module implements Game management. --- a game is a set of rules, and results of actions made by players (usually vote results) --- the module manages the effects of rules over each others. -module Language.Nomyx.Game (GameEvent(..), update, update', LoggedGame(..), game, gameLog, emptyGame, - execWithGame, execWithGame', getLoggedGame, tracePN, getTimes, activeRules, pendingRules, - rejectedRules, UInputData(..)) where - -import Prelude hiding (log) -import Control.Monad.State -import Data.List -import Language.Nomyx hiding (outputAll) -import Data.Lens -import Control.Category ((>>>)) -import Data.Lens.Template -import Control.Exception as E -import Control.Monad.Trans.State hiding (get) - -data TimedEvent = TimedEvent UTCTime GameEvent deriving (Show, Read, Eq, Ord) - -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) - ---A game being non serializable, we have to store events in parralel in order to rebuild the state latter. -data LoggedGame = LoggedGame { _game :: Game, - _gameLog :: [TimedEvent]} - deriving (Read, Show) - -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 - - -emptyGame name desc date = Game { - _gameName = name, - _gameDesc = desc, - _rules = [], - _players = [], - _variables = [], - _events = [], - _outputs = [], - _victory = [], - _logs = [], - _currentTime = date} - -$( makeLens ''LoggedGame) - ---TODO: get rid of inter param? -enactEvent :: GameEvent -> Maybe (RuleCode -> IO RuleFunc) -> StateT Game IO () -enactEvent (GameSettings name desc date) _ = mapStateIO $ gameSettings name desc date -enactEvent (JoinGame pn name) _ = mapStateIO $ joinGame name pn -enactEvent (LeaveGame pn) _ = mapStateIO $ leaveGame pn -enactEvent (ProposeRuleEv pn sr) (Just inter) = void $ proposeRule sr pn inter -enactEvent (InputResult pn en ir) _ = mapStateIO $ inputResult pn en ir -enactEvent (GLog mpn s) _ = mapStateIO $ logGame s mpn -enactEvent (TimeEvent t) _ = mapStateIO $ runEvalError 0 $ void $ evTriggerTime t -enactEvent (SystemAddRule r) (Just inter) = systemAddRule r inter -enactEvent (ProposeRuleEv _ _) Nothing = error "ProposeRuleEv: interpreter function needed" -enactEvent (SystemAddRule _) Nothing = error "SystemAddRule: interpreter function needed" - -enactTimedEvent :: Maybe (RuleCode -> IO RuleFunc) -> TimedEvent -> StateT Game IO () -enactTimedEvent 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 - -update :: GameEvent -> StateT LoggedGame IO () -update ge = update' Nothing ge - -update' :: Maybe (RuleCode -> IO RuleFunc) -> GameEvent -> StateT LoggedGame IO () -update' inter ge = do - t <- access $ game >>> currentTime - let te = TimedEvent t ge - gameLog %= \gl -> gl ++ [te] - focus game $ enactTimedEvent inter te - -getLoggedGame :: Game -> (RuleCode -> IO RuleFunc) -> [TimedEvent] -> IO LoggedGame -getLoggedGame 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} - players %= (player : ) - runEvalError pn $ triggerEvent_ (Player Arrive) (PlayerData player) - - --- | leave the game. -leaveGame :: PlayerNumber -> State Game () -leaveGame pn = runEvalError pn $ void $ evDelPlayer pn - --- | insert a rule in pending rules. -proposeRule :: SubmitRule -> PlayerNumber -> (RuleCode -> IO RuleFunc) -> StateT Game IO () -proposeRule sr pn inter = do - rule <- createRule sr pn inter - mapStateIO $ runEvalError pn $ do - r <- evProposeRule rule - if r == True then tracePN pn $ "Your rule has been added to pending rules." - else tracePN pn $ "Error: Rule could not be proposed" - -logGame :: String -> (Maybe PlayerNumber) -> State Game () -logGame s mpn = do - time <- access currentTime - void $ logs %= (Log mpn time s : ) - -inputResult :: PlayerNumber -> EventNumber -> UInputData -> State Game () -inputResult pn en ir = do - tracePN pn $ "input result: Event " ++ (show en) ++ ", choice " ++ (show ir) - runEvalError pn $ triggerInput en ir - -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 -> [Rule] -activeRules = sort . filter ((==Active) . getL rStatus) . _rules - -pendingRules :: Game -> [Rule] -pendingRules = sort . filter ((==Pending) . getL rStatus) . _rules - -rejectedRules :: Game -> [Rule] -rejectedRules = sort . filter ((==Reject) . getL rStatus) . _rules - -instance Ord PlayerInfo where - h <= g = (_playerNumber h) <= (_playerNumber g) - - -createRule :: SubmitRule -> PlayerNumber -> (RuleCode -> IO RuleFunc) -> StateT Game IO Rule -createRule (SubmitRule name desc code) pn inter = do - rs <- access rules - let rn = getFreeNumber $ map _rNumber rs - rf <- lift $ inter code - tracePN pn $ "Creating rule n=" ++ (show rn) ++ " code=" ++ code - return $ Rule {_rNumber = rn, - _rName = name, - _rDescription = desc, - _rProposedBy = pn, - _rRuleCode = code, - _rRuleFunc = rf, - _rStatus = Pending, - _rAssessedBy = Nothing} - -systemAddRule :: SubmitRule -> (RuleCode -> IO RuleFunc) -> StateT Game IO () -systemAddRule sr inter = do - rule <- createRule sr 0 inter - let sysRule = (rStatus ^= Active) >>> (rAssessedBy ^= Just 0) - rules %= (sysRule rule : ) - mapStateIO $ runEvalError 0 $ void $ evalExp (_rRuleFunc rule) (_rNumber rule) - -stateCatch = liftCatch E.catch diff --git a/src/Language/Nomyx/Inputs.hs b/src/Language/Nomyx/Inputs.hs new file mode 100644 --- /dev/null +++ b/src/Language/Nomyx/Inputs.hs @@ -0,0 +1,168 @@ +{-# LANGUAGE ScopedTypeVariables, GADTs #-} + +-- | All the building blocks to allow rules to get inputs. +module Language.Nomyx.Inputs where +-- Input(..), +-- InputForm(..), +-- inputRadio, inputRadioHead, inputRadioEnum, +-- inputRadioData, +-- onInputRadio, onInputRadio_, +-- onInputRadioOnce, onInputRadioOnce_, +-- onInputRadioEnum, onInputRadioEnum_, +-- onInputRadioEnumOnce_, +-- inputText, +-- inputTextData, +-- onInputText, onInputText_, +-- onInputTextOnce, onInputTextOnce_, +-- inputCheckboxData, +-- inputCheckbox, +-- onInputCheckbox, onInputCheckbox_, +-- onInputCheckboxOnce, onInputCheckboxOnce_, +-- inputButtonData, +-- inputButton, +-- onInputButton, onInputButton_, +-- onInputButtonOnce, onInputButtonOnce_, +-- inputTextareaData, +-- inputTextarea, +-- onInputTextarea, onInputTextarea_, +-- onInputTextareaOnce, onInputTextareaOnce_, + +import Language.Nomyx.Expression +import Language.Nomyx.Events +import Data.Typeable +import Control.Applicative + + +-- * Inputs + +-- ** Radio inputs + +inputRadio :: (Eq c, Show c, Typeable c) => PlayerNumber -> String -> [c] -> c -> Event (Input c) +inputRadio pn title cs _ = InputEv (Input pn title (Radio (zip cs (show <$> cs)))) + +inputRadioHead :: (Eq c, Show c, Typeable c) => PlayerNumber -> String -> [c] -> Event (Input c) +inputRadioHead pn title choices = inputRadio pn title choices (head choices) + +inputRadioEnum :: forall c. (Enum c, Bounded c, Typeable c, Eq c, Show c) => PlayerNumber -> String -> c -> Event (Input c) +inputRadioEnum pn title defaultChoice = inputRadio pn title (enumFrom (minBound::c)) defaultChoice + +inputRadioData :: (Show c) => EventData (Input c) -> c +inputRadioData (InputData (RadioData a)) = a +inputRadioData a = error $ "Not a Radio Data: " ++ (show a) + +-- | triggers a choice input to the user. The result will be sent to the callback +onInputRadio :: (Typeable a, Eq a, Show a) => String -> [a] -> (EventNumber -> a -> Nomex ()) -> PlayerNumber -> Nomex EventNumber +onInputRadio title choices handler pn = onEvent (inputRadioHead pn title choices) (\(en, InputData (RadioData a)) -> handler en a) + +-- | the same, disregard the event number +onInputRadio_ :: (Typeable a, Eq a, Show a) => String -> [a] -> (a -> Nomex ()) -> PlayerNumber -> Nomex () +onInputRadio_ title choices handler pn = onEvent_ (inputRadioHead pn title choices) (handler . inputRadioData) + +-- | the same, suppress the event after first trigger +onInputRadioOnce :: (Typeable a, Eq a, Show a) => String -> [a] -> (a -> Nomex ()) -> PlayerNumber -> Nomex EventNumber +onInputRadioOnce title choices handler pn = onEventOnce (inputRadioHead pn title choices) (handler . inputRadioData) + +-- | the same, disregard the event number +onInputRadioOnce_ :: (Typeable a, Eq a, Show a) => String -> [a] -> (a -> Nomex ()) -> PlayerNumber -> Nomex () +onInputRadioOnce_ title choices handler pn = onEventOnce_ (inputRadioHead pn title choices) (handler . inputRadioData) + +-- | triggers a choice input to the user, using an enumerate as input +onInputRadioEnum :: forall a. (Enum a, Bounded a, Typeable a, Eq a, Show a) => String -> a -> (EventNumber -> a -> Nomex ()) -> PlayerNumber -> Nomex EventNumber +onInputRadioEnum title defaultChoice handler pn = onEvent (inputRadioEnum pn title defaultChoice) (\(en, a) -> handler en (inputRadioData a)) + +-- | the same, disregard the event number +onInputRadioEnum_ :: forall a. (Enum a, Bounded a, Typeable a, Eq a, Show a) => String -> a -> (a -> Nomex ()) -> PlayerNumber -> Nomex () +onInputRadioEnum_ title defaultChoice handler pn = onEvent_ (inputRadioEnum pn title defaultChoice) (handler . inputRadioData) + +-- | the same, suppress the event after first trigger +onInputRadioEnumOnce_ :: forall a. (Enum a, Bounded a, Typeable a, Eq a, Show a) => String -> a -> (a -> Nomex ()) -> PlayerNumber -> Nomex () +onInputRadioEnumOnce_ title defaultChoice handler pn = onEventOnce_ (inputRadioEnum pn title defaultChoice) (handler . inputRadioData) + +-- ** Text inputs + +inputText :: PlayerNumber -> String -> Event (Input String) +inputText pn title = InputEv (Input pn title Text) + +inputTextData :: EventData (Input String) -> String +inputTextData (InputData (TextData a)) = a +inputTextData a = error $ "Not a Text Data: " ++ (show a) + +-- | triggers a string input to the user. The result will be sent to the callback +onInputText :: String -> (EventNumber -> String -> Nomex ()) -> PlayerNumber -> Nomex EventNumber +onInputText title handler pn = onEvent (inputText pn title) (\(en, a) -> handler en (inputTextData a)) + +-- | asks the player pn to answer a question, and feed the callback with this data. +onInputText_ :: String -> (String -> Nomex ()) -> PlayerNumber -> Nomex () +onInputText_ title handler pn = onEvent_ (inputText pn title) (handler . inputTextData) + +-- | asks the player pn to answer a question, and feed the callback with this data. +onInputTextOnce :: String -> (String -> Nomex ()) -> PlayerNumber -> Nomex EventNumber +onInputTextOnce title handler pn = onEventOnce (inputText pn title) (handler . inputTextData) + +onInputTextOnce_ :: String -> (String -> Nomex ()) -> PlayerNumber -> Nomex () +onInputTextOnce_ title handler pn = onEventOnce_ (inputText pn title) (handler . inputTextData) + +-- ** Checkbox inputs + +inputCheckboxData :: (Show c) => EventData (Input c) -> [c] +inputCheckboxData (InputData (CheckboxData a)) = a +inputCheckboxData a = error $ "Not a Checkbox Data: " ++ (show a) + +inputCheckbox :: (Eq c, Show c, Typeable c) => PlayerNumber -> String -> [(c, String)] -> Event (Input c) +inputCheckbox pn title cs = InputEv (Input pn title (Checkbox cs)) + +onInputCheckbox :: (Typeable a, Eq a, Show a) => String -> [(a, String)] -> (EventNumber -> [a] -> Nomex ()) -> PlayerNumber -> Nomex EventNumber +onInputCheckbox title choices handler pn = onEvent (inputCheckbox pn title choices) (\(en, InputData (CheckboxData a)) -> handler en a) + +onInputCheckbox_ :: (Typeable a, Eq a, Show a) => String -> [(a, String)] -> ([a] -> Nomex ()) -> PlayerNumber -> Nomex () +onInputCheckbox_ title choices handler pn = onEvent_ (inputCheckbox pn title choices) (handler . inputCheckboxData) + +onInputCheckboxOnce :: (Typeable a, Eq a, Show a) => String -> [(a, String)] -> ([a] -> Nomex ()) -> PlayerNumber -> Nomex EventNumber +onInputCheckboxOnce title choices handler pn = onEventOnce (inputCheckbox pn title choices) (handler . inputCheckboxData) + +onInputCheckboxOnce_ :: (Typeable a, Eq a, Show a) => String -> [(a, String)] -> ([a] -> Nomex ()) -> PlayerNumber -> Nomex () +onInputCheckboxOnce_ title choices handler pn = onEventOnce_ (inputCheckbox pn title choices) (handler . inputCheckboxData) + + +-- ** Button inputs + +inputButtonData :: EventData (Input ()) -> () +inputButtonData (InputData ButtonData) = () +inputButtonData a = error $ "Not a Button Data: " ++ (show a) + +inputButton :: PlayerNumber -> String -> Event (Input ()) +inputButton pn title = InputEv (Input pn title Button) + +onInputButton :: String -> (EventNumber -> () -> Nomex ()) -> PlayerNumber -> Nomex EventNumber +onInputButton title handler pn = onEvent (inputButton pn title) (\(en, InputData ButtonData) -> handler en ()) + +onInputButton_ :: String -> (() -> Nomex ()) -> PlayerNumber -> Nomex () +onInputButton_ title handler pn = onEvent_ (inputButton pn title) (handler . inputButtonData) + +onInputButtonOnce :: String -> (() -> Nomex ()) -> PlayerNumber -> Nomex EventNumber +onInputButtonOnce title handler pn = onEventOnce (inputButton pn title) (handler . inputButtonData) + +onInputButtonOnce_ :: String -> (() -> Nomex ()) -> PlayerNumber -> Nomex () +onInputButtonOnce_ title handler pn = onEventOnce_ (inputButton pn title) (handler . inputButtonData) + +-- ** Textarea inputs + +inputTextareaData :: EventData (Input String) -> String +inputTextareaData (InputData (TextAreaData a)) = a +inputTextareaData a = error $ "Not a Textarea Data: " ++ (show a) + +inputTextarea :: PlayerNumber -> String -> Event (Input String) +inputTextarea pn title = InputEv (Input pn title TextArea) + +onInputTextarea :: String -> (EventNumber -> String -> Nomex ()) -> PlayerNumber -> Nomex EventNumber +onInputTextarea title handler pn = onEvent (inputTextarea pn title) (\(en, a) -> handler en (inputTextareaData a)) + +onInputTextarea_ :: String -> (String -> Nomex ()) -> PlayerNumber -> Nomex () +onInputTextarea_ title handler pn = onEvent_ (inputTextarea pn title) (handler . inputTextareaData) + +onInputTextareaOnce :: String -> (String -> Nomex ()) -> PlayerNumber -> Nomex EventNumber +onInputTextareaOnce title handler pn = onEventOnce (inputTextarea pn title) (handler . inputTextareaData) + +onInputTextareaOnce_ :: String -> (String -> Nomex ()) -> PlayerNumber -> Nomex () +onInputTextareaOnce_ title handler pn = onEventOnce_ (inputTextarea pn title) (handler . inputTextareaData) + diff --git a/src/Language/Nomyx/Outputs.hs b/src/Language/Nomyx/Outputs.hs new file mode 100644 --- /dev/null +++ b/src/Language/Nomyx/Outputs.hs @@ -0,0 +1,78 @@ + +-- | All the building blocks to allow rules to produce outputs. +module Language.Nomyx.Outputs where +-- OutputNumber, +-- newOutput, newOutput_, +-- outputAll, outputAll_, outputAll', +-- getOutput, getOutput_, +-- updateOutput, updateOutput_, +-- delOutput, delOutput_, +-- displayVar, displaySimpleVar, +-- displayArrayVar, showArrayVar, + +import Language.Nomyx.Expression +import Language.Nomyx.Variables +import Data.Typeable +import Control.Monad.State + + +-- * Outputs + +-- | outputs a message to one player +newOutput :: Nomex String -> (Maybe PlayerNumber) -> Nomex OutputNumber +newOutput ns mpn = ns >>= NewOutput mpn + +newOutput_ :: Nomex String -> (Maybe PlayerNumber) -> Nomex () +newOutput_ ns pn = void $ newOutput ns pn + +-- | output a message to all players +outputAll :: Nomex String -> Nomex OutputNumber +outputAll ns = newOutput ns Nothing + +outputAll_ :: Nomex String -> Nomex () +outputAll_ ns = newOutput_ ns Nothing + +outputAll' :: String -> Nomex () +outputAll' s = newOutput_ (return s) Nothing + +getOutput :: OutputNumber -> Nomex (Maybe String) +getOutput on = GetOutput on + +getOutput_ :: OutputNumber -> Nomex String +getOutput_ on = partial "getOutput_ : Output number not existing" $ getOutput on + +updateOutput :: OutputNumber -> Nomex String -> Nomex Bool +updateOutput on ns = ns >>= UpdateOutput on + +updateOutput_ :: OutputNumber -> Nomex String -> Nomex () +updateOutput_ on ns = void $ updateOutput on ns + +delOutput :: OutputNumber -> Nomex Bool +delOutput = DelOutput + +delOutput_ :: OutputNumber -> Nomex () +delOutput_ on = void $ delOutput on + +-- permanently display a variable (update display when variable is updated) +displayVar :: (Typeable a, Show a, Eq a) => (Maybe PlayerNumber) -> MsgVar a -> (a -> Nomex String) -> Nomex () +displayVar mpn mv dis = onMsgVarEvent + mv + (\a -> newOutput (dis a) mpn) + (\a n -> updateOutput_ n (dis a)) + delOutput_ + +displaySimpleVar :: (Typeable a, Show a, Eq a) => (Maybe PlayerNumber) -> Nomex String -> MsgVar a -> Nomex () +displaySimpleVar mpn ntitle mv = do + let title a = do + t <- ntitle + return $ (t ++ ": " ++ (show a) ++ "\n") + displayVar mpn mv title + +displayArrayVar :: (Typeable a, Show a, Eq a, Typeable i, Show i, Eq i) => (Maybe PlayerNumber) -> Nomex String -> ArrayVar i a -> Nomex () +displayArrayVar mpn ntitle mv = displayVar mpn mv (showArrayVar ntitle) + +showArrayVar :: (Show a, Show i) => Nomex String -> [(i,a)] -> Nomex String +showArrayVar title l = do + t <- title + return $ t ++ "\n" ++ concatMap (\(i,a) -> (show i) ++ "\t" ++ (show a) ++ "\n") l + diff --git a/src/Language/Nomyx/Players.hs b/src/Language/Nomyx/Players.hs new file mode 100644 --- /dev/null +++ b/src/Language/Nomyx/Players.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE GADTs, ScopedTypeVariables, TupleSections #-} + +-- | All the building blocks to allow rules to manage players. +module Language.Nomyx.Players where +-- PlayerNumber, +-- PlayerName, +-- PlayerInfo(..), +-- Player(..), +-- playerNumber, playerName, +-- getPlayers, getPlayer, getPlayerName, +-- setPlayerName, +-- modifyPlayerName, +-- getPlayersNumber, getAllPlayerNumbers, +-- delPlayer, +-- forEachPlayer, forEachPlayer_, +-- createValueForEachPlayer, createValueForEachPlayer_, +-- getValueOfPlayer, +-- modifyValueOfPlayer, modifyAllValues, +-- showPlayer, +-- getSelfProposedByPlayer, +-- setVictory, +-- giveVictory, + +import Language.Nomyx.Expression +import Language.Nomyx.Events +import Language.Nomyx.Variables +import Language.Nomyx.Rules +import Data.Typeable +import Data.List +import Data.Lens +import Control.Applicative +import Control.Arrow + +-- * Players + +-- | get all the players +getPlayers :: Nomex [PlayerInfo] +getPlayers = GetPlayers + +-- | Get a specific player +getPlayer :: PlayerNumber -> Nomex (Maybe PlayerInfo) +getPlayer pn = do + pls <- GetPlayers + return $ find ((== pn) . getL playerNumber) pls + +-- | Set the name of a player +getPlayerName :: PlayerNumber -> Nomex (Maybe PlayerName) +getPlayerName pn = do + p <- getPlayer pn + return $ _playerName <$> p + +-- | Set the name of a player +setPlayerName :: PlayerNumber -> PlayerName -> Nomex Bool +setPlayerName = SetPlayerName + +modifyPlayerName :: PlayerNumber -> (PlayerName -> PlayerName) -> Nomex Bool +modifyPlayerName pn f = do + mn <- getPlayerName pn + case mn of + Just name -> setPlayerName pn (f name) + Nothing -> return False + + +-- | Get the total number of players +getPlayersNumber :: Nomex Int +getPlayersNumber = length <$> getPlayers + +-- | Get all the players number +getAllPlayerNumbers :: Nomex [PlayerNumber] +getAllPlayerNumbers = map _playerNumber <$> getPlayers + +-- | Remove the player from the game (kick) +delPlayer :: PlayerNumber -> Nomex Bool +delPlayer = DelPlayer + + +-- | perform an action for each current players, new players and leaving players +forEachPlayer :: (PlayerNumber -> Nomex ()) -> (PlayerNumber -> Nomex ()) -> (PlayerNumber -> Nomex ()) -> Nomex () +forEachPlayer action actionWhenArrive actionWhenLeave = do + pns <- getAllPlayerNumbers + mapM_ action pns + onEvent_ (Player Arrive) $ \(PlayerData p) -> actionWhenArrive $ _playerNumber p + onEvent_ (Player Leave) $ \(PlayerData p) -> actionWhenLeave $ _playerNumber p + +-- | perform the same action for each players, including new players +forEachPlayer_ :: (PlayerNumber -> Nomex ()) -> Nomex () +forEachPlayer_ action = forEachPlayer action action (\_ -> return ()) + +-- | create a value initialized for each players +--manages players joining and leaving +createValueForEachPlayer :: forall a. (Typeable a, Show a, Eq a) => a -> MsgVar [(PlayerNumber, a)] -> Nomex () +createValueForEachPlayer initialValue mv = do + pns <- getAllPlayerNumbers + v <- newMsgVar_ (getMsgVarName mv) $ map (,initialValue::a) pns + forEachPlayer (const $ return ()) + (\p -> modifyMsgVar v ((p, initialValue) : )) + (\p -> modifyMsgVar v $ filter $ (/= p) . fst) + +-- | create a value initialized for each players initialized to zero +--manages players joining and leaving +createValueForEachPlayer_ :: MsgVar [(PlayerNumber, Int)] -> Nomex () +createValueForEachPlayer_ = createValueForEachPlayer 0 + +getValueOfPlayer :: forall a. (Typeable a, Show a, Eq a) => PlayerNumber -> MsgVar [(PlayerNumber, a)] -> Nomex (Maybe a) +getValueOfPlayer pn var = do + value <- readMsgVar_ var + return $ lookup pn value + +modifyValueOfPlayer :: (Eq a, Show a, Typeable a) => PlayerNumber -> MsgVar [(PlayerNumber, a)] -> (a -> a) -> Nomex () +modifyValueOfPlayer pn var f = modifyMsgVar var $ map $ (\(a,b) -> if a == pn then (a, f b) else (a,b)) + +modifyAllValues :: (Eq a, Show a, Typeable a) => MsgVar [(PlayerNumber, a)] -> (a -> a) -> Nomex () +modifyAllValues var f = modifyMsgVar var $ map $ second f + +-- | show a player name based on his number +showPlayer :: PlayerNumber -> Nomex String +showPlayer pn = do + mn <- getPlayerName pn + case mn of + Just name -> return name + Nothing -> return ("Player " ++ (show pn)) + + +-- | set victory to a list of players +setVictory :: [PlayerNumber] -> Nomex () +setVictory = SetVictory + +-- | give victory to one player +giveVictory :: PlayerNumber -> Nomex () +giveVictory pn = SetVictory [pn] + + +getSelfProposedByPlayer :: Nomex PlayerNumber +getSelfProposedByPlayer = getSelfRule >>= return . _rProposedBy + diff --git a/src/Language/Nomyx/Rule.hs b/src/Language/Nomyx/Rule.hs deleted file mode 100644 --- a/src/Language/Nomyx/Rule.hs +++ /dev/null @@ -1,122 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable, GADTs, ScopedTypeVariables, TupleSections, - FlexibleInstances, TypeFamilies, FlexibleContexts, Rank2Types #-} - --- | Basic rules examples. -module Language.Nomyx.Rule where - -import Prelude hiding (foldr) -import Language.Nomyx.Expression -import Language.Nomyx.Definition -import Control.Arrow -import Data.Lens -import Data.Maybe -import Data.List - - - --- | This rule will activate automatically any new rule. -autoActivate :: RuleFunc -autoActivate = voidRule $ onEvent_ (RuleEv Proposed) (activateRule_ . _rNumber . ruleData) - --- | This rule will forbid any new rule to delete the rule in parameter ---immutableRule :: RuleNumber -> RuleFunc ---immutableRule rn = return $ Meta f where --- f r = do --- protectedRule <- getRule rn --- case protectedRule of --- Just pr -> case _rRuleFunc r of --- RuleRule paramRule -> paramRule pr --- _ -> return $ BoolResp True --- Nothing -> return $ BoolResp True - --- | A rule will be always legal -legal :: RuleFunc -legal = return $ Meta (\_ -> return $ BoolResp True) - --- | A rule will be always illegal -illegal :: RuleFunc -illegal = return $ Meta (\_ -> return $ BoolResp False) - --- | active metarules are automatically used to evaluate a given rule ---checkWithMetarules :: Rule -> Nomex (Event (Message ForAgainst) ---checkWithMetarules rule = do --- rs <- getActiveRules --- (metas :: [Rule -> Nomex BoolResp]) <- mapMaybeM maybeMetaRule rs --- let (evals :: [Nomex BoolResp]) = map (\meta -> meta rule) metas --- foldr (&&*) true evals - - -maybeMetaRule :: Rule -> Nomex (Maybe (Rule -> Nomex BoolResp)) -maybeMetaRule Rule {_rRuleFunc = rule} = do - meta <- rule - case meta of - (Meta m) -> return $ Just m - _ -> return Nothing - - - - --- | activate or reject a rule -activateOrReject :: Rule -> Bool -> Nomex () -activateOrReject r b = if b then activateRule_ (_rNumber r) else rejectRule_ (_rNumber r) - --- | perform an action for each current players, new players and leaving players -forEachPlayer :: (PlayerNumber -> Nomex ()) -> (PlayerNumber -> Nomex ()) -> (PlayerNumber -> Nomex ()) -> Nomex () -forEachPlayer action actionWhenArrive actionWhenLeave = do - pns <- getAllPlayerNumbers - mapM_ action pns - onEvent_ (Player Arrive) $ \(PlayerData p) -> actionWhenArrive $ _playerNumber p - onEvent_ (Player Leave) $ \(PlayerData p) -> actionWhenLeave $ _playerNumber p - --- | perform the same action for each players, including new players -forEachPlayer_ :: (PlayerNumber -> Nomex ()) -> Nomex () -forEachPlayer_ action = forEachPlayer action action (\_ -> return ()) - - --- | create a value initialized for each players ---manages players joining and leaving -createValueForEachPlayer :: Int -> MsgVar [(Int, Int)] -> Nomex () -createValueForEachPlayer initialValue mv = do - pns <- getAllPlayerNumbers - v <- newMsgVar_ (getMsgVarName mv) $ map (,initialValue::Int) pns - forEachPlayer (const $ return ()) - (\p -> modifyMsgVar v ((p, initialValue) : )) - (\p -> modifyMsgVar v $ filter $ (/= p) . fst) - --- | create a value initialized for each players initialized to zero ---manages players joining and leaving -createValueForEachPlayer_ :: MsgVar [(Int, Int)] -> Nomex () -createValueForEachPlayer_ = createValueForEachPlayer 0 - -getValueOfPlayer :: PlayerNumber -> MsgVar [(Int, Int)] -> Nomex (Maybe Int) -getValueOfPlayer pn var = do - value <- readMsgVar_ var - return $ lookup pn value - -modifyValueOfPlayer :: PlayerNumber -> MsgVar [(Int, Int)] -> (Int -> Int) -> Nomex () -modifyValueOfPlayer pn var f = modifyMsgVar var $ map $ (\(a,b) -> if a == pn then (a, f b) else (a,b)) - -modifyAllValues :: MsgVar [(Int, Int)] -> (Int -> Int) -> Nomex () -modifyAllValues var f = modifyMsgVar var $ map $ second f - --- | Player p cannot propose anymore rules -noPlayPlayer :: PlayerNumber -> RuleFunc -noPlayPlayer p = return $ Meta $ \r -> return $ BoolResp $ (_rProposedBy r) /= p - --- | a rule can autodelete itself (generaly after having performed some actions) -autoDelete :: Nomex () -autoDelete = getSelfRuleNumber >>= suppressRule_ - - --- | All rules from player p are erased: -eraseAllRules :: PlayerNumber -> Nomex Bool -eraseAllRules p = do - rs <- getRules - let myrs = filter ((== p) . getL rProposedBy) rs - res <- mapM (suppressRule . _rNumber) myrs - return $ and res - -showPlayer :: Nomex (PlayerNumber -> String) -showPlayer = do - pls <- getPlayers - return $ (\pn -> _playerName $ fromJust $ find (\(PlayerInfo mypn _) -> mypn == pn) pls) diff --git a/src/Language/Nomyx/Rules.hs b/src/Language/Nomyx/Rules.hs new file mode 100644 --- /dev/null +++ b/src/Language/Nomyx/Rules.hs @@ -0,0 +1,199 @@ + +-- | Basic rules examples. +module Language.Nomyx.Rules where +-- RuleFunc, +-- RuleResp(..), +-- Rule(..), +-- RuleNumber, +-- RuleCode, +-- RuleEvent(..), +-- RuleStatus(..), +-- voidRule, +-- activateRule, activateRule_, +-- rejectRule, rejectRule_, +-- getRules, getActiveRules, getRule, +-- getRulesByNumbers, +-- getRuleFuncs, +-- addRule, addRule_, addRuleParams, +-- getFreeRuleNumber, +-- suppressRule, suppressRule_, suppressAllRules, +-- modifyRule, +-- autoActivate, +-- activateOrReject, +-- noPlayPlayer, +-- autoDelete, +-- eraseAllRules, +-- getSelfRuleNumber, getSelfRule, + +import Prelude hiding (foldr) +import Language.Nomyx.Expression +import Language.Nomyx.Events +import Data.Lens +import Control.Monad +import Data.List +import Data.Maybe +--import Language.Nomyx.Utils + +-- * Rule management + +voidRule :: Nomex a -> Nomex RuleResp +voidRule e = e >> return Void + +-- | activate a rule: change its state to Active and execute it +activateRule :: RuleNumber -> Nomex Bool +activateRule = ActivateRule + +activateRule_ :: RuleNumber -> Nomex () +activateRule_ r = activateRule r >> return () + +-- | reject a rule: change its state to Suppressed and suppresses all its environment (events, variables, inputs) +-- the rule can be activated again later +rejectRule :: RuleNumber -> Nomex Bool +rejectRule = RejectRule + +rejectRule_ :: RuleNumber -> Nomex () +rejectRule_ r = void $ rejectRule r + +getRules :: Nomex [Rule] +getRules = GetRules + +getActiveRules :: Nomex [Rule] +getActiveRules = return . (filter ((== Active) . _rStatus) ) =<< getRules + +getRule :: RuleNumber -> Nomex (Maybe Rule) +getRule rn = do + rs <- GetRules + return $ find ((== rn) . getL rNumber) rs + +getRulesByNumbers :: [RuleNumber] -> Nomex [Rule] +getRulesByNumbers rns = mapMaybeM getRule rns + +getRuleFuncs :: Nomex [RuleFunc] +getRuleFuncs = return . (map _rRuleFunc) =<< getRules + +-- | add a rule to the game, it will have to be activated +addRule :: Rule -> Nomex Bool +addRule r = AddRule r + +addRule_ :: Rule -> Nomex () +addRule_ r = void $ AddRule r + +--TODO: too permissive. Should use SubmitRule instead. +addRuleParams :: RuleName -> RuleFunc -> RuleCode -> String -> Nomex RuleNumber +addRuleParams name func code desc = do + number <- getFreeRuleNumber + res <- addRule $ defaultRule {_rName = name, _rRuleFunc = func, _rRuleCode = code, _rNumber = number, _rDescription = desc} + return $ if res then number else error "addRuleParams: cannot add rule" + + +getFreeRuleNumber :: Nomex RuleNumber +getFreeRuleNumber = do + rs <- getRules + return $ getFreeNumber $ map _rNumber rs + +getFreeNumber :: (Eq a, Num a, Enum a) => [a] -> a +getFreeNumber l = head [a| a <- [1..], not $ a `elem` l] + +--suppresses completly a rule and its environment from the system +suppressRule :: RuleNumber -> Nomex Bool +suppressRule rn = RejectRule rn + +suppressRule_ :: RuleNumber -> Nomex () +suppressRule_ rn = void $ RejectRule rn + +suppressAllRules :: Nomex Bool +suppressAllRules = do + rs <- getRules + res <- mapM (suppressRule . _rNumber) rs + return $ and res + +modifyRule :: RuleNumber -> Rule -> Nomex Bool +modifyRule rn r = ModifyRule rn r + + +-- | This rule will activate automatically any new rule. +autoActivate :: RuleFunc +autoActivate = voidRule $ onEvent_ (RuleEv Proposed) (activateRule_ . _rNumber . ruleData) + +-- | This rule will forbid any new rule to delete the rule in parameter +--immutableRule :: RuleNumber -> RuleFunc +--immutableRule rn = return $ Meta f where +-- f r = do +-- protectedRule <- getRule rn +-- case protectedRule of +-- Just pr -> case _rRuleFunc r of +-- RuleRule paramRule -> paramRule pr +-- _ -> return $ BoolResp True +-- Nothing -> return $ BoolResp True + +-- | A rule will be always legal +legal :: RuleFunc +legal = return $ Meta (\_ -> return $ BoolResp True) + +-- | A rule will be always illegal +illegal :: RuleFunc +illegal = return $ Meta (\_ -> return $ BoolResp False) + +-- | active metarules are automatically used to evaluate a given rule +--checkWithMetarules :: Rule -> Nomex (Event (Message ForAgainst) +--checkWithMetarules rule = do +-- rs <- getActiveRules +-- (metas :: [Rule -> Nomex BoolResp]) <- mapMaybeM maybeMetaRule rs +-- let (evals :: [Nomex BoolResp]) = map (\meta -> meta rule) metas +-- foldr (&&*) true evals + + +maybeMetaRule :: Rule -> Nomex (Maybe (Rule -> Nomex BoolResp)) +maybeMetaRule Rule {_rRuleFunc = rule} = do + meta <- rule + case meta of + (Meta m) -> return $ Just m + _ -> return Nothing + + +-- | activate or reject a rule +activateOrReject :: Rule -> Bool -> Nomex () +activateOrReject r b = if b then activateRule_ (_rNumber r) else rejectRule_ (_rNumber r) + + +-- | Player p cannot propose anymore rules +noPlayPlayer :: PlayerNumber -> RuleFunc +noPlayPlayer p = return $ Meta $ \r -> return $ BoolResp $ (_rProposedBy r) /= p + +-- | a rule can autodelete itself (generaly after having performed some actions) +autoDelete :: Nomex () +autoDelete = getSelfRuleNumber >>= suppressRule_ + +-- | All rules from player p are erased: +eraseAllRules :: PlayerNumber -> Nomex Bool +eraseAllRules p = do + rs <- getRules + let myrs = filter ((== p) . getL rProposedBy) rs + res <- mapM (suppressRule . _rNumber) myrs + return $ and res + + +-- | allows a rule to retrieve its own number (for auto-deleting for example) +getSelfRuleNumber :: Nomex RuleNumber +getSelfRuleNumber = SelfRuleNumber + +getSelfRule :: Nomex Rule +getSelfRule = do + srn <- getSelfRuleNumber + rs:[] <- getRulesByNumbers [srn] + return rs + +-- | a default rule +defaultRule = Rule { + _rNumber = 1, + _rName = "", + _rDescription = "", + _rProposedBy = 0, + _rRuleCode = "", + _rRuleFunc = return Void, + _rStatus = Pending, + _rAssessedBy = Nothing} + +mapMaybeM :: (Monad m) => (a -> m (Maybe b)) -> [a] -> m [b] +mapMaybeM f = liftM catMaybes . mapM f + diff --git a/src/Language/Nomyx/Test.hs b/src/Language/Nomyx/Test.hs deleted file mode 100644 --- a/src/Language/Nomyx/Test.hs +++ /dev/null @@ -1,297 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable, NamedFieldPuns, GADTs#-} - -module Language.Nomyx.Test where - -import Language.Nomyx.Rule -import Language.Nomyx.Expression -import Language.Nomyx.Evaluation -import Language.Nomyx.Utils -import Language.Nomyx.Vote -import Control.Monad.State -import Data.Typeable -import Data.Lens -import Language.Nomyx.Definition - -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"], - _variables = [], - _events = [], - _outputs = [], - _victory = [], - _logs = [], - _currentTime = date1} - -testRule = Rule { _rNumber = 0, - _rName = "test", - _rDescription = "test", - _rProposedBy = 0, - _rRuleCode = "", - _rRuleFunc = return Void, - _rStatus = Pending, - _rAssessedBy = Nothing} - -evalRuleFunc f = evalState (runEvalError 0 $ evalExp f 0) testGame -execRuleFuncEvent f e d = execState (runEvalError 0 $ evalExp f 0 >> (triggerEvent_ e d)) testGame -execRuleFuncGame f g = execState (runEvalError 0 $ void $ evalExp f 0) g -execRuleFuncEventGame f e d g = execState (runEvalError 0 $ evalExp f 0 >> (triggerEvent_ e d)) g -execRuleFunc f = execRuleFuncGame f testGame - -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 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 = and $ map snd tests - ---Test variable creation -testVar1 :: RuleFunc -testVar1 = voidRule $ do - NewVar "toto" (1::Integer) - return () - -testVarEx1 = (variables ^$ execRuleFunc testVar1) == [(Var 0 "toto" (1::Integer))] - ---Test variable deleting -testVar2 :: RuleFunc -testVar2 = voidRule $ do - var <- newVar_ "toto" (1::Int) - delVar var - return () - -testVarEx2 = _variables (execRuleFunc testVar2) == [] - ---Test variable reading -testVar3 :: RuleFunc -testVar3 = voidRule $ do - var <- newVar_ "toto" (1::Int) - a <- readVar var - case a of - Just (1::Int) -> newOutput_ "ok" 1 - _ -> newOutput_ "nok" 1 - -testVarEx3 = isOutput "ok" (execRuleFunc testVar3) - ---Test variable writing -testVar4 :: RuleFunc -testVar4 = voidRule $ do - var <- newVar_ "toto" (1::Int) - writeVar var (2::Int) - a <- readVar var - case a of - Just (2::Int) -> newOutput_ "ok" 1 - _ -> newOutput_ "nok" 1 - -testVarEx4 = isOutput "ok" (execRuleFunc testVar4) - ---Test variable writing -testVar5 :: RuleFunc -testVar5 = voidRule $ do - var <- newVar_ "toto" ([]::[Int]) - writeVar var ([1]::[Int]) - a <- readVar var - case a of - Just (a::[Int]) -> do - writeVar var (2:a) - return () - Nothing -> newOutput_ "nok" 1 - -testVarEx5 = _variables (execRuleFunc testVar5) == [(Var 0 "toto" ([2,1]::[Int]))] - -data Choice = Holland | Sarkozy deriving (Enum, Typeable, Show, Eq, Bounded) - --- Test input -testSingleInput :: RuleFunc -testSingleInput = voidRule $ do - onInputRadioEnum_ "Vote for Holland or Sarkozy" Holland h 1 where - h a = newOutput_ ("voted for " ++ (show a)) 1 - -testSingleInputEx = isOutput "voted for Holland" g where - g = execRuleFuncEvent testSingleInput (inputRadioEnum 1 "Vote for Holland or Sarkozy" Holland) (InputData (RadioData Holland)) - -testMultipleInputs :: RuleFunc -testMultipleInputs = voidRule $ do - onInputCheckbox_ "Vote for Holland and Sarkozy" [(Holland, "Holland"), (Sarkozy, "Sarkozy")] h 1 where - h a = newOutput_ ("voted for " ++ (show a)) 1 - -testMultipleInputsEx = isOutput "voted for [Holland,Sarkozy]" g where - g = execRuleFuncEvent testMultipleInputs (inputCheckbox 1 "Vote for Holland and Sarkozy" [(Holland, "Holland"), (Sarkozy, "Sarkozy")]) (InputData (CheckboxData [Holland, Sarkozy])) - - -testInputString :: RuleFunc -testInputString = voidRule $ do - onInputText_ "Enter a number:" h 1 where - h a = newOutput_ ("You entered: " ++ a) 1 - -testInputStringEx = isOutput "You entered: 1" g where - g = execRuleFuncEvent testInputString (inputText 1 "Enter a number:") (InputData (TextData "1")) - --- Test message -testSendMessage :: RuleFunc -testSendMessage = voidRule $ do - let msg = Message "msg" :: Event(Message String) - onEvent_ msg f - sendMessage msg "toto" where - f (MessageData a :: EventData(Message String)) = newOutput_ a 1 - -testSendMessageEx = isOutput "toto" (execRuleFunc testSendMessage) - -testSendMessage2 :: RuleFunc -testSendMessage2 = voidRule $ do - onEvent_ (Message "msg":: Event(Message ())) $ const $ newOutput_ "Received" 1 - 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 :: RuleFunc -testUserInputWrite = voidRule $ do - newVar_ "vote" (Nothing::Maybe Choice2) - onEvent_ (Message "voted" :: Event (Message ())) h2 - onEvent_ (InputEv (Input 1 "Vote for" (Radio [(Me, "Me"), (You, "You")]))) h1 where - h1 (InputData (RadioData a) :: EventData (Input Choice2)) = do - writeVar (V "vote") (Just a) - SendMessage (Message "voted") () - h1 _ = undefined - h2 (MessageData _) = do - a <- readVar (V "vote") - case a of - Just (Just Me) -> newOutput_ "voted Me" 1 - _ -> newOutput_ "problem" 1 - h2 _ = undefined - -testUserInputWriteEx = isOutput "voted Me" g where - g = execRuleFuncEvent testUserInputWrite (InputEv (Input 1 "Vote for" (Radio [(Me, "Me"), (You, "You")]))) (InputData (RadioData Me)) - --- Test rule activation -testActivateRule :: RuleFunc -testActivateRule = voidRule $ do - a <- GetRules - if (_rStatus (head a) == Pending) then do - ActivateRule $ _rNumber (head a) - return () - else return () - - -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 :: RuleFunc -testTimeEvent = voidRule $ do - 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 = flip execState testGame (runEvalError 0 $ evalExp testTimeEvent2 0 >> void gameEvs) - gameEvs = do - evTriggerTime date1 - evTriggerTime date2 - - --- Test votes - -voteGameActions :: Int -> Int -> Int -> Bool -> Evaluate () -> Game -voteGameActions positives negatives total timeEvent actions = flip execState testGame {_players = []} $ runEvalError 0 $ do - mapM_ (\x -> addPlayer (PlayerInfo x $ "coco " ++ (show x))) [1..total] - actions - evProposeRule testRule - evs <- getChoiceEvents - let pos = take positives evs - let neg = take negatives $ drop positives evs - mapM_ (\x -> triggerInput x (URadioData $ fromEnum For)) pos - mapM_ (\x -> triggerInput x (URadioData $ fromEnum Against)) neg - when timeEvent $ void $ evTriggerTime date2 - -voteGame' :: Int -> Int -> Int -> Bool -> RuleFunc -> Game -voteGame' positives negatives notVoted timeEvent rf = voteGameActions positives negatives notVoted timeEvent $ do - let rule = testRule {_rName = "testRule", _rRuleFunc = rf, _rNumber = 1, _rStatus = Pending} - evAddRule rule - evActivateRule (_rNumber rule) 0 - return () - -voteGame :: Int -> Int -> Int -> RuleFunc -> Game -voteGame positives negatives notVoted rf = voteGame' positives negatives notVoted True rf - -voteGameTimed :: Int -> Int -> Int -> RuleFunc -> Game -voteGameTimed positives negatives notVoted rf = voteGame' positives negatives notVoted True rf - --- 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 - -isOutput :: String -> Game -> Bool -isOutput s g = any (\(Output _ _ _ mys SActive) -> mys == s) (_outputs g) - - diff --git a/src/Language/Nomyx/Utils.hs b/src/Language/Nomyx/Utils.hs deleted file mode 100644 --- a/src/Language/Nomyx/Utils.hs +++ /dev/null @@ -1,62 +0,0 @@ - - - -module Language.Nomyx.Utils where - - -import Data.Time -import Data.Typeable (cast, Typeable) -import Debug.Trace.Helpers (traceM) -import Data.Maybe (fromJust, catMaybes) -import System.Locale (rfc822DateFormat, defaultTimeLocale) -import Control.Monad.State -import Control.Monad.Identity -import Debug.Trace (trace) - --- | durations -oneWeek, oneDay, oneHour, oneMinute :: NominalDiffTime -oneWeek = 7 * oneDay -oneDay = 24 * oneHour -oneHour = 60 * oneMinute -oneMinute = 60 - --- | 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 - -mapMaybeM :: (Monad m) => (a -> m (Maybe b)) -> [a] -> m [b] -mapMaybeM f = liftM catMaybes . mapM f - -parse822Time :: String -> UTCTime -parse822Time = zonedTimeToUTC - . fromJust - . parseTime defaultTimeLocale rfc822DateFormat - -sndMaybe :: (a, Maybe b) -> Maybe (a,b) -sndMaybe (a, Just b) = Just (a,b) -sndMaybe (_, 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/Variables.hs b/src/Language/Nomyx/Variables.hs new file mode 100644 --- /dev/null +++ b/src/Language/Nomyx/Variables.hs @@ -0,0 +1,205 @@ +{-# LANGUAGE DeriveDataTypeable, GADTs, ScopedTypeVariables #-} + +-- | All the building blocks to allow rules to build variables. +module Language.Nomyx.Variables where +-- V(..), +-- VEvent(..), +-- MsgVar(..), +-- msgVar, +-- newMsgVar, newMsgVar_, newMsgVar', +-- writeMsgVar, writeMsgVar_, +-- readMsgVar, readMsgVar_, +-- modifyMsgVar, +-- delMsgVar, +-- onMsgVarEvent, onMsgVarChange, +-- getMsgVarMessage, +-- getMsgVarData, getMsgVarData_, +-- getMsgVarName, +-- ArrayVar, +-- newArrayVar, newArrayVar_, newArrayVar', +-- cleanOnFull, +-- isFullArrayVar_, +-- putArrayVar, putArrayVar_ + + +import Language.Nomyx.Expression +import Language.Nomyx.Events +import Data.Typeable +import Control.Monad.State +import Data.Maybe +import qualified Data.Map as M +import Data.Map hiding (map, filter, insert, mapMaybe, null) + + +-- * Variables +-- | variable creation +newVar :: (Typeable a, Show a, Eq a) => VarName -> a -> Nomex (Maybe (V a)) +newVar = NewVar + +newVar_ :: (Typeable a, Show a, Eq a) => VarName -> a -> Nomex (V a) +newVar_ s a = partial "newVar_: Variable existing" (newVar s a) + +-- | variable reading +readVar :: (Typeable a, Show a, Eq a) => (V a) -> Nomex (Maybe a) +readVar = ReadVar + +readVar_ :: forall a. (Typeable a, Show a, Eq a) => (V a) -> Nomex a +readVar_ v@(V a) = partial ("readVar_: Variable \"" ++ a ++ "\" with type \"" ++ (show $ typeOf v) ++ "\" not existing") (readVar v) + +-- | variable writing +writeVar :: (Typeable a, Show a, Eq a) => (V a) -> a -> Nomex Bool +writeVar = WriteVar + +writeVar_ :: (Typeable a, Show a, Eq a) => (V a) -> a -> Nomex () +writeVar_ var val = void $ writeVar var val + +-- | modify a variable using the provided function +modifyVar :: (Typeable a, Show a, Eq a) => (V a) -> (a -> a) -> Nomex () +modifyVar v f = writeVar_ v . f =<< readVar_ v + +-- | delete variable +delVar :: (V a) -> Nomex Bool +delVar = DelVar + +delVar_ :: (V a) -> Nomex () +delVar_ v = void $ delVar v + +-- * Message Variable +-- | a MsgVar is a variable with a message attached, allowing to trigger registered functions anytime the var if modified +data VEvent a = VUpdated a | VDeleted deriving (Typeable, Show, Eq) +data MsgVar a = MsgVar {message :: (Msg (VEvent a)), variable :: (V a) } + +msgVar :: String -> MsgVar a +msgVar a = MsgVar (Message a) (V a) + +newMsgVar :: (Typeable a, Show a, Eq a) => VarName -> a -> Nomex (Maybe (MsgVar a)) +newMsgVar name a = do + mv <- newVar name a + return $ mv >>= Just . MsgVar (Message name) + +newMsgVar_ :: (Typeable a, Show a, Eq a) => VarName -> a -> Nomex (MsgVar a) +newMsgVar_ name a = partial "newMsgVar_: Variable existing" (newMsgVar name a) + + +newMsgVar' :: (Typeable a, Show a, Eq a) => VarName -> a -> (VEvent a -> Nomex()) -> Nomex (Maybe (MsgVar a)) +newMsgVar' name a f = do + mv <- newMsgVar name a + case mv of + Just (MsgVar m _) -> do + onMessage m $ f . messageData + return mv + Nothing -> return Nothing + +writeMsgVar :: (Typeable a, Show a, Eq a) => MsgVar a -> a -> Nomex Bool +writeMsgVar (MsgVar m v) a = do + r <- writeVar v a + sendMessage m (VUpdated a) + return r + +writeMsgVar_ :: (Typeable a, Show a, Eq a) => MsgVar a -> a -> Nomex () +writeMsgVar_ mv a = void $ writeMsgVar mv a + +readMsgVar :: (Typeable a, Show a, Eq a) => MsgVar a -> Nomex (Maybe a) +readMsgVar (MsgVar _ v) = readVar v + +readMsgVar_ :: (Typeable a, Show a, Eq a) => MsgVar a -> Nomex a +readMsgVar_ mv = partial "readMsgVar_: variable not existing" (readMsgVar mv) + +modifyMsgVar :: (Typeable a, Show a, Eq a) => MsgVar a -> (a -> a) -> Nomex () +modifyMsgVar mv f = writeMsgVar_ mv . f =<< readMsgVar_ mv + +delMsgVar :: (Typeable a, Show a, Eq a) => MsgVar a -> Nomex Bool +delMsgVar (MsgVar m v) = do + sendMessage m VDeleted + delAllEvents m + delVar v + +onMsgVarChange :: (Typeable a, Show a, Eq a) => MsgVar a -> (VEvent a -> Nomex()) -> Nomex () +onMsgVarChange mv f = do + m <- getMsgVarMessage mv + onMessage m $ \(MessageData v) -> f v + +onMsgVarEvent :: (Typeable a, Show a, Eq a) + => MsgVar a + -> (a -> Nomex b) + -> (a -> b -> Nomex()) + -> (b -> Nomex()) + -> Nomex () +onMsgVarEvent mv create update delete = do + val <- readMsgVar_ mv + c <- create val + onMsgVarChange mv $ f c where + f c' (VUpdated v) = update v c' + f c' VDeleted = delete c' + +-- | get the messsage triggered when the array is filled +getMsgVarMessage :: (Typeable a, Show a, Eq a) => (MsgVar a) -> Nomex (Msg (VEvent a)) +getMsgVarMessage (MsgVar m _) = return m + +-- | get the association array +getMsgVarData :: (Typeable a, Show a, Eq a) => (MsgVar a) -> Nomex (Maybe a) +getMsgVarData (MsgVar _ v) = readVar v + +getMsgVarData_ :: (Typeable a, Show a, Eq a) => (MsgVar a) -> Nomex a +getMsgVarData_ (MsgVar _ v) = readVar_ v + +getMsgVarName :: (Typeable a, Show a, Eq a) => (MsgVar a) -> String +getMsgVarName (MsgVar _ (V varName)) = varName + + +-- * Variable arrays +-- | ArrayVar is an indexed array with a signal attached triggered at every change. +-- | each indexed elements starts empty (value=Nothing). +type ArrayVar i a = MsgVar [(i, Maybe a)] + +-- | initialize an empty ArrayVar +newArrayVar :: (Typeable a, Show a, Eq a, Typeable i, Show i, Eq i) => VarName -> [i] -> Nomex (Maybe (ArrayVar i a)) +newArrayVar name l = do + let list = map (\i -> (i, Nothing)) l + newMsgVar name list + +newArrayVar_ :: (Typeable a, Show a, Eq a, Typeable i, Show i, Eq i) => VarName -> [i] -> Nomex (ArrayVar i a) +newArrayVar_ name l = partial "newArrayVar_: Variable existing" (newArrayVar name l) + +-- | initialize an empty ArrayVar, registering a callback that will be triggered at every change +newArrayVar' :: (Typeable a, Show a, Eq a, Typeable i, Show i, Eq i) => VarName -> [i] -> (VEvent [(i,Maybe a)] -> Nomex ()) -> Nomex (Maybe (ArrayVar i a)) +newArrayVar' name l f = do + let list = map (\i -> (i, Nothing)) l + newMsgVar' name list f + +-- | initialize an empty ArrayVar, registering a callback. +-- the ArrayVar will be deleted when full +newArrayVarOnce :: (Ord i, Typeable a, Show a, Eq a, Typeable i, Show i) => VarName -> [i] -> (VEvent [(i, Maybe a)] -> Nomex ()) -> Nomex (Maybe (ArrayVar i a)) +newArrayVarOnce name l f = do + mv <- newArrayVar' name l f + when (isJust mv) $ cleanOnFull $ fromJust mv + return mv + +cleanOnFull :: (Typeable a, Show a, Eq a, Ord i, Typeable i, Show i) => (ArrayVar i a) -> Nomex () +cleanOnFull ar = do + m <- getMsgVarMessage ar + onMessage m $ \_ -> do + full <- (isFullArrayVar_ ar) + when full $ void $ delMsgVar ar + return () + return () + +isFullArrayVar_ :: (Ord i, Typeable a, Show a, Eq a, Typeable i, Show i) => (ArrayVar i a) -> Nomex Bool +isFullArrayVar_ av = do + md <- getMsgVarData av + return $ and $ map isJust $ map snd $ fromJust md + + +-- | store one value and the given index. If this is the last filled element, the registered callbacks are triggered. +putArrayVar :: (Ord i, Typeable a, Show a, Eq a, Typeable i, Show i) => (ArrayVar i a) -> i -> a -> Nomex Bool +putArrayVar mv i a = do + ma <- readMsgVar mv + case ma of + Just ar -> do + let ar2 = M.insert i (Just a) (fromList ar) + writeMsgVar mv (toList ar2) + Nothing -> return False + +putArrayVar_ :: (Ord i, Typeable a, Show a, Eq a, Typeable i, Show i) => (ArrayVar i a) -> i -> a -> Nomex () +putArrayVar_ mv i a = void $ putArrayVar mv i a + 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 @@ -6,16 +6,21 @@ import Prelude hiding (foldr) import Language.Nomyx.Expression -import Language.Nomyx.Definition -import Language.Nomyx.Rule +import Language.Nomyx.Events +import Language.Nomyx.Variables +import Language.Nomyx.Outputs +import Language.Nomyx.Inputs +import Language.Nomyx.Players +import Language.Nomyx.Rules import Data.Typeable import Control.Monad.State hiding (forM_) import Data.Maybe import Data.Time hiding (getCurrentTime) import Control.Arrow import Control.Applicative -import Language.Nomyx.Utils +--import Language.Nomyx.Utils import Data.List +import Data.Function import qualified Data.Map as M import Control.Monad.Error (MonadError(..)) @@ -25,10 +30,10 @@ class (Eq (Alts a), Show (Alts a), Ord (Alts a), Typeable a) => Votable a where data Alts a - alts :: [Alts a] - quota :: Alts a -> Int -> Int -> Int + alts :: [Alts a] -- The alternatives + quota :: Alts a -> Int -> Int -> Int -- "quota alts q total" gives the quota to reach for each alternatives name :: a -> String - exclusiveWinner :: a -> Maybe (Alts a, Alts a) + exclusiveWinner :: a -> Maybe (Alts a, Alts a) --The Votable as only two alternatives, one excluding the other exclusiveWinner _ = Nothing type ForAgainst = Alts Rule @@ -71,7 +76,7 @@ --set the assessors evalStateT assessors voteData --display the vote - mapM (\n -> displayVoteVar n ("Votes for " ++ toVoteName ++ ":") voteVar) pns + displayVoteVar Nothing ("On-going vote for " ++ toVoteName ++ ":") voteVar displayVoteResult toVoteName voteData --clean the vote at the end cleanVote voteData @@ -151,6 +156,27 @@ -- | assess the vote results according to a necessary number of positive votes numberVotes :: (Votable a) => Int -> VoteStats a -> [Alts a] numberVotes i vs = voteQuota i vs + +-- | the winners are the x vote alternatives with the more votes +firstXBest :: forall a. (Votable a) => Int -> VoteStats a -> [Alts a] +firstXBest x votes = map fst $ takeInGroups x $ sortedVotesWithExAequoGroups where + voted (Just a, n) = Just (a, n) + voted (Nothing, _) = Nothing + sortedVotesWithExAequoGroups :: [[(Alts a, Int)]] + sortedVotesWithExAequoGroups = (groupBy ((==) `on` snd)) $ sortWith snd $ catMaybes $ map voted $ M.assocs (voteCounts votes) + +--take n elements from the first lists, but do not break groups +takeInGroups :: Int -> [[a]] -> [a] +takeInGroups 0 _ = [] +takeInGroups n grps = if grpsSize <= n then (head grps) ++ takeInGroups (n - grpsSize) (tail grps) else (head grps) where + grpsSize = length $ head grps + +-- | the winner is the vote alternative with the more votes +firstBest :: (Votable a) => VoteStats a -> [Alts a] +firstBest = firstXBest 1 + +sortWith :: Ord b => (a -> b) -> [a] -> [a] +sortWith f = sortBy (\x y -> compare (f x) (f y)) -- | return the vote alternatives that are above threshold voteQuota :: forall a. (Votable a) => Int -> VoteStats a -> [Alts a] @@ -158,6 +184,7 @@ Nothing -> catMaybes $ M.keys $ M.filter (>= q) (voteCounts votes) Just a -> maybeToList $ exclusiveVoteQuota q votes a +-- | in case of exclusive winner exclusiveVoteQuota :: (Votable a) => Int -> VoteStats a -> (Alts a, Alts a) -> Maybe (Alts a) exclusiveVoteQuota q votes (for, against) | M.findWithDefault 0 (Just for) vs >= q = Just for @@ -188,10 +215,8 @@ counts as = map (head &&& length) (group $ sort as) -displayVoteVar :: (Votable a) => PlayerNumber -> String -> ArrayVar PlayerNumber (Alts a) -> Nomex () -displayVoteVar pn title mv = do - sp <- showPlayer - displayVar pn mv (showVotes title sp) +displayVoteVar :: (Votable a) => (Maybe PlayerNumber) -> String -> ArrayVar PlayerNumber (Alts a) -> Nomex () +displayVoteVar mpn title mv = displayVar mpn mv (showOnGoingVote title) showChoice :: (Votable a) => Maybe (Alts a) -> String @@ -199,22 +224,31 @@ showChoice Nothing = "Not Voted" showChoices :: (Votable a) => [(Alts a)] -> String +showChoices [] = "no result" showChoices cs = concat $ intersperse ", " $ map show cs -showVotes :: (Votable a) => String -> (PlayerNumber -> String) -> [(PlayerNumber, Maybe (Alts a))] -> String -showVotes title showPlayer l = title ++ "\n" ++ - concatMap (\(i,a) -> (showPlayer i) ++ "\t" ++ (showChoice a) ++ "\n") l +showOnGoingVote :: (Votable a) => String -> [(PlayerNumber, Maybe (Alts a))] -> Nomex String +showOnGoingVote title listVotes = do + list <- mapM showVote listVotes + return $ title ++ "\n" ++ concatMap (\(name, vote) -> name ++ "\t" ++ vote ++ "\n") list -showVotes' :: (Votable a) => (PlayerNumber -> String) -> [(PlayerNumber, Maybe (Alts a))] -> String -showVotes' showPlayer l = concat $ intersperse ", " $ map (\(i,a) -> (showPlayer i) ++ ": " ++ (showChoice a)) voted where - voted = filter (\(_, r) -> isJust r) l +showFinishedVote :: (Votable a) => [(PlayerNumber, Maybe (Alts a))] -> Nomex String +showFinishedVote l = do + let voted = filter (\(_, r) -> isJust r) l + votes <- mapM showVote voted + return $ concat $ intersperse ", " $ map (\(name, vote) -> name ++ ": " ++ vote) votes + +showVote :: (Votable a) => (PlayerNumber, Maybe (Alts a)) -> Nomex (String, String) +showVote (pn, v) = do + name <- showPlayer pn + return (name, showChoice v) displayVoteResult :: (Votable a) => String -> VoteData a -> Nomex () displayVoteResult toVoteName (VoteData msgEnd voteVar _ _) = onMessage msgEnd $ \(MessageData result) -> do vs <- getMsgVarData_ voteVar - sp <- showPlayer - outputAll $ "Vote result for " ++ toVoteName ++ ": " ++ (showChoices result) ++ - " (" ++ showVotes' sp vs ++ ")" + votes <- showFinishedVote vs + outputAll' $ "Vote result for " ++ toVoteName ++ ": " ++ (showChoices result) ++ + " (" ++ votes ++ ")" -- | any new rule will be activate if the rule in parameter returns True onRuleProposed :: (Rule -> Nomex (Msg [ForAgainst]) ) -> RuleFunc @@ -222,6 +256,8 @@ resp <- f rule onMessageOnce resp $ (activateOrReject rule) . (== [For]) . messageData + + -- * Referendum & elections data Referendum = Referendum String deriving (Typeable) @@ -237,10 +273,10 @@ msg <- voteWith_ (majority `withQuorum` 2) (assessOnEveryVote >> assessOnTimeDelay oneDay) (Referendum name) onMessageOnce msg resolution where resolution (MessageData [Yes]) = do - outputAll "Positive result of referendum" + outputAll' "Positive result of referendum" action - resolution (MessageData [No]) = outputAll "Negative result of referendum" - resolution (MessageData []) = outputAll "No result for referendum" + resolution (MessageData [No]) = outputAll' "Negative result of referendum" + resolution (MessageData []) = outputAll' "No result for referendum" resolution (MessageData _) = throwError "Impossible result for referendum" @@ -262,10 +298,10 @@ elections :: String -> [PlayerInfo] -> (PlayerNumber -> Nomex()) -> Nomex () elections name pns action = do - msg <- voteWith majority (assessWhenEverybodyVoted {-assessOnEveryVotes >> assessOnTimeDelay oneDay-}) (Election name) (Candidate <$> pns) + msg <- voteWith majority (assessOnTimeDelay oneDay) (Election name) (Candidate <$> pns) onMessageOnce msg resolution where resolution (MessageData [Candidate pi]) = do - outputAll $ "Result of elections: player(s) " ++ (show $ _playerName pi) ++ " won!" + outputAll' $ "Result of elections: player(s) " ++ (show $ _playerName pi) ++ " won!" action $ _playerNumber pi - resolution (MessageData []) = outputAll $ "Result of elections: nobody won!" + resolution (MessageData []) = outputAll' "Result of elections: nobody won!" resolution (MessageData _) = throwError "Impossible result for elections"