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.7.1 +version: 0.7.2 cabal-version: >=1.6 build-type: Simple license: BSD3 @@ -15,7 +15,7 @@ data-dir: data library - build-depends: Nomyx-Language == 0.7.1, + build-depends: Nomyx-Language == 0.7.2, DebugTraceHelpers == 0.12.*, MissingH == 1.2.*, acid-state == 0.12.*, @@ -41,6 +41,7 @@ deepseq == 1.3.*, network == 2.4.*, old-locale == 1.0.*, + random == 1.0.*, safe == 0.3.*, safecopy == 0.8.*, stm == 2.4.*, diff --git a/src/Nomyx/Core/Context.hs b/src/Nomyx/Core/Context.hs --- a/src/Nomyx/Core/Context.hs +++ b/src/Nomyx/Core/Context.hs @@ -42,6 +42,7 @@ "Data.Monoid", "Data.Ord", "Data.Ratio", + "Data.Semigroup", "Data.Tree", "Data.Tuple", "Data.Typeable", @@ -53,7 +54,8 @@ "array", "base", "bytestring", - "containers"] + "containers", + "text"] qualImports :: [(String, Maybe String)] qualImports = [("Control.Category", Just "C"), @@ -67,4 +69,5 @@ ("Data.Map", Just "M"), ("Data.Sequence", Just "Data.Sequence"), ("Data.Set", Just "S"), - ("Data.Traversable", Just "Data.Traversable") ] + ("Data.Text", Just "T"), + ("Data.Traversable", Just "Data.Traversable")] diff --git a/src/Nomyx/Core/Engine/EvalUtils.hs b/src/Nomyx/Core/Engine/EvalUtils.hs --- a/src/Nomyx/Core/Engine/EvalUtils.hs +++ b/src/Nomyx/Core/Engine/EvalUtils.hs @@ -16,22 +16,24 @@ import Data.Typeable import Data.Lens import Data.Maybe +import Data.List import Control.Applicative import Control.Monad.Error import Language.Nomyx.Expression import Nomyx.Core.Engine.Types import Nomyx.Core.Engine.Utils +import Safe -- find a field result in an environment --- TODO simplify? lookupField :: Typeable a => Field a -> FieldAddress -> [FieldResult] -> Maybe a -lookupField _ _ [] = Nothing -lookupField fi fa ((FieldResult a r fa1) : ers) = case (cast (a,r)) of - Just (a',r') -> if (a' == fi && maybe True (== fa) fa1) - then Just r' - else lookupField fi fa ers - Nothing -> lookupField fi fa ers +lookupField fi fa frs = headMay $ mapMaybe (maybeField fi fa) frs +--return the field result if it matches with the input field and address +maybeField :: Typeable a => Field a -> FieldAddress -> FieldResult -> Maybe a +maybeField fi fa (FieldResult fi' res fa') = do + ((fi'', res') :: (Field a, a)) <- cast (fi', res) + if (fi'' == fi) && maybe True (== fa) fa' then (Just res') else Nothing + errorHandler :: EventNumber -> String -> Evaluate () errorHandler en s = do rn <- access eRuleNumber @@ -80,11 +82,32 @@ focusGame :: State Game a -> Evaluate a focusGame = lift . (focus eGame) -accessGame :: Lens Game a -> Evaluate (a, PlayerNumber) +accessGame :: Lens Game a -> Evaluate (a, RuleNumber) accessGame l = do a <- access (eGame >>> l) - pn <- access eRuleNumber - return (a, pn) + rn <- access eRuleNumber + return (a, rn) + +putGame :: Lens Game a -> a -> Evaluate () +putGame l a = do + ruleActive <- evalRuleActive + when ruleActive $ void $ (eGame >>> l) ~= a + +modifyGame :: Lens Game a -> (a -> a) -> Evaluate () +modifyGame l f = do + ruleActive <- evalRuleActive + when ruleActive $ void $ (eGame >>> l) %= f + +evalRuleActive :: Evaluate Bool +evalRuleActive = do + rn <- access eRuleNumber + rs <- access (eGame >>> rules) + return $ if rn == 0 + then True + else case find (\r -> _rNumber r == rn) rs of + Just r -> _rStatus r == Active + Nothing -> True --TODO why should there be an evaluating rule not in the list? + --replace temporarily the rule number used for evaluation withRN :: RuleNumber -> Evaluate a -> Evaluate a diff --git a/src/Nomyx/Core/Engine/Evaluation.hs b/src/Nomyx/Core/Engine/Evaluation.hs --- a/src/Nomyx/Core/Engine/Evaluation.hs +++ b/src/Nomyx/Core/Engine/Evaluation.hs @@ -20,6 +20,7 @@ import Data.Maybe import Data.Todo import Data.Either +import Data.Function (on) import Control.Category hiding (id) import Control.Applicative import Control.Monad.Error.Class (MonadError(..)) @@ -28,7 +29,9 @@ import Nomyx.Core.Engine.EvalUtils import Nomyx.Core.Engine.Utils import Safe +import System.Random + -- * Evaluation -- | evaluate an effecful expression. @@ -56,6 +59,7 @@ evalNomex (CatchError n h) = catchError (evalNomex n) (\a -> evalNomex (h a)) evalNomex (Return a) = return a evalNomex (Bind exp f) = evalNomex exp >>= \e -> evalNomex (f e) +evalNomex (GetRandomNumber r) = evGetRandomNumber r -- | evaluate an effectless expression. evalNomexNE :: NomexNE a -> EvaluateNE a @@ -70,6 +74,8 @@ evalNomexNE (Bind exp f) = evalNomexNE exp >>= \e -> evalNomexNE (f e) evalNomexNE (Simu sim ev) = evSimu sim ev + + --TODO should we also give a rule number to simulate the Nomex with? -- currently we use the simulating rule number evSimu :: Nomex a -> NomexNE Bool -> EvaluateNE Bool @@ -85,7 +91,7 @@ (vars, rn) <- accessGame variables case find ((== name) . getL vName) vars of Nothing -> do - (eGame >>> variables) %= (Var rn name def : ) + modifyGame variables (Var rn name def : ) return $ Just (V name) Just _ -> return Nothing @@ -95,7 +101,7 @@ case find ((== name) . getL vName) vars of Nothing -> return False Just _ -> do - (eGame >>> variables) %= filter ((/= name) . getL vName) + modifyGame variables $ filter ((/= name) . getL vName) return True evWriteVar :: (Typeable a, Show a) => V a -> a -> Evaluate Bool @@ -104,14 +110,14 @@ case find (\(Var _ myName _) -> myName == name) vars of Nothing -> return False Just (Var rn myName _) -> do - (eGame >>> variables) %= replaceWith ((== name) . getL vName) (Var rn myName val) + modifyGame variables $ replaceWith ((== name) . getL vName) (Var rn myName val) return True evOnEvent :: (Typeable e, Show e) => Event e -> ((EventNumber, e) -> Nomex ()) -> Evaluate EventNumber evOnEvent event handler = do (evs, rn) <- accessGame events let en = getFreeNumber (map _eventNumber evs) - (eGame >>> events) %= (EventInfo en rn event handler SActive [] : ) + modifyGame events (EventInfo en rn event handler SActive [] : ) return en evSendMessage :: (Typeable a, Show a) => Msg a -> a -> Evaluate () @@ -122,7 +128,7 @@ (rs, _) <- accessGame rules case find ((== (rNumber ^$ rule)) . getL rNumber) rs of Nothing -> do - (eGame >>> rules) %= (rule:) + modifyGame rules (rule:) triggerEvent (RuleEv Proposed) rule return True Just _ -> return False @@ -134,8 +140,7 @@ 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 - (eGame >>> rules) ~= newrules + putGame rules $ replaceWith ((== rn) . getL rNumber) r{_rStatus = Active, _rAssessedBy = Just by} rs --execute the rule withRN (_rNumber r) $ evalNomex (_rRule r) triggerEvent (RuleEv Activated) r @@ -147,13 +152,12 @@ 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 - (eGame >>> rules) ~= newrules - triggerEvent (RuleEv Rejected) r delVarsRule rn delEventsRule rn delOutputsRule rn delVictoryRule rn + putGame rules $ replaceWith ((== rn) . getL rNumber) r{_rStatus = Reject, _rAssessedBy = Just by} rs + triggerEvent (RuleEv Rejected) r return True evAddRule :: RuleInfo -> Evaluate Bool @@ -161,12 +165,12 @@ (rs, _) <- accessGame rules case find ((== (rNumber ^$ rule)) . getL rNumber) rs of Nothing -> do - (eGame >>> rules) %= (rule:) + modifyGame rules (rule:) triggerEvent (RuleEv Added) rule return True Just _ -> return False ---TODO: clean and execute new rule + evModifyRule :: RuleNumber -> RuleInfo -> Evaluate Bool evModifyRule rn rule = do (rs, _) <- accessGame rules @@ -174,7 +178,7 @@ case find ((== rn) . getL rNumber) rs of Nothing -> return False Just r -> do - (eGame >>> rules) ~= newRules + putGame rules newRules triggerEvent (RuleEv Modified) r return True @@ -186,7 +190,7 @@ tracePN pn "not in game!" return False Just pi -> do - (eGame >>> players) %= filter ((/= pn) . getL playerNumber) + modifyGame players $ filter ((/= pn) . getL playerNumber) triggerEvent (Player Leave) pi tracePN pn $ "leaving the game: " ++ _gameName g return True @@ -197,7 +201,7 @@ case find ((== pn) . getL playerNumber) pls of Nothing -> return False Just pi -> do - (eGame >>> players) ~= replaceWith ((== pn) . getL playerNumber) (pi {_playerName = name}) pls + putGame players $ replaceWith ((== pn) . getL playerNumber) (pi {_playerName = name}) pls return True evDelEvent :: EventNumber -> Evaluate Bool @@ -207,8 +211,7 @@ Nothing -> return False Just eh -> case _evStatus eh of SActive -> do - let newEvents = replaceWith ((== en) . getL eventNumber) eh{_evStatus = SDeleted} evs - (eGame >>> events) ~= newEvents + putGame events $ replaceWith ((== en) . getL eventNumber) eh{_evStatus = SDeleted} evs return True SDeleted -> return False @@ -219,7 +222,7 @@ evNewOutput pn s = do (ops, rn) <- accessGame outputs let on = getFreeNumber (map _outputNumber ops) - (eGame >>> outputs) %= (Output on rn pn s SActive : ) + modifyGame outputs (Output on rn pn s SActive : ) return on evGetOutput :: OutputNumber -> EvaluateNE (Maybe String) @@ -237,7 +240,7 @@ case find (\(Output myOn _ _ _ s) -> myOn == on && s == SActive) ops of Nothing -> return False Just (Output _ rn pn _ _) -> do - (eGame >>> outputs) %= replaceWith ((== on) . getL outputNumber) (Output on rn pn s SActive) + modifyGame outputs $ replaceWith ((== on) . getL outputNumber) (Output on rn pn s SActive) return True evDelOutput :: OutputNumber -> Evaluate Bool @@ -247,15 +250,14 @@ Nothing -> return False Just o -> case _oStatus o of SActive -> do - let newOutputs = replaceWith ((== on) . getL outputNumber) o{_oStatus = SDeleted} ops - (eGame >>> outputs) ~= newOutputs + putGame outputs $ replaceWith ((== on) . getL outputNumber) o{_oStatus = SDeleted} ops return True SDeleted -> return False evSetVictory :: NomexNE [PlayerNumber] -> Evaluate () evSetVictory ps = do rn <- access eRuleNumber - void $ (eGame >>> victory) ~= (Just $ VictoryInfo rn ps) + putGame victory (Just $ VictoryInfo rn ps) triggerEvent Victory (VictoryInfo rn ps) evReadVar :: (Typeable a, Show a) => V a -> EvaluateNE (Maybe a) @@ -268,12 +270,20 @@ Just v -> return $ Just v Nothing -> return Nothing +evGetRandomNumber :: Random a => (a, a) -> Evaluate a +evGetRandomNumber r = do + g <- access (eGame >>> randomGen) + let (a, g') = randomR r g + putGame randomGen g' + return a + + + -- * Events -- | Get the field at a certain address ---TODO: should we check that the field is not already completed? findField :: EventInfo -> FieldAddress -> FormField -> EvaluateNE (Maybe SomeField) findField (EventInfo _ _ e _ _ er) addr ft = findField' addr e er ft @@ -288,10 +298,10 @@ findField' (AppR:as) (AppEvent _ e2) frs ft = findField' as e2 (filterPath AppR frs) ft findField' (BindL:as) (BindEvent e1 _) frs ft = findField' as e1 (filterPath BindL frs) ft findField' (BindR:as) (BindEvent e1 f) frs ft = do - er <- getEventResult e1 (filterPath BindL frs) - case er of + ter <- getEventResult e1 (filterPath BindL frs) -- + case ter of Done e2 -> findField' as (f e2) (filterPath BindR frs) ft - Todo _ -> return Nothing + Todo _ -> return $ Nothing findField' (Shortcut:as) (ShortcutEvents es _) frs ft = do msfs <- mapM (\e-> findField' as e frs ft) es return $ headMay $ catMaybes msfs -- returning the first field that matches @@ -301,8 +311,7 @@ filterPath :: FieldAddressElem -> [FieldResult] -> [FieldResult] filterPath fa frs = mapMaybe f frs where f (FieldResult fe fr (Just (fa':fas))) | fa == fa' = Just $ FieldResult fe fr (Just fas) - f _ = Nothing - + f fr = Just fr getFormField :: SomeField -> Maybe FormField getFormField (SomeField (Input pn s (Radio choices))) = Just $ RadioField pn s (zip [0..] (snd <$> choices)) @@ -329,7 +338,7 @@ getEventResult' EmptyEvent _ _ = return $ Todo [] getEventResult' (SumEvent a b) ers fa = liftM2 (<|>) (getEventResult' a ers (fa ++ [SumL])) (getEventResult' b ers (fa ++ [SumR])) getEventResult' (AppEvent f b) ers fa = liftM2 (<*>) (getEventResult' f ers (fa ++ [AppL])) (getEventResult' b ers (fa ++ [AppR])) -getEventResult' (LiftNomexNE a) _ _ = evalNomexNE a >>= return . Done +getEventResult' (LiftEvent a) _ _ = evalNomexNE a >>= return . Done getEventResult' (BindEvent a f) ers fa = do er <- getEventResult' a ers (fa ++ [BindL]) case er of @@ -354,9 +363,9 @@ -- trigger some specific events triggerEvent' :: FieldResult -> [EventInfo] -> Evaluate () triggerEvent' res evs = do - evs' <- mapM (liftEval . (updateEventInfo res)) evs -- get all the EventInfos updated with the field - (eGame >>> events) %= union (map fst evs') -- store them - void $ mapM triggerIfComplete evs' -- trigger the handlers for completed events + evs' <- mapM (liftEval . (updateEventInfo res)) (sortBy (compare `on` _ruleNumber) evs) -- get all the EventInfos updated with the field + (eGame >>> events) %= union (map fst evs') -- store them + void $ mapM triggerIfComplete evs' -- trigger the handlers for completed events -- if the event is complete, trigger its handler triggerIfComplete :: (EventInfo, Maybe SomeData) -> Evaluate () @@ -393,7 +402,7 @@ i <- liftEval $ findField ei fa ft case i of Just sf -> execInputHandler' ir sf fa ei - Nothing -> logAll "Input not found" + Nothing -> logAll $ "Input not found, InputData=" ++ (show ir) ++ " FieldAddress=" ++ (show fa) ++ " FormField=" ++ (show ft) execInputHandler _ _ _ _ = return () -- execute the event handler using the data received from user @@ -405,6 +414,8 @@ execInputHandler' (CheckboxData is) (SomeField e@(Input _ _ (Checkbox cs))) fa ei = triggerEvent' (FieldResult e (fst <$> cs `sel` is) (Just fa)) [ei] execInputHandler' _ _ _ _ = return () + + -- * misc getVictorious :: Game -> [PlayerNumber] @@ -446,15 +457,16 @@ -- | Show instance for Game -- showing a game involves evaluating some parts (such as victory and outputs) instance Show Game where - show g@(Game gn _ rs ps vs es _ _ _ t) = + show g@(Game gn _ rs ps vs es os _ l t _) = "Game Name = " ++ show gn ++ - "\n Rules = " ++ (intercalate "\n " $ map show rs) ++ - "\n Players = " ++ show ps ++ - "\n Variables = " ++ show vs ++ - "\n Events = " ++ (intercalate "\n " $ map (displayEvent g) es) ++ - "\n Outputs = " ++ show (allOutputs g) ++ - "\n Victory = " ++ show (getVictorious g) ++ - "\n currentTime = " ++ show t ++ "\n" + "\n\n Rules = " ++ (intercalate "\n " $ map show rs) ++ + "\n\n Players = " ++ show ps ++ + "\n\n Variables = " ++ show vs ++ + "\n\n Events = " ++ (intercalate "\n " $ map (displayEvent g) es) ++ "\n" ++ + "\n\n Outputs = " ++ (intercalate "\n " $ map (displayOutput g) os) ++ "\n" ++ + "\n\n Victory = " ++ show (getVictorious g) ++ + "\n\n currentTime = " ++ show t ++ "\n" ++ + "\n\n logs = " ++ show l ++ "\n" displayEvent :: Game -> EventInfo -> String @@ -463,6 +475,14 @@ ", rule num: " ++ (show rn) ++ ", event fields: " ++ (show $ getEventFields ei g) ++ --TODO: display also event result? ", envs: " ++ (show env) ++ + ", status: " ++ (show s) + +displayOutput :: Game -> Output -> String +displayOutput g o@(Output on rn mpn _ s) = + "output num: " ++ (show on) ++ + ", rule num: " ++ (show rn) ++ + ", by pn: " ++ (show mpn) ++ + ", output: " ++ (show $ evalOutput g o) ++ ", status: " ++ (show s) displayEvent' :: EventInfo -> EvaluateNE String diff --git a/src/Nomyx/Core/Engine/GameEvents.hs b/src/Nomyx/Core/Engine/GameEvents.hs --- a/src/Nomyx/Core/Engine/GameEvents.hs +++ b/src/Nomyx/Core/Engine/GameEvents.hs @@ -20,8 +20,7 @@ import Data.Maybe -- | a list of possible events affecting a game -data GameEvent = GameSettings GameName GameDesc UTCTime - | JoinGame PlayerNumber PlayerName +data GameEvent = JoinGame PlayerNumber PlayerName | LeaveGame PlayerNumber | ProposeRuleEv PlayerNumber SubmitRule | InputResult PlayerNumber EventNumber FieldAddress FormField InputData @@ -47,7 +46,6 @@ -- | 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 @@ -76,7 +74,7 @@ execGameEvent' :: Maybe (RuleCode -> IO Rule) -> GameEvent -> StateT LoggedGame IO () execGameEvent' inter ge = do - t <- access $ game >>> currentTime + t <- access (game >>> currentTime) let te = TimedEvent t ge gameLog %= \gl -> gl ++ [te] focus game $ enactTimedEvent inter te @@ -87,14 +85,6 @@ 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 @@ -152,7 +142,7 @@ getTime (SomeField (Time t)) = Just t getTime _ = Nothing --- | A helper function to use the state transformer GameState. +-- | A helper function to run the game state. -- It additionally sets the current time. execWithGame :: UTCTime -> State LoggedGame () -> LoggedGame -> LoggedGame execWithGame t gs g = execState gs $ (game >>> currentTime) `setL` t $ g diff --git a/src/Nomyx/Core/Engine/Test.hs b/src/Nomyx/Core/Engine/Test.hs --- a/src/Nomyx/Core/Engine/Test.hs +++ b/src/Nomyx/Core/Engine/Test.hs @@ -24,6 +24,7 @@ import Control.Applicative import Control.Category hiding ((.)) import Control.Shortcut +import System.Random date1 = parse822Time "Tue, 02 Sep 1997 09:00:00 -0400" date2 = parse822Time "Tue, 02 Sep 1997 10:00:00 -0400" @@ -38,16 +39,17 @@ _outputs = [], _victory = Nothing, _logs = [], - _currentTime = date1} + _currentTime = date1, + _randomGen = mkStdGen 0} testRule = RuleInfo { _rNumber = 0, - _rName = "test", - _rDescription = "test", - _rProposedBy = 0, - _rRuleCode = "", - _rRule = return (), - _rStatus = Pending, - _rAssessedBy = Nothing} + _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 (runSystemEval' $ evalNomex r >> triggerEvent f d) testGame @@ -115,6 +117,7 @@ ("test composed event prod 2", testProdComposeEx2), ("test two separate events", testTwoEventsEx), ("test monadic event", testMonadicEventEx), + ("test monadic event2", testMonadicEventEx2), ("test shortcut event", testShorcutEventEx) ] @@ -170,7 +173,7 @@ 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]))] +testVarEx5 = (show $ head $ _variables $ execRule testVar5) == "Rule number = 0, Name = \"toto\", Value = [2,1]\n" data Choice = Holland | Sarkozy deriving (Enum, Typeable, Show, Eq, Bounded) @@ -246,6 +249,14 @@ testAutoActivateEx = _rStatus (head $ _rules (execRuleEventGame autoActivate (RuleEv Proposed) testRule (testGame {_rules=[testRule]}))) == Active +--testAutoDelete :: Rule +--testAutoDelete = do +-- outputAll_ "before" +-- autoDelete +-- outputAll_ "after" +-- +--testAutoDeleteEx = isOutput "ok" (execRuleGame testAutoDelete testGame {_rules=[testRule {_rNumber = 1}]}) + --Time tests testTimeEvent :: Rule @@ -399,6 +410,22 @@ testMonadicEventEx = isOutput "coco2" g where g = execRuleInputs testMonadicEvent 1 [([BindL], (TextField 1 ""), TextData "coco1"), ([BindR, BindR], (TextField 1 ""), TextData "coco2")] + +testMonadicEvent2 :: Rule +testMonadicEvent2 = do + let displayMsg a = void $ newOutput_ Nothing a + let e = do + playerEvent Arrive + inputText 1 "" + void $ onEvent_ e displayMsg + +testMonadicEvent2PlayerArrive :: Game +testMonadicEvent2PlayerArrive = flip execState testGame {_players = []} $ runSystemEval' $ do + addActivateRule testMonadicEvent2 1 + addPlayer (PlayerInfo 1 "coco 1" Nothing) + triggerInput 1 [BindR] (TextField 1 "") (TextData "coco2") + +testMonadicEventEx2 = isOutput "coco2" testMonadicEvent2PlayerArrive testShorcutEvent :: Rule testShorcutEvent = do diff --git a/src/Nomyx/Core/Engine/Types.hs b/src/Nomyx/Core/Engine/Types.hs --- a/src/Nomyx/Core/Engine/Types.hs +++ b/src/Nomyx/Core/Engine/Types.hs @@ -19,6 +19,7 @@ import Control.Monad.State import Control.Monad.Reader import GHC.Generics +import System.Random -- * Evaluation @@ -44,7 +45,8 @@ _outputs :: [Output], _victory :: Maybe VictoryInfo, _logs :: [Log], - _currentTime :: UTCTime} + _currentTime :: UTCTime, + _randomGen :: StdGen} deriving (Typeable) data GameDesc = GameDesc { _desc :: String, _agora :: String} deriving (Eq, Show, Read, Ord) @@ -55,7 +57,7 @@ instance Ord Game where compare (Game {_gameName=gn1}) (Game {_gameName=gn2}) = compare gn1 gn2 -emptyGame name desc date = Game { +emptyGame name desc date gen = Game { _gameName = name, _gameDesc = desc, _rules = [], @@ -65,6 +67,7 @@ _outputs = [], _victory = Nothing, _logs = [], + _randomGen = gen, _currentTime = date} @@ -106,6 +109,12 @@ _output :: NomexNE String, -- output string _oStatus :: Status} -- status of the output deriving (Show) + +instance Eq Output where + (Output {_outputNumber=on1}) == (Output {_outputNumber=on2}) = on1 == on2 + +instance Ord Output where + (Output {_outputNumber=r1}) <= (Output {_outputNumber=r2}) = r1 <= r2 -- * Logs diff --git a/src/Nomyx/Core/Engine/Utils.hs b/src/Nomyx/Core/Engine/Utils.hs --- a/src/Nomyx/Core/Engine/Utils.hs +++ b/src/Nomyx/Core/Engine/Utils.hs @@ -1,6 +1,15 @@ -module Nomyx.Core.Engine.Utils where - +module Nomyx.Core.Engine.Utils( + (===), + replaceWith, + tracePN, + traceData, + parse822Time, + sndMaybe, + mapStateIO, + getFreeNumber, + sel, + module Debug.Trace) where import Data.Time import Data.Typeable (cast, Typeable) 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 @@ -72,8 +72,9 @@ sendMailsNewRule :: Session -> SubmitRule -> PlayerNumber -> IO () sendMailsNewRule s sr pn = when (_sendMails $ _mSettings $ _multi s) $ do putStrLn "Sending mails" - gn <- fromJustNote "sendMailsNewRule" <$> getPlayersGame pn s - let sendMailsTo = delete pn (map _playerNumber (_players $ _game $ _loggedGame gn)) + gi <- fromJustNote "sendMailsNewRule" <$> getPlayersGame pn s + guard (_isPublic gi) + let sendMailsTo = delete pn (map _playerNumber (_players $ _game $ _loggedGame gi)) proposer <- Nomyx.Core.Profile.getPlayerName pn s profiles <- mapM (getProfile s) sendMailsTo mapM_ (send proposer (_net $ _mSettings $ _multi s) sr) (_pPlayerSettings <$> catMaybes profiles) 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 @@ -18,6 +18,7 @@ import Nomyx.Core.Types import Nomyx.Core.Interpret import Nomyx.Core.Quotes (cr) +import System.Random triggerTimeEvent :: UTCTime -> StateT Multi IO () triggerTimeEvent t = do @@ -62,7 +63,8 @@ initialGameInfo :: GameName -> GameDesc -> Bool -> Maybe PlayerNumber -> UTCTime -> ServerHandle -> IO GameInfo initialGameInfo name desc isPublic mpn date sh = do - let lg = GameInfo { _loggedGame = LoggedGame (emptyGame name desc date) [], + let gen = mkStdGen 0 + let lg = GameInfo { _loggedGame = LoggedGame (emptyGame name desc date gen) [], _ownedBy = mpn, _forkedFromGame = Nothing, _isPublic = isPublic, 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 @@ -22,7 +22,7 @@ import Nomyx.Core.Context --- This quasi quoter allows to type check a string as a Nomyx rule (a RuleFunc). +-- This quasi quoter allows to type check a string as a Nomyx rule. -- this gives additionnal safety at compile time. #ifdef NO_INTERPRET_QUOTES cr :: QuasiQuoter 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 @@ -19,6 +19,7 @@ import Nomyx.Core.Interpret import Nomyx.Core.Engine import Nomyx.Core.Engine.GameEvents +import System.Random save :: Multi -> IO () save m = BL.writeFile (getSaveFile $ _mSettings m) (encode m) @@ -52,7 +53,7 @@ time0 = posixSecondsToUTCTime 0 instance ToJSON Game where - toJSON (Game name desc _ _ _ _ _ _ _ _) = + toJSON (Game name desc _ _ _ _ _ _ _ _ _) = object ["gameName" .= name, "gameDesc" .= desc] @@ -67,8 +68,8 @@ pure [] <*> pure Nothing <*> pure [] <*> - pure time0 - -- A non-Object value is of the wrong type, so fail. + pure time0 <*> + pure (mkStdGen 0) parseJSON _ = mzero @@ -84,4 +85,5 @@ $(deriveJSON defaultOptions ''InputData) $(deriveJSON defaultOptions ''SubmitRule) $(deriveJSON defaultOptions ''GameDesc) +$(deriveJSON defaultOptions ''StdGen) 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 @@ -11,6 +11,7 @@ import Data.Time as T import Data.List import qualified Data.Acid.Advanced as A (update', query') +import Happstack.Auth.Core.Auth import Control.Category hiding ((.)) import Control.Monad.State import Control.Concurrent.STM @@ -28,6 +29,7 @@ newPlayer :: PlayerNumber -> PlayerSettings -> StateT Session IO () newPlayer uid ms = do s <- get + void $ A.update' (acidAuth $ _profiles s) (SetDefaultSessionTimeout $ 3600 * 24 * 7 *25) void $ A.update' (acidProfileData $ _profiles s) (NewProfileData uid ms) -- | starts a new game