diff --git a/AUTHORS b/AUTHORS --- a/AUTHORS +++ b/AUTHORS @@ -1,1 +1,1 @@ -corentin.dupont@gmail.com +Corentin Dupont (remove DELAVEGA to obtain my email) diff --git a/Nomyx-Core.cabal b/Nomyx-Core.cabal --- a/Nomyx-Core.cabal +++ b/Nomyx-Core.cabal @@ -1,5 +1,5 @@ name: Nomyx-Core -version: 0.5.0 +version: 0.6.0 cabal-version: >=1.6 build-type: Simple license: BSD3 @@ -15,7 +15,7 @@ data-dir: data library - build-depends: Nomyx-Language == 0.5.0, + build-depends: Nomyx-Language == 0.6.0, DebugTraceHelpers == 0.12.*, MissingH == 1.2.*, acid-state == 0.12.*, @@ -38,8 +38,9 @@ ixset == 1.0.*, mime-mail == 0.4.*, mtl == 2.1.*, - mueval == 0.9.*, + deepseq == 1.3.*, network == 2.4.*, + old-locale == 1.0.*, safe == 0.3.*, safecopy == 0.8.*, stm == 2.4.*, @@ -63,13 +64,20 @@ Nomyx.Core.Multi Nomyx.Core.Serialize Nomyx.Core.Interpret + Nomyx.Core.Context Nomyx.Core.Quotes Nomyx.Core.Mail Nomyx.Core.Utils Nomyx.Core.Test + Nomyx.Core.Engine + Nomyx.Core.Engine.Evaluation + Nomyx.Core.Engine.Game + Nomyx.Core.Engine.GameEvents + Nomyx.Core.Engine.Test + Nomyx.Core.Engine.Utils Paths_Nomyx_Core ghc-options: -W -threaded source-repository head type: git - location: git://github.com/cdupont/Nomyx-Core.git + location: https://github.com/cdupont/Nomyx-Core.git diff --git a/README b/README --- a/README +++ b/README @@ -1,5 +1,3 @@ -[![Build Status](https://travis-ci.org/cdupont/Nomyx-Core.png?branch=master)](https://travis-ci.org/cdupont/Nomyx-Core) -[![Hackage](https://budueba.com/hackage/Nomyx-Core)](https://hackage.haskell.org/package/Nomyx-Core) Nomyx-Core ========= diff --git a/src/Nomyx/Core/Context.hs b/src/Nomyx/Core/Context.hs new file mode 100644 --- /dev/null +++ b/src/Nomyx/Core/Context.hs @@ -0,0 +1,71 @@ +module Nomyx.Core.Context ( + unQualImports, + qualImports, + defaultPackages +) where + + +unQualImports :: [String] +unQualImports = ["Language.Nomyx", + "Language.Nomyx.Examples", + "Safe", + "Data.Typeable", + "Data.Lens", + "Prelude", + "Data.Function", + "Control.Applicative", + "Control.Arrow", + "Control.Monad", + "Control.Monad.Cont", + "Control.Monad.Error", + "Control.Monad.Fix", + "Control.Monad.Identity", + "Control.Monad.Instances", + "Control.Monad.RWS", + "Control.Monad.Reader", + "Control.Monad.State", + "Control.Monad.State", + "Control.Monad.Writer", + "Data.Array", + "Data.Bits", + "Data.Bool", + "Data.Char", + "Data.Complex", + "Data.Dynamic", + "Data.Either", + "Data.Eq", + "Data.Fixed", + "Data.Graph", + "Data.Int", + "Data.Ix", + "Data.List", + "Data.Maybe", + "Data.Monoid", + "Data.Ord", + "Data.Ratio", + "Data.Tree", + "Data.Tuple", + "Data.Typeable", + "Data.Word", + "System.Random"] + +defaultPackages :: [String] +defaultPackages = ["Nomyx-Language", + "array", + "base", + "bytestring", + "containers"] + +qualImports :: [(String, Maybe String)] +qualImports = [("Control.Category", Just "C"), + ("Data.ByteString", Just "BS"), + ("Data.ByteString.Char8", Just "BSC"), + ("Data.ByteString.Lazy", Just "BSL"), + ("Data.ByteString.Lazy.Char8", Just "BSLC"), + ("Data.Foldable", Just "Data.Foldable"), + ("Data.IntMap", Just "IM"), + ("Data.IntSet", Just "IS"), + ("Data.Map", Just "M"), + ("Data.Sequence", Just "Data.Sequence"), + ("Data.Set", Just "S"), + ("Data.Traversable", Just "Data.Traversable") ] diff --git a/src/Nomyx/Core/Engine.hs b/src/Nomyx/Core/Engine.hs new file mode 100644 --- /dev/null +++ b/src/Nomyx/Core/Engine.hs @@ -0,0 +1,63 @@ + +-- | 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 Nomyx.Core.Engine( + -- * Game management + GameEvent(..), + LoggedGame(..), + GameName, + Game(..), + GameDesc(..), + execGameEvent, execGameEvent', + execWithGame, execWithGame', + game, + emptyGame, + getLoggedGame, + gameName, + players, + getVictorious, + + -- * Variables management + Var(..), + + -- * Rules management + SubmitRule(..), + activeRules, pendingRules, rejectedRules, + + -- * Events management + EventInfo(..), + EventHandler, + Status(..), + events, + getEventFields, + getInput, + getEventInfo, + + -- * Inputs management + InputData(..), + + -- * Outputs management + Output(..), + Log(..), + evalOutput, + isOutput, + + -- * Time + getTimes, + currentTime, + + -- * Misc + tracePN, + replaceWith, + getChoiceEvents, + getTextEvents + ) where + +import Nomyx.Core.Engine.Evaluation +import Nomyx.Core.Engine.Game +import Nomyx.Core.Engine.GameEvents +import Nomyx.Core.Engine.Utils +import Nomyx.Core.Engine.Test + diff --git a/src/Nomyx/Core/Engine/Evaluation.hs b/src/Nomyx/Core/Engine/Evaluation.hs new file mode 100644 --- /dev/null +++ b/src/Nomyx/Core/Engine/Evaluation.hs @@ -0,0 +1,473 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE StandaloneDeriving #-} + +module Nomyx.Core.Engine.Evaluation where + +import Prelude hiding ((.), log) +import Control.Monad +import Control.Monad.State +import Control.Monad.Reader +import Data.List +import Data.Typeable +import Data.Function hiding ((.)) +import Data.Time +import Data.Lens +import Data.Maybe +import Control.Category hiding (id) +import Control.Applicative +import Control.Monad.Error (ErrorT(..)) +import Control.Monad.Error.Class (MonadError(..)) +import Language.Nomyx.Expression +import Nomyx.Core.Engine.Game +import Nomyx.Core.Engine.Utils +import Safe + +type Evaluate a = ErrorT String (State Game) a + +-- data sent back by the forms +data InputData = RadioData Int + | CheckboxData [Int] + | TextData String + | TextAreaData String + | ButtonData + deriving (Show, Read, Eq, Ord) + +-- | evaluate an expression. +-- The rule number passed is the number of the rule containing the expression. +evalNomex :: Nomex a -> RuleNumber -> Evaluate a +evalNomex (NewVar name def) rn = do + vars <- access variables + case find ((== name) . getL vName) vars of + Nothing -> do + variables %= (Var rn name def : ) + return $ Just (V name) + Just _ -> return Nothing + +evalNomex (DelVar (V name)) _ = do + vars <- access variables + case find ((== name) . getL vName) vars of + Nothing -> return False + Just _ -> do + variables %= filter ((/= name) . getL vName) + return True + +evalNomex (WriteVar (V name) val) _ = do + vars <- access variables + case find (\(Var _ myName _) -> myName == name) vars of + Nothing -> return False + Just (Var rn myName _) -> do + variables %= replaceWith ((== name) . getL vName) (Var rn myName val) + return True + +evalNomex (OnEvent event handler) rn = do + evs <- access events + let en = getFreeNumber (map _eventNumber evs) + events %= (EventInfo en rn (indexInputs event) handler SActive [] : ) + return en + +evalNomex (DelEvent en) _ = evDelEvent en + +evalNomex (SendMessage (Msg id) myData) _ = triggerEvent (Message (Msg id)) myData + +evalNomex (NewOutput pn s) rn = evNewOutput pn rn s +evalNomex (UpdateOutput on s) _ = evUpdateOutput on s +evalNomex (DelOutput on) _ = evDelOutput on +evalNomex (ProposeRule rule) _ = evProposeRule rule +evalNomex (ActivateRule rule) rn = evActivateRule rule rn +evalNomex (RejectRule rule) rn = evRejectRule rule rn +evalNomex (AddRule rule) _ = evAddRule rule +evalNomex (ModifyRule mod rule) _ = evModifyRule mod rule +evalNomex (SetPlayerName pn n) _ = evChangeName pn n +evalNomex (DelPlayer pn) _ = evDelPlayer pn +evalNomex (LiftEffect e) pn = liftEval $ evalNomexNE e pn + + +evalNomex (ThrowError s) _ = throwError s +evalNomex (CatchError n h) rn = catchError (evalNomex n rn) (\a -> evalNomex (h a) rn) +evalNomex (SetVictory ps) rn = do + void $ victory ~= (Just $ VictoryCond rn ps) + triggerEvent Victory (VictoryCond rn ps) + +evalNomex (Return a) _ = return a +evalNomex (Bind exp f) rn = do + e <- evalNomex exp rn + evalNomex (f e) rn + +liftEval :: Reader Game a -> Evaluate a +liftEval r = runReader r <$> get + +evalNomexNE :: NomexNE a -> RuleNumber -> Reader Game a +evalNomexNE (ReadVar (V name)) _ = do + vars <- asks _variables + let var = find ((== name) . getL vName) vars + case var of + Nothing -> return Nothing + Just (Var _ _ val) -> case cast val of + Just v -> return $ Just v + Nothing -> return Nothing + +evalNomexNE (GetOutput on) _ = evGetOutput on +evalNomexNE GetRules _ = asks _rules +evalNomexNE GetPlayers _ = asks _players +evalNomexNE SelfRuleNumber rn = return rn +evalNomexNE (CurrentTime) _ = asks _currentTime +evalNomexNE (Return a) _ = return a +evalNomexNE (Bind exp f) rn = do + e <- evalNomexNE exp rn + evalNomexNE (f e) rn + +evalNomexNE (Simu sim ev) rn = do + let s = runEvalError Nothing (evalNomex sim rn) + g <- ask + let g' = execState s g + return $ runReader (evalNomexNE ev rn) g' + +getVictorious :: Game -> [PlayerNumber] +getVictorious g = case _victory g of + Nothing -> [] + Just (VictoryCond rn v) -> runReader (evalNomexNE v rn) g + +evalOutput :: Game -> Output -> String +evalOutput g (Output _ rn _ o _) = runReader (evalNomexNE o rn) g + +allOutputs :: Game -> [String] +allOutputs g = map (evalOutput g) (_outputs g) + +triggerEvent :: (Typeable e, Show e) => Field e -> e -> Evaluate () +triggerEvent e dat = do + evs <- access events + triggerEvent' e dat evs + +-- receive a field data +triggerEvent' :: (Typeable e, Show e) => Field e -> e -> [EventInfo] -> Evaluate () +triggerEvent' e dat evs = do + let evs' = map (updateEventInfo e dat) evs + events %= union (map fst evs') + mapM triggerIfComplete evs' + return () + +updateEventInfo :: (Typeable a, Show a) => Field a -> a -> EventInfo -> (EventInfo, Maybe SomeData) +updateEventInfo field dat ei@(EventInfo _ _ ev _ _ envi) = + if (SomeField field) `elem` (getEventFields ev envi) -- if the field if found among the remaining fields of the event + then case getEventResult ev (eventRes : envi) of -- then check the event with that field result included + BE (Left _) -> (env ^= (eventRes : envi) $ ei, Nothing) -- some fields are left to complete: add ours in the environment + BE (Right a) -> (env ^= [] $ ei, Just $ SomeData a) -- the event is now complete: empty the environment and set the handler to be triggered + else (ei, Nothing) -- field not found: do nothing + where eventRes = EventEnv field dat + +data SomeData = forall e. (Typeable e, Show e) => SomeData e +deriving instance Show SomeData + +-- in the case an event is complete, trigger its handler +triggerIfComplete :: (EventInfo, Maybe SomeData) -> Evaluate () +triggerIfComplete (EventInfo en rn _ h SActive _, Just (SomeData val)) = do + case (cast val) of + Just a -> do + let exp = h (en, a) + (evalNomex exp rn) `catchError` (errorHandler rn en) + Nothing -> error "Bad trigger data type" +triggerIfComplete _ = return () + +-- compute the result of an event given an environment. +-- in the case the event cannot be computed because some fields results are pending, return that list instead. +getEventResult :: Event a -> [EventEnv] -> BEither [SomeField] a +getEventResult (PureEvent a) _ = BE (Right a) +getEventResult EmptyEvent _ = BE (Left []) +getEventResult (SumEvent a b) ers = (getEventResult a ers) <|> (getEventResult b ers) +getEventResult (AppEvent f b) ers = (getEventResult f ers) <*> (getEventResult b ers) +getEventResult (BaseEvent a) ers = case lookupField a ers of + Just r -> BE (Right r) + Nothing -> BE (Left [SomeField a]) + +-- find a field result in an environment +lookupField :: Typeable a => Field a -> [EventEnv] -> Maybe a +lookupField _ [] = Nothing +lookupField be (EventEnv a r : ers) = case (cast (a,r)) of + Just (a',r') -> if (a' == be) then Just r' else lookupField be ers + Nothing -> lookupField be ers + +--get the fields lefft to be completed in an event +getEventFields :: Event a -> [EventEnv] -> [SomeField] +getEventFields e er = case (getEventResult e er) of + BE (Right _) -> [] + BE (Left a) -> a + +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 -> InputNumber -> InputData -> Evaluate () +triggerInput en inn ir = do + evs <- access events + let mei = find ((== en) . getL eventNumber) evs + when (isJust mei) $ execInputHandler ir inn (fromJust mei) + +execInputHandler :: InputData -> InputNumber -> EventInfo -> Evaluate () +execInputHandler ir inn ei = do + case (getInput ei inn) of + Just sf -> execInputHandler' ir sf ei + Nothing -> error "Input not found" + +getInput :: EventInfo -> InputNumber -> Maybe SomeField +getInput (EventInfo _ _ ev _ _ env) inn = find isInput (getEventFields ev env) where + isInput (SomeField (Input (Just n) _ _ _)) | n == inn = True + isInput _ = False + +-- execute the event handler using the data received from user +execInputHandler' :: InputData -> SomeField -> EventInfo -> Evaluate () +execInputHandler' (TextData s) (SomeField e@(Input _ _ _ (Text))) ei = triggerEvent' e s [ei] +execInputHandler' (TextAreaData s) (SomeField e@(Input _ _ _ (TextArea))) ei = triggerEvent' e s [ei] +execInputHandler' (ButtonData) (SomeField e@(Input _ _ _ (Button))) ei = triggerEvent' e () [ei] +execInputHandler' (RadioData i) (SomeField e@(Input _ _ _ (Radio cs))) ei = triggerEvent' e (fst $ cs!!i) [ei] +execInputHandler' (CheckboxData is) (SomeField e@(Input _ _ _ (Checkbox cs))) ei = triggerEvent' e (fst <$> cs `sel` is) [ei] +execInputHandler' _ _ _ = return () + +evProposeRule :: RuleInfo -> Evaluate Bool +evProposeRule rule = do + rs <- access rules + case find ((== (rNumber ^$ rule)) . getL rNumber) rs of + Nothing -> do + rules %= (rule:) + triggerEvent (RuleEv Proposed) rule + return True + Just _ -> return False + +--Sets the rule status to Active and execute it if possible +evActivateRule :: RuleNumber -> RuleNumber -> Evaluate Bool +evActivateRule rn by = do + rs <- access rules + case find (\r -> _rNumber r == rn && _rStatus r /= Active) rs of + Nothing -> return False + Just r -> do + let newrules = replaceWith ((== rn) . getL rNumber) r{_rStatus = Active, _rAssessedBy = Just by} rs + rules ~= newrules + --execute the rule + evalNomex (_rRule r) rn + triggerEvent (RuleEv Activated) 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) r + delVarsRule rn + delEventsRule rn + delOutputsRule rn + return True + +evAddRule :: RuleInfo -> Evaluate Bool +evAddRule rule = do + rs <- access rules + case find ((== (rNumber ^$ rule)) . getL rNumber) rs of + Nothing -> do + rules %= (rule:) + triggerEvent (RuleEv Added) rule + return True + Just _ -> return False + + +--TODO: clean and execute new rule +evModifyRule :: RuleNumber -> RuleInfo -> Evaluate Bool +evModifyRule mod rule = do + rs <- access rules + let newRules = replaceWith ((== mod) . getL rNumber) rule rs + case find ((== mod) . getL rNumber) rs of + Nothing -> return False + Just r -> do + rules ~= newRules + triggerEvent (RuleEv Modified) r + return True + +addPlayer :: PlayerInfo -> Evaluate Bool +addPlayer pi = do + pls <- access players + let exists = any (((==) `on` _playerNumber) pi) pls + unless exists $ do + players %= (pi:) + triggerEvent (Player Arrive) 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) pi + tracePN pn $ "leaving the game: " ++ _gameName g + return True + +evChangeName :: PlayerNumber -> PlayerName -> Evaluate Bool +evChangeName pn name = do + pls <- access players + case find ((== pn) . getL playerNumber) pls of + Nothing -> return False + Just pi -> do + players ~= replaceWith ((== pn) . getL playerNumber) (pi {_playerName = name}) pls + return True + +evDelEvent :: EventNumber -> Evaluate Bool +evDelEvent en = do + evs <- access events + case find ((== en) . getL eventNumber) evs of + Nothing -> return False + Just eh -> case _evStatus eh of + SActive -> do + let newEvents = replaceWith ((== en) . getL eventNumber) eh{_evStatus = SDeleted} evs + events ~= newEvents + return True + SDeleted -> return False + + +evTriggerTime :: UTCTime -> Evaluate () +evTriggerTime t = triggerEvent (Time t) t + + +--delete all variables of a rule +delVarsRule :: RuleNumber -> Evaluate () +delVarsRule rn = void $ variables %= filter ((/= rn) . getL vRuleNumber) + +--delete all events of a rule +delEventsRule :: RuleNumber -> Evaluate () +delEventsRule rn = do + evs <- access events + let toDelete = filter ((== rn) . getL ruleNumber) evs + mapM_ (evDelEvent . _eventNumber) toDelete + +--delete all outputs of a rule +delOutputsRule :: RuleNumber -> Evaluate () +delOutputsRule rn = do + os <- access outputs + let toDelete = filter ((== rn) . getL oRuleNumber) os + mapM_ (evDelOutput . _outputNumber) toDelete + +evNewOutput :: Maybe PlayerNumber -> RuleNumber -> NomexNE String -> Evaluate OutputNumber +evNewOutput pn rn s = do + ops <- access outputs + let on = getFreeNumber (map _outputNumber ops) + outputs %= (Output on rn pn s SActive : ) + return on + +evGetOutput :: OutputNumber -> Reader Game (Maybe String) +evGetOutput on = do + ops <- asks _outputs + case find (\(Output myOn _ _ _ s) -> myOn == on && s == SActive) ops of + Nothing -> return Nothing + Just (Output _ rn _ o _) -> do + out <- evalNomexNE o rn + return $ Just out + +evUpdateOutput :: OutputNumber -> NomexNE String -> Evaluate Bool +evUpdateOutput on s = do + ops <- access outputs + case find (\(Output myOn _ _ _ s) -> myOn == on && s == SActive) ops of + Nothing -> return False + Just (Output _ rn pn _ _) -> do + outputs %= replaceWith ((== on) . getL outputNumber) (Output on rn pn s SActive) + return True + +evDelOutput :: OutputNumber -> Evaluate Bool +evDelOutput on = do + ops <- access outputs + case find ((== on) . getL outputNumber) ops of + Nothing -> return False + Just o -> case _oStatus o of + SActive -> do + let newOutputs = replaceWith ((== on) . getL outputNumber) o{_oStatus = SDeleted} ops + outputs ~= newOutputs + return True + SDeleted -> return False + +logPlayer :: PlayerNumber -> String -> Evaluate () +logPlayer pn = log (Just pn) + +logAll :: String -> Evaluate () +logAll = log Nothing + +log :: Maybe PlayerNumber -> String -> Evaluate () +log mpn s = do + time <- access currentTime + void $ logs %= (Log mpn time s : ) + +--remove the ErrorT layer from the Evaluate monad stack. +runEvalError :: Maybe PlayerNumber -> Evaluate a -> State Game () +runEvalError pn egs = do + e <- runErrorT egs + case e of + Right _ -> return () + Left e -> do + tracePN (fromMaybe 0 pn) $ "Error: " ++ e + void $ runErrorT $ log pn "Error: " + +-- Put an index on every input fields +indexInputs :: Event a -> Event a +indexInputs e = fst $ indexInputs' 0 e + +indexInputs' :: Int -> Event a -> (Event a, Int) +indexInputs' n (BaseEvent (Input _ pn s ifo)) = (BaseEvent (Input (Just n) pn s ifo), n+1) +indexInputs' n (BaseEvent a) = (BaseEvent a, n) +indexInputs' n (PureEvent a) = (PureEvent a, n) +indexInputs' n EmptyEvent = (EmptyEvent, n) +indexInputs' n (SumEvent a b) = (SumEvent e1 e2, n2) where + (e1, n1) = indexInputs' n a + (e2, n2) = indexInputs' n1 b +indexInputs' n (AppEvent a b) = (AppEvent e1 e2, n2) where + (e1, n1) = indexInputs' n a + (e2, n2) = indexInputs' n1 b + +newtype BEither a b = BE (Either a b) deriving (Show, Eq, Typeable) +bLeft = BE . Left +bRight = BE . Right + +instance Alternative (BEither [a]) where + empty = bLeft [] + BE (Left a) <|> BE (Left b) = bLeft $ a ++ b + BE (Left _) <|> n = n + m <|> _ = m + +instance Applicative (BEither [a]) where + pure = BE . Right + BE (Left a) <*> BE (Left b) = BE (Left (a ++ b)) + BE (Left a) <*> _ = BE (Left a) + BE (Right f) <*> r = fmap f r + +instance Functor (BEither a) where + fmap _ (BE (Left x)) = BE (Left x) + fmap f (BE (Right y)) = BE (Right (f y)) + +-- | Show instance for Game +-- showing a game involves evaluating some parts (such as victory and outputs) +instance Show Game where + show g@(Game { _gameName, _rules, _players, _variables, _events, _victory, _currentTime}) = + "Game Name = " ++ show _gameName ++ + "\n Rules = " ++ (intercalate "\n " $ map show _rules) ++ + "\n Players = " ++ show _players ++ + "\n Variables = " ++ show _variables ++ + "\n Events = " ++ (intercalate "\n " $ map show _events) ++ + "\n Outputs = " ++ show (allOutputs g) ++ + "\n Victory = " ++ show (getVictorious g) ++ + "\n currentTime = " ++ show _currentTime ++ "\n" + + +instance Show EventInfo where + show (EventInfo en rn e _ s env) = + "event num: " ++ (show en) ++ + ", rule num: " ++ (show rn) ++ + ", event fields: " ++ (show $ getEventFields e env) ++ + ", envs: " ++ (show env) ++ + ", status: " ++ (show s) + +instance Eq SomeField where + (SomeField e1) == (SomeField e2) = e1 === e2 diff --git a/src/Nomyx/Core/Engine/Game.hs b/src/Nomyx/Core/Engine/Game.hs new file mode 100644 --- /dev/null +++ b/src/Nomyx/Core/Engine/Game.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE StandaloneDeriving #-} + +-- | This module implements game engine (for the nomyx language, see Language.Nomyx) +module Nomyx.Core.Engine.Game where + +import Prelude hiding (log) +import Language.Nomyx.Expression +import Data.Lens.Template +import Data.Time +import Data.Typeable +import Data.Data + +-- * Game + +type GameName = String + +-- | The state of the game: +data Game = Game { _gameName :: GameName, + _gameDesc :: GameDesc, + _rules :: [RuleInfo], + _players :: [PlayerInfo], + _variables :: [Var], + _events :: [EventInfo], + _outputs :: [Output], + _victory :: Maybe VictoryCond, + _logs :: [Log], + _currentTime :: UTCTime} + deriving (Typeable) + +data GameDesc = GameDesc { _desc :: String, _agora :: String} deriving (Eq, Show, Read, Ord) + +instance Eq Game where + (Game {_gameName=gn1}) == (Game {_gameName=gn2}) = gn1 == gn2 + +instance Ord Game where + compare (Game {_gameName=gn1}) (Game {_gameName=gn2}) = compare gn1 gn2 + +emptyGame name desc date = Game { + _gameName = name, + _gameDesc = desc, + _rules = [], + _players = [], + _variables = [], + _events = [], + _outputs = [], + _victory = Nothing, + _logs = [], + _currentTime = date} + + +-- * Variables + +-- | stores the variable's data +data Var = forall a . (Typeable a, Show a) => + Var { _vRuleNumber :: RuleNumber, + _vName :: String, + vData :: a} + +instance Show Var where + show (Var a b c) = "Rule number = " ++ (show a) ++ ", Name = " ++ (show b) ++ ", Value = " ++ (show c) ++ "\n" + +-- * Events + +type EventHandler e = (EventNumber, e) -> Nomex () + +data EventInfo = forall e. (Typeable e, Show e) => + EventInfo {_eventNumber :: EventNumber, + _ruleNumber :: RuleNumber, + event :: Event e, + handler :: EventHandler e, + _evStatus :: Status, + _env :: [EventEnv]} + +data EventEnv = forall e. (Typeable e, Show e) => EventEnv (Field e) e + +deriving instance Show EventEnv + +data Status = SActive | SDeleted deriving (Eq, Show) + +instance Eq EventInfo where + (EventInfo {_eventNumber=e1}) == (EventInfo {_eventNumber=e2}) = e1 == e2 + +instance Ord EventInfo where + (EventInfo {_eventNumber=e1}) <= (EventInfo {_eventNumber=e2}) = e1 <= e2 + + +-- * Outputs + +data Output = Output { _outputNumber :: OutputNumber, -- number of the output + _oRuleNumber :: RuleNumber, -- rule that triggered the output + _oPlayerNumber :: (Maybe PlayerNumber), -- player to display the output to (Nothing means display to all players) + _output :: NomexNE String, -- output string + _oStatus :: Status} -- status of the output + deriving (Show) + +-- * Logs + +data Log = Log { _lPlayerNumber :: Maybe PlayerNumber, + _lTime :: UTCTime, + _lMsg :: String} + deriving (Show) + +-- * Rules + +data SubmitRule = SubmitRule RuleName RuleDesc RuleCode deriving (Show, Read, Eq, Ord, Data, Typeable) + + +$( makeLenses [''Game, ''GameDesc, ''EventInfo, ''Var, ''Output] ) + + + diff --git a/src/Nomyx/Core/Engine/GameEvents.hs b/src/Nomyx/Core/Engine/GameEvents.hs new file mode 100644 --- /dev/null +++ b/src/Nomyx/Core/Engine/GameEvents.hs @@ -0,0 +1,188 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | This module implements the events that can affect a game. +module Nomyx.Core.Engine.GameEvents where + +import Prelude hiding (log) +import Control.Monad.State +import Data.List +import Language.Nomyx.Expression +import Nomyx.Core.Engine.Evaluation +import Nomyx.Core.Engine.Game +import Nomyx.Core.Engine.Utils +import Data.Lens +import Control.Category ((>>>)) +import Data.Lens.Template +import Control.Exception as E +import Data.Time +import Data.Maybe + +-- | 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 InputNumber InputData + | GLog (Maybe PlayerNumber) String + | TimeEvent UTCTime + | SystemAddRule SubmitRule + deriving (Show, Read, Eq, Ord) + +data TimedEvent = TimedEvent UTCTime GameEvent deriving (Show, Read, Eq, Ord) + +-- | A game being non serializable, we have to store events in parralel in order to rebuild the state latter. +data LoggedGame = LoggedGame { _game :: Game, + _gameLog :: [TimedEvent]} + deriving (Show) + +instance Eq LoggedGame where + (LoggedGame {_game=g1}) == (LoggedGame {_game=g2}) = g1 == g2 + +instance Ord LoggedGame where + compare (LoggedGame {_game=g1}) (LoggedGame {_game=g2}) = compare g1 g2 + +$( makeLens ''LoggedGame) + +-- | perform a game event +enactEvent :: GameEvent -> Maybe (RuleCode -> IO Rule) -> StateT Game IO () +enactEvent (GameSettings name desc date) _ = mapStateIO $ gameSettings name desc date +enactEvent (JoinGame pn name) _ = mapStateIO $ joinGame name pn +enactEvent (LeaveGame pn) _ = mapStateIO $ leaveGame pn +enactEvent (ProposeRuleEv pn sr) (Just inter) = void $ proposeRule sr pn inter +enactEvent (InputResult pn en inn ir) _ = mapStateIO $ inputResult pn en inn ir +enactEvent (GLog mpn s) _ = mapStateIO $ logGame s mpn +enactEvent (TimeEvent t) _ = mapStateIO $ runEvalError Nothing $ evTriggerTime t +enactEvent (SystemAddRule r) (Just inter) = systemAddRule r inter +enactEvent (ProposeRuleEv _ _) Nothing = error "ProposeRuleEv: interpreter function needed" +enactEvent (SystemAddRule _) Nothing = error "SystemAddRule: interpreter function needed" + +enactTimedEvent :: Maybe (RuleCode -> IO Rule) -> TimedEvent -> StateT Game IO () +enactTimedEvent inter (TimedEvent t ge) = flip stateCatch updateError $ do + currentTime ~= t + enactEvent ge inter + lg <- get + lift $ evaluate lg + return () + +updateError :: SomeException -> StateT Game IO () +updateError e = do + liftIO $ putStrLn $ "IO error: " ++ show e + mapStateIO $ logGame ("IO error: " ++ show e) Nothing + +execGameEvent :: GameEvent -> StateT LoggedGame IO () +execGameEvent = execGameEvent' Nothing + +execGameEvent' :: Maybe (RuleCode -> IO Rule) -> GameEvent -> StateT LoggedGame IO () +execGameEvent' inter ge = do + t <- access $ game >>> currentTime + let te = TimedEvent t ge + gameLog %= \gl -> gl ++ [te] + focus game $ enactTimedEvent inter te + +getLoggedGame :: Game -> (RuleCode -> IO Rule) -> [TimedEvent] -> IO LoggedGame +getLoggedGame g mInter tes = do + let a = mapM_ (enactTimedEvent (Just mInter)) tes + g' <- execStateT a g + return $ LoggedGame g' tes + +-- | initialize the game. +gameSettings :: GameName -> GameDesc -> UTCTime -> State Game () +gameSettings name desc date = do + gameName ~= name + gameDesc ~= desc + currentTime ~= date + return () + +-- | join the game. +joinGame :: PlayerName -> PlayerNumber -> State Game () +joinGame name pn = do + g <- get + case find ((== pn) . getL playerNumber) (_players g) of + Just _ -> return () + Nothing -> do + tracePN pn $ "Joining game: " ++ _gameName g + let player = PlayerInfo { _playerNumber = pn, _playerName = name, _playAs = Nothing} + players %= (player : ) + runEvalError (Just pn) $ triggerEvent (Player Arrive) player + + +-- | leave the game. +leaveGame :: PlayerNumber -> State Game () +leaveGame pn = runEvalError (Just pn) $ void $ evDelPlayer pn + +-- | insert a rule in pending rules. +proposeRule :: SubmitRule -> PlayerNumber -> (RuleCode -> IO Rule) -> StateT Game IO () +proposeRule sr pn inter = do + rule <- createRule sr pn inter + mapStateIO $ runEvalError (Just pn) $ do + r <- evProposeRule rule + tracePN pn $ if r then "Your rule has been added to pending rules." + else "Error: Rule could not be proposed" + +-- | add a rule forcefully (no votes etc.) +systemAddRule :: SubmitRule -> (RuleCode -> IO Rule) -> StateT Game IO () +systemAddRule sr inter = do + rule <- createRule sr 0 inter + let sysRule = (rStatus ^= Active) >>> (rAssessedBy ^= Just 0) + rules %= (sysRule rule : ) + mapStateIO $ runEvalError (Just 0) $ void $ evalNomex (_rRule rule) (_rNumber rule) + +-- | insert a log message. +logGame :: String -> Maybe PlayerNumber -> State Game () +logGame s mpn = do + time <- access currentTime + void $ logs %= (Log mpn time s : ) + +-- | the user has provided an input result +-- TODO: this is relying on the EventNumber, which may change at all time +inputResult :: PlayerNumber -> EventNumber -> InputNumber -> InputData -> State Game () +inputResult pn en inn ir = do + tracePN pn $ "input result: EventNumber " ++ show en ++ ", InputNumber " ++ show inn ++ ", choice " ++ show ir + runEvalError (Just pn) $ triggerInput en inn ir + + +-- TODO repair +getTimes :: EventInfo -> Maybe UTCTime +getTimes (EventInfo _ _ (BaseEvent (Time t)) _ SActive _) = Just t +getTimes _ = Nothing + +-- | A helper function to use the state transformer GameState. +-- It additionally sets the current time. +execWithGame :: UTCTime -> State LoggedGame () -> LoggedGame -> LoggedGame +execWithGame t gs g = execState gs $ (game >>> currentTime) `setL` t $ g + +execWithGame' :: UTCTime -> StateT LoggedGame IO () -> LoggedGame -> IO LoggedGame +execWithGame' t gs g = execStateT gs ((game >>> currentTime) `setL` t $ g) + + +activeRules :: Game -> [RuleInfo] +activeRules = sort . filter ((==Active) . getL rStatus) . _rules + +pendingRules :: Game -> [RuleInfo] +pendingRules = sort . filter ((==Pending) . getL rStatus) . _rules + +rejectedRules :: Game -> [RuleInfo] +rejectedRules = sort . filter ((==Reject) . getL rStatus) . _rules + + +createRule :: SubmitRule -> PlayerNumber -> (RuleCode -> IO Rule) -> StateT Game IO RuleInfo +createRule (SubmitRule name desc code) pn inter = do + rs <- access rules + let rn = getFreeNumber $ map _rNumber rs + rf <- lift $ inter code + tracePN pn $ "Creating rule n=" ++ show rn ++ " code=" ++ code + return RuleInfo {_rNumber = rn, + _rName = name, + _rDescription = desc, + _rProposedBy = pn, + _rRuleCode = code, + _rRule = rf, + _rStatus = Pending, + _rAssessedBy = Nothing} + +stateCatch :: Exception e => StateT Game IO a -> (e -> StateT Game IO a) -> StateT Game IO a +stateCatch m h = StateT $ \s -> runStateT m s `E.catch` \e -> runStateT (h e) s + +getEventInfo :: EventNumber -> LoggedGame -> EventInfo +getEventInfo en g = fromJust $ find ((== en) . getL eventNumber) (_events $ _game g) diff --git a/src/Nomyx/Core/Engine/Test.hs b/src/Nomyx/Core/Engine/Test.hs new file mode 100644 --- /dev/null +++ b/src/Nomyx/Core/Engine/Test.hs @@ -0,0 +1,378 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GADTs #-} + +module Nomyx.Core.Engine.Test where + +import Language.Nomyx.Expression +import Language.Nomyx.Variables +import Language.Nomyx.Rules +import Language.Nomyx.Events +import Language.Nomyx.Outputs +import Language.Nomyx.Inputs +import Language.Nomyx.Vote +import Language.Nomyx.Examples +import Language.Nomyx.Players +import Nomyx.Core.Engine.Evaluation +import Nomyx.Core.Engine.Game +import Nomyx.Core.Engine.Utils +import Control.Monad.State +import Data.Lens +import Data.Typeable +import qualified Data.Foldable as T +import Control.Applicative + +date1 = parse822Time "Tue, 02 Sep 1997 09:00:00 -0400" +date2 = parse822Time "Tue, 02 Sep 1997 10:00:00 -0400" +date3 = parse822Time "Tue, 02 Sep 1997 11:00:00 -0400" + +testGame = Game { _gameName = "test", + _gameDesc = GameDesc "test" "test", + _rules = [], + _players = [PlayerInfo 1 "coco" Nothing], + _variables = [], + _events = [], + _outputs = [], + _victory = Nothing, + _logs = [], + _currentTime = date1} + +testRule = RuleInfo { _rNumber = 0, + _rName = "test", + _rDescription = "test", + _rProposedBy = 0, + _rRuleCode = "", + _rRule = return (), + _rStatus = Pending, + _rAssessedBy = Nothing} + +execRuleEvent :: (Show e, Typeable e) => Nomex a -> Field e -> e -> Game +execRuleEvent r f d = execState (runEvalError Nothing $ evalNomex r 0 >> triggerEvent f d) testGame + +execRuleEvents :: (Show e, Typeable e) => Nomex a -> [(Field e, e)] -> Game +execRuleEvents f eds = execState (runEvalError Nothing $ evalNomex f 0 >> mapM (\(a,b) -> triggerEvent a b) eds) testGame + +execRuleInput :: Nomex a -> EventNumber -> InputNumber -> InputData -> Game +execRuleInput r en inn d = execState (runEvalError Nothing $ evalNomex r 0 >> triggerInput en inn d) testGame + +execRuleGame :: Nomex a -> Game -> Game +execRuleGame r g = execState (runEvalError Nothing $ void $ evalNomex r 0) g + +execRuleEventGame :: (Show e, Typeable e) => Nomex a -> Field e -> e -> Game -> Game +execRuleEventGame r f d g = execState (runEvalError Nothing $ evalNomex r 0 >> (triggerEvent f d)) g + +execRule :: Nomex a -> Game +execRule r = execRuleGame r testGame + +addActivateRule :: Rule -> RuleNumber -> Evaluate () +addActivateRule rf rn = do + let rule = testRule {_rName = "testRule", _rRule = rf, _rNumber = rn, _rStatus = Pending} + evAddRule rule + evActivateRule (_rNumber rule) 0 + return () + +tests = [("test var 1", testVarEx1), + ("test var 2", testVarEx2), + ("test var 3", testVarEx3), + ("test var 4", testVarEx4), + ("test var 5", testVarEx5), + ("test single input", testSingleInputEx), + ("test multiple input", testMultipleInputsEx), + ("test input string", testInputStringEx), + ("test send messsage", testSendMessageEx), + ("test send message 2", testSendMessageEx2), + ("test user input write", testUserInputWriteEx), + ("test activate rule", testActivateRuleEx), + ("test auto activate", testAutoActivateEx), + --("test meta rules vote", testApplicationMetaRuleEx), + ("test time event", testTimeEventEx), + ("test time event 2", testTimeEventEx2), + ("test delete rule", testDeleteRuleEx1), + ("test victory rule", testVictoryEx1), + ("test assess on vote complete 1", testVoteAssessOnVoteComplete1), + ("test assess on vote complete 2", testVoteAssessOnVoteComplete2), + ("test assess on every vote 1", testVoteAssessOnEveryVote1), + ("test assess on every vote 2", testVoteAssessOnEveryVote2), + ("test assess on every vote 3", testVoteAssessOnEveryVote3), + ("test assess on every vote 4", testVoteAssessOnEveryVote4), + ("test majority with", testVoteMajorityWith), + ("test number positive votes", testVoteNumberPositiveVotes), + ("test vote with quorum 1", testVoteWithQuorum1), + ("test vote with quorum 2", testVoteWithQuorum2), + ("test assess on time limit 1", testVoteAssessOnTimeLimit1), + ("test assess on time limit 2", testVoteAssessOnTimeLimit2), + ("test assess on time limit 3", testVoteAssessOnTimeLimit3), + ("test assess on time limit 4", testVoteAssessOnTimeLimit4), + ("test assess on time limit 5", testVoteAssessOnTimeLimit5), + ("test composed event sum", testSumComposeEx), + ("test composed event prod 1", testProdComposeEx1), + ("test composed event prod 2", testProdComposeEx2), + ("test two separate events", testTwoEventsEx)] + +allTests = all snd tests + +--Test variable creation +testVar1 :: Rule +testVar1 = do + NewVar "toto" (1::Integer) + return () + +testVarEx1 = True --(variables ^$ execRuleFunc testVar1) == [(Var 0 "toto" (1::Integer))] + +--Test variable deleting +testVar2 :: Rule +testVar2 = do + var <- newVar_ "toto" (1::Int) + delVar var + return () + +testVarEx2 = True --_variables (execRuleFunc testVar2) == [] + +--Test variable reading +testVar3 :: Rule +testVar3 = do + var <- newVar_ "toto" (1::Int) + a <- liftEffect $ readVar var + case a of + Just (1::Int) -> void $ newOutput (Just 1) (return "ok") + _ -> void $ newOutput (Just 1) (return "nok") + +testVarEx3 = isOutput "ok" (execRule testVar3) + +--Test variable writing +testVar4 :: Rule +testVar4 = do + var <- newVar_ "toto" (1::Int) + writeVar var (2::Int) + a <- liftEffect $ readVar var + case a of + Just (2::Int) -> void $ newOutput (Just 1) (return "ok") + _ -> void $ newOutput (Just 1) (return "nok") + +testVarEx4 = isOutput "ok" (execRule testVar4) + +--Test variable writing +testVar5 :: Rule +testVar5 = do + var <- newVar_ "toto" ([]::[Int]) + writeVar var ([1]::[Int]) + a <- liftEffect $ readVar var + case a of + Just (a::[Int]) -> void $ writeVar var (2:a) + Nothing -> void $ newOutput (Just 1) (return "nok") + +testVarEx5 = True --_variables (execRuleFunc testVar5) == [(Var 0 "toto" ([2,1]::[Int]))] + +data Choice = Holland | Sarkozy deriving (Enum, Typeable, Show, Eq, Bounded) + +-- Test input +testSingleInput :: Rule +testSingleInput = void $ onInputRadio_ "Vote for Holland or Sarkozy" [Holland, Sarkozy] h 1 where + h a = void $ newOutput (Just 1) (return $ "voted for " ++ show a) + +testSingleInputEx = isOutput "voted for Holland" g where + g = execRuleEvent testSingleInput (Input (Just 0) 1 "Vote for Holland or Sarkozy" (Radio [(Holland, "Holland"), (Sarkozy, "Sarkozy")])) Holland + +testMultipleInputs :: Rule +testMultipleInputs = void $ onInputCheckbox_ "Vote for Holland and Sarkozy" [(Holland, "Holland"), (Sarkozy, "Sarkozy")] h 1 where + h a = void $ newOutput (Just 1) (return $ "voted for " ++ show a) + +testMultipleInputsEx = isOutput "voted for [Holland,Sarkozy]" g where + g = execRuleEvent testMultipleInputs (Input (Just 0) 1 "Vote for Holland and Sarkozy" (Checkbox [(Holland, "Holland"), (Sarkozy, "Sarkozy")])) [Holland, Sarkozy] + +testInputString :: Rule +testInputString = void $ onInputText_ "Enter a number:" h 1 where + h a = void $ newOutput (Just 1) (return $ "You entered: " ++ a) + +testInputStringEx = isOutput "You entered: 1" g where + g = execRuleEvent testInputString (Input (Just 0) 1 "Enter a number:" Text) "1" + +-- Test message +testSendMessage :: Rule +testSendMessage = do + let msg = Msg "msg" :: Msg String + onEvent_ (messageEvent msg) f + sendMessage msg "toto" where + f (a :: String) = void $ newOutput (Just 1) (return a) + +testSendMessageEx = isOutput "toto" (execRule testSendMessage) + +testSendMessage2 :: Rule +testSendMessage2 = do + onEvent_ (messageEvent (Msg "msg" :: Msg ())) $ const $ void $ newOutput (Just 1) (return "Received") + sendMessage_ "msg" + + +testSendMessageEx2 = isOutput "Received" (execRule testSendMessage2) + +data Choice2 = Me | You deriving (Enum, Typeable, Show, Eq, Bounded) + +-- Test user input + variable read/write +testUserInputWrite :: Rule +testUserInputWrite = do + newVar_ "vote" (Nothing::Maybe Choice2) + onEvent_ (messageEvent (Msg "voted" :: Msg ())) h2 + void $ onEvent_ (BaseEvent $ Input Nothing 1 "Vote for" (Radio [(Me, "Me"), (You, "You")])) h1 where + h1 a = do + writeVar (V "vote") (Just a) + SendMessage (Msg "voted") () + h2 _ = do + a <- liftEffect $ readVar (V "vote") + void $ case a of + Just (Just Me) -> newOutput (Just 1) (return "voted Me") + _ -> newOutput (Just 1) (return "problem") + + +testUserInputWriteEx = isOutput "voted Me" g where + g = execRuleEvent testUserInputWrite (Input (Just 0) 1 "Vote for" (Radio [(Me, "Me"), (You, "You")])) Me + +-- Test rule activation +testActivateRule :: Rule +testActivateRule = do + a <- liftEffect GetRules + when (_rStatus (head a) == Pending) $ void $ ActivateRule $ _rNumber (head a) + + +testActivateRuleEx = _rStatus (head $ _rules (execRuleGame testActivateRule testGame {_rules=[testRule]})) == Active + +testAutoActivateEx = _rStatus (head $ _rules (execRuleEventGame autoActivate (RuleEv Proposed) testRule (testGame {_rules=[testRule]}))) == Active + +--Time tests + +testTimeEvent :: Rule +testTimeEvent = void $ onEvent_ (timeEvent date1) f where + f _ = outputAll_ $ show date1 + +testTimeEventEx = isOutput (show date1) g where + g = execRuleEvent testTimeEvent (Time date1) date1 + +testTimeEvent2 :: Nomex () +testTimeEvent2 = schedule' [date1, date2] (outputAll_ . show) + +testTimeEventEx2 = isOutput (show date1) g && isOutput (show date2) g where + g = execState (runEvalError Nothing $ evalNomex testTimeEvent2 0 >> void gameEvs) testGame + gameEvs = do + evTriggerTime date1 + evTriggerTime date2 + +-- Test deletes +testDeleteRule :: Rule +testDeleteRule = do + newVar_ "toto" (1::Int) + onMessage (Msg "msg" :: Msg ()) (const $ return ()) + void $ newOutput (Just 1) (return "toto") + +testDeleteGame :: Game +testDeleteGame = flip execState testGame {_players = []} $ runEvalError Nothing $ do + addActivateRule testDeleteRule 1 + addActivateRule (void $ suppressRule 1) 2 + +testDeleteRuleEx1 = (_rStatus $ head $ drop 1 $ _rules testDeleteGame) == Reject && + --(_variables testDeleteGame == []) && + (_oStatus $ head $ _outputs testDeleteGame) == SDeleted && + (_evStatus $ head $ _events testDeleteGame) == SDeleted + +-- Test victory +testVictoryGame :: Game +testVictoryGame = flip execState testGame $ runEvalError Nothing $ do + addActivateRule (victoryXRules 1) 1 + addActivateRule (nothing) 2 + +testVictoryEx1 = (length $ getVictorious testVictoryGame) == 1 + +-- Test votes + +voteGameActions :: Int -> Int -> Int -> Bool -> Evaluate () -> Game +voteGameActions positives negatives total timeEvent actions = flip execState testGame {_players = []} $ runEvalError Nothing $ do + mapM_ (\x -> addPlayer (PlayerInfo x ("coco " ++ show x) Nothing)) [1..total] + actions + evProposeRule testRule + evs <- lift getChoiceEvents + let pos = take positives evs + let neg = take negatives $ drop positives evs + mapM_ (\x -> triggerInput x 0 (RadioData $ fromEnum For)) pos + mapM_ (\x -> triggerInput x 0 (RadioData $ fromEnum Against)) neg + when timeEvent $ evTriggerTime date2 + +voteGame' :: Int -> Int -> Int -> Bool -> Rule -> Game +voteGame' positives negatives notVoted timeEvent rf = voteGameActions positives negatives notVoted timeEvent $ addActivateRule rf 1 + +voteGame :: Int -> Int -> Int -> Rule -> Game +voteGame positives negatives notVoted = voteGame' positives negatives notVoted False + +voteGameTimed :: Int -> Int -> Int -> Rule -> Game +voteGameTimed positives negatives notVoted = voteGame' positives negatives notVoted True + +-- 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 + +-- Event composition + +testSumCompose :: Rule +testSumCompose = void $ onEvent_ (True <$ inputButton 1 "" <|> False <$ inputButton 1 "") f where + f a = outputAll_ $ show a + +testSumComposeEx = isOutput "True" g where + g = execRuleEvent testSumCompose (Input (Just 0) 1 "" Button) () + +testProdCompose :: Rule +testProdCompose = void $ onEvent_ ((,) <$> inputText 1 "" <*> inputText 1 "") f where + f a = outputAll_ $ show a + +testProdComposeEx1 = null $ allOutputs g where + g = execRuleEvent testProdCompose (Input (Just 0) 1 "" Text) "toto" + +testProdComposeEx2 = isOutput "(\"toto\",\"tata\")" g where + g = execRuleEvents testProdCompose [((Input (Just 0) 1 "" Text), "toto"), ((Input (Just 1) 1 "" Text), "tata")] + +testTwoEvents :: Rule +testTwoEvents = do + void $ onEvent_ (inputText 1 "") f + void $ onEvent_ (inputText 1 "") f where + f a = outputAll_ $ show a + +testTwoEventsEx = (length $ allOutputs g) == 1 where + g = execRuleInput testTwoEvents 1 0 (TextData "toto") + + +--Get all event numbers of type choice (radio button) +getChoiceEvents :: State Game [EventNumber] +getChoiceEvents = do + evs <- access events + return $ map _eventNumber $ filter choiceEvent evs + where choiceEvent (EventInfo _ _ (BaseEvent (Input _ _ _ (Radio _))) _ _ _) = True + choiceEvent _ = False + +--Get all event numbers of type text (text field) +getTextEvents :: State Game [EventNumber] +getTextEvents = do + evs <- access events + return $ map _eventNumber $ filter choiceEvent evs + where choiceEvent (EventInfo _ _ (BaseEvent (Input _ _ _ Text)) _ _ _) = True + choiceEvent _ = False + +isOutput :: String -> Game -> Bool +isOutput s g = s `elem` allOutputs g + + +myEvent :: NomexNE (Event String) +myEvent = do + ps <- getAllPlayerNumbers + let oneButton pn = inputText pn "test" + return $ T.asum (map oneButton ps) diff --git a/src/Nomyx/Core/Engine/Utils.hs b/src/Nomyx/Core/Engine/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Nomyx/Core/Engine/Utils.hs @@ -0,0 +1,51 @@ + +module Nomyx.Core.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/Nomyx/Core/Interpret.hs b/src/Nomyx/Core/Interpret.hs --- a/src/Nomyx/Core/Interpret.hs +++ b/src/Nomyx/Core/Interpret.hs @@ -4,38 +4,19 @@ -- | This module starts a Interpreter server that will read our strings representing rules to convert them to plain Rules. module Nomyx.Core.Interpret where -import Language.Haskell.Interpreter -import Language.Haskell.Interpreter.Server -import Language.Nomyx import System.Directory (createDirectoryIfMissing, copyFile, removeFile, doesFileExist) import System.FilePath ((), joinPath, dropExtension, takeFileName) -import Control.Exception as CE +import System.IO.Error import Data.Either.Unwrap -import Nomyx.Core.Utils import Data.List +import Control.Exception as CE import Control.Monad +import Language.Haskell.Interpreter import Language.Haskell.Interpreter.Unsafe (unsafeSetGhcOption) -import qualified Mueval.Resources as MR (limitResources) -import qualified Mueval.Context as MC -import qualified Mueval.Interpreter as MI -import System.IO.Error - - - -unQualImports :: [String] -unQualImports = "Language.Nomyx" : - "Language.Nomyx.Examples" : - "Safe" : - "Data.Typeable" : - "Data.Lens" : - MC.defaultModules - -qualImports :: [(String, Maybe String)] -qualImports = ("Control.Category", Just "C") : MC.qualifiedModules - -defaultPackages :: [String] -defaultPackages = "Nomyx-Language" : MC.defaultPackages - +import Language.Haskell.Interpreter.Server +import Language.Nomyx +import Nomyx.Core.Context +import Nomyx.Core.Utils exts :: [String] exts = ["Safe", "GADTs"] ++ map show namedExts @@ -64,40 +45,22 @@ getUploadModules saveDir = do files <- getUploadedModules saveDir `catch` (\(_::SomeException) -> return []) return $ map (\f -> joinPath [saveDir, uploadDir, f]) files - -- | initializes the interpreter by loading some modules. initializeInterpreter :: FilePath -> Interpreter () initializeInterpreter saveDir = do reset -- Make sure nothing is available set [installedModulesInScope := False, - languageExtensions := map MI.readExt exts] + languageExtensions := map readExt exts] unsafeSetGhcOption "-fpackage-trust" forM_ (defaultPackages >>= words) $ \pkg -> unsafeSetGhcOption ("-trust " ++ pkg) uploadedMods <- liftIO $ getUploadModules saveDir liftIO $ putStrLn $ "Loading modules: " ++ (intercalate ", " uploadedMods) loadModules uploadedMods setTopLevelModules $ map (dropExtension . takeFileName) uploadedMods - liftIO $ MR.limitResources False let importMods = qualImports ++ zip (unQualImports) (repeat Nothing) setImportsQ importMods ---initializeInterpreter :: FilePath -> Interpreter () ---initializeInterpreter saveDir = do --- uploadedMods <- liftIO $ getUploadModules saveDir --- liftIO $ putStrLn $ "Loading modules: " ++ (concat $ intersperse ", " uploadedMods) --- let o = Options { extensions = True, --- namedExtensions = exts, --- typeOnly = True, --- rLimits = True, --- loadFile = "", --- packageTrust = True, --- modules = Just unQualImports} --- MI.initializeInterpreter o --- uploadedMods <- liftIO $ getUploadModules saveDir --- liftIO $ putStrLn $ "Loading modules: " ++ (concat $ intersperse ", " uploadedMods) --- loadModules uploadedMods - ---- | reads maybe a Rule out of a string. interpretRule :: String -> ServerHandle -> IO (Either InterpreterError Rule) interpretRule s sh = (liftIO $ runIn sh $ interpret s (as :: Rule)) @@ -130,9 +93,13 @@ when (isLeft final) $ putStrLn "Error: reinitialize interpreter failed" return $ Just e - showInterpreterError :: InterpreterError -> String showInterpreterError (UnknownError s) = "Unknown Error\n" ++ s showInterpreterError (WontCompile ers) = "Won't Compile\n" ++ concatMap (\(GhcError errMsg) -> errMsg ++ "\n") ers showInterpreterError (NotAllowed s) = "Not Allowed (Probable cause: bad module or file name)\n" ++ s showInterpreterError (GhcException s) = "Ghc Exception\n" ++ s + +readExt :: String -> Extension +readExt s = case reads s of + [(e,[])] -> e + _ -> UnknownExtension s diff --git a/src/Nomyx/Core/Mail.hs b/src/Nomyx/Core/Mail.hs --- a/src/Nomyx/Core/Mail.hs +++ b/src/Nomyx/Core/Mail.hs @@ -5,28 +5,27 @@ module Nomyx.Core.Mail where +import Prelude hiding (div, (.)) +import Language.Haskell.HsColour.Colourise hiding (string) +import qualified Language.Haskell.HsColour.HTML as HSC import Text.Blaze.Html5 hiding (map, label, br) import qualified Text.Blaze.Html5 as H import Text.Blaze.Html.Renderer.String import Network.Mail.Mime hiding (mailTo) -import Prelude hiding (div, (.)) -import Control.Monad -import Language.Nomyx -import Language.Nomyx.Engine +import Safe +import Data.List import Data.Text(Text, pack) -import Control.Concurrent import Data.Maybe import qualified Data.Text.Lazy as B -import qualified Language.Haskell.HsColour.HTML as HSC -import Language.Haskell.HsColour.Colourise hiding (string) -import Text.Blaze.Internal +import Control.Concurrent import Control.Category import Control.Applicative ((<$>)) -import Safe -import Data.List +import Control.Monad +import Language.Nomyx import Nomyx.Core.Profile import Nomyx.Core.Types import Nomyx.Core.Utils +import Nomyx.Core.Engine default (Integer, Double, Data.Text.Text) @@ -50,7 +49,7 @@ (toHtml $ "a new rule has been proposed by player " ++ prop ++ ".") >> H.br (toHtml $ "Name: " ++ name) >> H.br (toHtml $ "Description: " ++ desc) >> H.br - (toHtml $ "Code: ") >> H.br >> (preEscapedString $ HSC.hscolour defaultColourPrefs False code) >> H.br >> H.br + (toHtml $ "Code: ") >> H.br >> (preEscapedToHtml $ HSC.hscolour defaultColourPrefs False code) >> H.br >> H.br (toHtml $ "Please login into Nomyx for actions on this rule:") >> H.br (toHtml $ nomyxURL net ++ "/Nomyx") >> H.br >> H.br (toHtml $ "You received this mail because you subscribed to Nomyx. To stop receiving mails, login to Nomyx with the above address, go to Settings and uncheck the corresponding box.") >> H.br diff --git a/src/Nomyx/Core/Multi.hs b/src/Nomyx/Core/Multi.hs --- a/src/Nomyx/Core/Multi.hs +++ b/src/Nomyx/Core/Multi.hs @@ -3,22 +3,21 @@ -- | This module manages multi-player games. module Nomyx.Core.Multi where -import Prelude -import Control.Monad.State -import Data.Time as T import Language.Haskell.Interpreter.Server (ServerHandle) import Data.Maybe -import Control.Exception import Data.Lens -import Language.Nomyx.Engine as G -import Control.Category hiding ((.)) -import Nomyx.Core.Quotes (cr) -import Control.Applicative import Data.List +import Data.Time as T +import Control.Exception +import Control.Monad.State +import Control.Applicative +import Control.Category hiding ((.)) import Language.Nomyx +import Nomyx.Core.Engine as G import Nomyx.Core.Utils import Nomyx.Core.Types import Nomyx.Core.Interpret +import Nomyx.Core.Quotes (cr) triggerTimeEvent :: UTCTime -> StateT Multi IO () triggerTimeEvent t = do diff --git a/src/Nomyx/Core/Profile.hs b/src/Nomyx/Core/Profile.hs --- a/src/Nomyx/Core/Profile.hs +++ b/src/Nomyx/Core/Profile.hs @@ -7,18 +7,19 @@ module Nomyx.Core.Profile where import Language.Nomyx -import Language.Nomyx.Engine -import Data.IxSet (toList, (@=)) -import qualified Data.IxSet as IxSet + + import Control.Monad.Reader.Class (MonadReader(..)) import Control.Monad.Catch (bracket) import Control.Concurrent.STM +import Control.Monad +import Control.Monad.State import Safe import Data.Lens import Data.List import Data.Maybe -import Control.Monad -import Control.Monad.State +import Data.IxSet (toList, (@=)) +import qualified Data.IxSet as IxSet import qualified Data.Acid.Advanced as A (update', query') import Data.Acid.Local (createCheckpointAndClose) import Data.Acid (openLocalStateFrom, makeAcidic, Update, Query) @@ -28,6 +29,7 @@ import Nomyx.Core.Quotes import Nomyx.Core.Types import Nomyx.Core.Utils +import Nomyx.Core.Engine -- | set 'ProfileData' for UserId setProfileData :: ProfileData -> Update ProfileDataState ProfileData @@ -72,7 +74,7 @@ let pd = initialProfileData uid ps put $ pds { profilesData = IxSet.updateIx uid pd profilesData } return pd - (Just profileData) -> return profileData + Just profileData -> return profileData -- | get number of askProfileDataNumber :: Query ProfileDataState Int diff --git a/src/Nomyx/Core/Quotes.hs b/src/Nomyx/Core/Quotes.hs --- a/src/Nomyx/Core/Quotes.hs +++ b/src/Nomyx/Core/Quotes.hs @@ -19,7 +19,7 @@ import Language.Haskell.TH as TH import Language.Haskell.TH.Quote import Language.Haskell.Interpreter hiding (get) -import Nomyx.Core.Interpret +import Nomyx.Core.Context -- This quasi quoter allows to type check a string as a Nomyx rule (a RuleFunc). diff --git a/src/Nomyx/Core/Serialize.hs b/src/Nomyx/Core/Serialize.hs --- a/src/Nomyx/Core/Serialize.hs +++ b/src/Nomyx/Core/Serialize.hs @@ -4,21 +4,21 @@ module Nomyx.Core.Serialize where import Prelude hiding (log, (.)) -import Language.Nomyx hiding (getCurrentTime) -import Language.Nomyx.Engine -import Language.Nomyx.Engine.GameEvents -import Control.Monad.State -import Data.Lens import Language.Haskell.Interpreter.Server +import Data.Lens import Data.Aeson.TH import Data.Aeson -import Control.Applicative -import Control.Category import Data.Time.Clock.POSIX import qualified Data.ByteString.Lazy.Char8 as BL +import Control.Monad.State +import Control.Applicative +import Control.Category +import Language.Nomyx hiding (getCurrentTime) import Nomyx.Core.Types import Nomyx.Core.Utils import Nomyx.Core.Interpret +import Nomyx.Core.Engine +import Nomyx.Core.Engine.GameEvents save :: Multi -> IO () save m = BL.writeFile (getSaveFile $ _mSettings m) (encode m) @@ -79,7 +79,7 @@ $(deriveJSON defaultOptions ''GameInfo) $(deriveJSON defaultOptions ''TimedEvent) $(deriveJSON defaultOptions ''GameEvent) -$(deriveJSON defaultOptions ''UInputData) +$(deriveJSON defaultOptions ''InputData) $(deriveJSON defaultOptions ''SubmitRule) $(deriveJSON defaultOptions ''GameDesc) diff --git a/src/Nomyx/Core/Session.hs b/src/Nomyx/Core/Session.hs --- a/src/Nomyx/Core/Session.hs +++ b/src/Nomyx/Core/Session.hs @@ -4,25 +4,25 @@ -- | This module manages multi-player commands. module Nomyx.Core.Session where -import Prelude -import Data.List -import Control.Monad.State -import Data.Time as T import Language.Haskell.Interpreter.Server (ServerHandle) import Language.Haskell.Interpreter (InterpreterError) -import Nomyx.Core.Types import Debug.Trace.Helpers import Data.Lens -import Language.Nomyx -import Language.Nomyx.Engine as G -import Control.Category hiding ((.)) +import Data.Time as T +import Data.List import qualified Data.Acid.Advanced as A (update', query') +import Control.Category hiding ((.)) +import Control.Monad.State import Control.Concurrent.STM import System.IO.PlafCompat +import Language.Nomyx +import Nomyx.Core.Types import Nomyx.Core.Utils import Nomyx.Core.Multi import Nomyx.Core.Profile import Nomyx.Core.Interpret +import Nomyx.Core.Serialize +import Nomyx.Core.Engine as G -- | add a new player newPlayer :: PlayerNumber -> PlayerSettings -> StateT Session IO () @@ -119,8 +119,8 @@ tracePN pn ("Error in submitted rule: " ++ errorMsg) modifyProfile pn (pLastRule ^= Just (sr, errorMsg)) -inputResult :: PlayerNumber -> EventNumber -> UInputData -> GameName -> StateT Session IO () -inputResult pn en ir gn = inGameDo gn $ execGameEvent $ InputResult pn en ir +inputResult :: PlayerNumber -> EventNumber -> InputNumber -> InputData -> GameName -> StateT Session IO () +inputResult pn en inn ir gn = inGameDo gn $ execGameEvent $ InputResult pn en inn ir -- | upload a rule file, given a player number, the full path of the file, the file name and the server handle inputUpload :: PlayerNumber -> FilePath -> FilePath -> ServerHandle -> StateT Session IO Bool @@ -220,7 +220,9 @@ s <- atomically $ readTVar ts ms <- evalWithWatchdog s (evalSession sm) case ms of - Just s -> atomically $ writeTVar ts s + Just s -> do + atomically $ writeTVar ts s + save $ _multi s Nothing -> putStrLn "thread timed out, updateSession discarded" diff --git a/src/Nomyx/Core/Test.hs b/src/Nomyx/Core/Test.hs --- a/src/Nomyx/Core/Test.hs +++ b/src/Nomyx/Core/Test.hs @@ -18,13 +18,12 @@ -- | Test module module Nomyx.Core.Test where -import Prelude -import Control.Monad.State import Language.Haskell.Interpreter.Server (ServerHandle) import Language.Nomyx hiding (getCurrentTime) -import Language.Nomyx.Engine import Control.Applicative +import Control.Monad.State import Control.Exception as E +import Control.Arrow ((>>>)) import Language.Haskell.TH import Language.Haskell.TH.Syntax as THS hiding (lift) import System.IO.Unsafe @@ -32,13 +31,11 @@ import Data.List import Data.Maybe import Data.Acid.Memory +import Data.Time hiding (getCurrentTime) import Happstack.Auth.Core.Auth (initialAuthState) import Happstack.Auth.Core.Profile (initialProfileState) -import qualified Language.Nomyx.Engine as G -import Control.Arrow ((>>>)) -import Data.Time hiding (getCurrentTime) -import System.IO.Temp import Paths_Nomyx_Core as PNC +import System.IO.Temp import System.FilePath (()) import System.Directory (createDirectoryIfMissing) import Nomyx.Core.Types @@ -47,6 +44,8 @@ import Nomyx.Core.Utils import Nomyx.Core.Profile import Nomyx.Core.Quotes +import Nomyx.Core.Engine +import qualified Nomyx.Core.Engine as G playTests :: FilePath -> ServerHandle -> Maybe String -> IO [(String, Bool)] playTests saveDir sh mTestName = do @@ -195,7 +194,7 @@ partialFunction2 :: String partialFunction2 = [cr|void $ do t <- liftEffect getCurrentTime - onEventOnce (Time $ addUTCTime 5 t) $ const $ readMsgVar_ (msgVar "toto2")|] + onEventOnce (timeEvent $ addUTCTime 5 t) $ const $ readMsgVar_ (msgVar "toto2")|] gamePartialFunction1 :: StateT Session IO () gamePartialFunction1 = submitR partialFunction1 @@ -216,7 +215,7 @@ partialFunction3 :: String -partialFunction3 = [cr|void $ onEvent_ (RuleEv Proposed) $ const $ readMsgVar_ (msgVar "toto3")|] +partialFunction3 = [cr|void $ onEvent_ (ruleEvent Proposed) $ const $ readMsgVar_ (msgVar "toto3")|] gamePartialFunction3 :: StateT Session IO () gamePartialFunction3 = do @@ -317,14 +316,14 @@ inputAllRadios choice pn = do s <- get let evs = evalState getChoiceEvents (firstGame $ _multi s) - mapM_ (\en -> inputResult pn en (URadioData choice) "test") evs + mapM_ (\en -> inputResult pn en 0 (RadioData choice) "test") evs -- input text for all text fields inputAllTexts :: String -> PlayerNumber -> StateT Session IO () inputAllTexts a pn = do s <- get let evs = evalState getTextEvents (firstGame $ _multi s) - mapM_ (\en -> inputResult pn en (UTextData a) "test") evs + mapM_ (\en -> inputResult pn en 0 (TextData a) "test") evs firstGame :: Multi -> Game firstGame = G._game . _loggedGame . head . _gameInfos diff --git a/src/Nomyx/Core/Types.hs b/src/Nomyx/Core/Types.hs --- a/src/Nomyx/Core/Types.hs +++ b/src/Nomyx/Core/Types.hs @@ -2,18 +2,19 @@ {-# LANGUAGE DeriveDataTypeable #-} module Nomyx.Core.Types where -import Language.Nomyx -import Language.Nomyx.Engine -import Data.Typeable + import Network.BSD -import Data.Lens.Template import Language.Haskell.Interpreter.Server (ServerHandle) -import Data.Acid (AcidState) import Happstack.Auth (ProfileState, AuthState) +import Data.Typeable +import Data.Lens.Template +import Data.Acid (AcidState) import Data.Data (Data) import Data.IxSet (inferIxSet, noCalcs) import Data.SafeCopy (base, deriveSafeCopy) import Data.Time +import Language.Nomyx +import Nomyx.Core.Engine type PlayerPassword = String type Port = Int diff --git a/src/Nomyx/Core/Utils.hs b/src/Nomyx/Core/Utils.hs --- a/src/Nomyx/Core/Utils.hs +++ b/src/Nomyx/Core/Utils.hs @@ -16,24 +16,27 @@ module Nomyx.Core.Utils where -import Data.Maybe -import Control.Monad.State -import Nomyx.Core.Types -import System.IO.Temp + + import Codec.Archive.Tar as Tar +import System.IO.Temp import System.Directory import System.FilePath -import Control.Monad.Catch as MC #ifndef WINDOWS import qualified System.Posix.Signals as S #endif -import Control.Concurrent import System.IO import System.IO.PlafCompat import Data.Lens +import Data.Maybe +import Control.Monad.State import Control.Exception +import Control.Concurrent import Control.Category ((>>>)) -import Language.Nomyx.Engine +import Control.Monad.Catch as MC +import Control.DeepSeq +import Nomyx.Core.Types +import Nomyx.Core.Engine saveFile, profilesDir, uploadDir, tarFile :: FilePath saveFile = "Nomyx.save" @@ -82,9 +85,21 @@ getRegularFiles :: FilePath -> [FilePath] -> IO [FilePath] getRegularFiles dir fps = filterM (getFileStatus . (\f -> dir f) >=> return . isRegularFile) fps +-- The setMode function is only used during module loading. In Windows, +-- a copied file automatically inherits permissions based on the containing +-- folder's ACLs an the user account being used. +#ifdef WINDOWS + setMode :: FilePath -> IO() +setMode _ = return () + +#else + +setMode :: FilePath -> IO() setMode file = setFileMode file (ownerModes + groupModes) +#endif + #ifdef WINDOWS --no signals under windows @@ -133,6 +148,20 @@ --start watchdog thread forkIO $ watchDog 3 id mvar takeMVar mvar + +evalWithWatchdog' :: NFData a => IO a -> IO (Maybe a) +evalWithWatchdog' s = do + mvar <- newEmptyMVar + hSetBuffering stdout NoBuffering + --start evaluation thread + id <- forkOS $ do + s' <- s + let s'' = force s' + putMVar mvar (Just s'') + --start watchdog thread + forkIO $ watchDog 3 id mvar + takeMVar mvar + -- | Fork off a thread which will sleep and then kill off the specified thread. watchDog :: Int -> ThreadId -> MVar (Maybe a) -> IO ()