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.0 +version: 0.7.1 cabal-version: >=1.6 build-type: Simple license: BSD3 @@ -15,7 +15,7 @@ data-dir: data library - build-depends: Nomyx-Language == 0.7.0, + build-depends: Nomyx-Language == 0.7.1, DebugTraceHelpers == 0.12.*, MissingH == 1.2.*, acid-state == 0.12.*, diff --git a/src/Data/Todo.hs b/src/Data/Todo.hs --- a/src/Data/Todo.hs +++ b/src/Data/Todo.hs @@ -27,7 +27,7 @@ instance Monad (Todo a) where return = Done Todo as >>= _ = Todo as - Done a >>= f = f a + Done a >>= f = f a toEither :: Todo a b -> Either [a] b toEither (Todo as) = Left as diff --git a/src/Nomyx/Core/Engine.hs b/src/Nomyx/Core/Engine.hs --- a/src/Nomyx/Core/Engine.hs +++ b/src/Nomyx/Core/Engine.hs @@ -30,9 +30,10 @@ events, getEventFields, getEventInfo, - getInput, + getFormField, -- * Inputs management + FormField(..), InputData(..), -- * Outputs management 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 @@ -24,9 +24,10 @@ import Control.Applicative import Control.Monad.Error.Class (MonadError(..)) import Language.Nomyx.Expression -import Nomyx.Core.Engine.Types +import Nomyx.Core.Engine.Types hiding (_vRuleNumber) import Nomyx.Core.Engine.EvalUtils import Nomyx.Core.Engine.Utils +import Safe -- * Evaluation @@ -152,6 +153,7 @@ delVarsRule rn delEventsRule rn delOutputsRule rn + delVictoryRule rn return True evAddRule :: RuleInfo -> Evaluate Bool @@ -268,41 +270,55 @@ -- * Events ---get the fields left to be completed in an event -getEventFields :: EventInfo -> Game -> [(FieldAddress, SomeField)] -getEventFields (EventInfo _ rn e _ _ env) g = case runEvaluateNE g rn $ getEventResult e env of - Done _ -> [] - Todo a -> a --- | Get the field at a certain address -getInput :: EventInfo -> FieldAddress -> Game -> Maybe SomeField -getInput ei fa g = runEvaluateNE g (_ruleNumber ei) (findField ei fa) -- | Get the field at a certain address --TODO: should we check that the field is not already completed? -findField :: EventInfo -> FieldAddress -> EvaluateNE (Maybe SomeField) -findField (EventInfo _ _ e _ _ er) addr = findField' addr e er +findField :: EventInfo -> FieldAddress -> FormField -> EvaluateNE (Maybe SomeField) +findField (EventInfo _ _ e _ _ er) addr ft = findField' addr e er ft -findField' :: FieldAddress -> Event e -> [FieldResult] -> EvaluateNE (Maybe SomeField) -findField' [] (BaseEvent f) _ = return $ Just $ SomeField f -findField' (SumL:as) (SumEvent e1 _) frs = findField' as e1 (filterPath SumL frs) -findField' (SumR:as) (SumEvent _ e2) frs = findField' as e2 (filterPath SumR frs) -findField' (AppL:as) (AppEvent e1 _) frs = findField' as e1 (filterPath AppL frs) -findField' (AppR:as) (AppEvent _ e2) frs = findField' as e2 (filterPath AppR frs) -findField' (BindL:as) (BindEvent e1 _) frs = findField' as e1 (filterPath BindL frs) -findField' ((Index i):as) (ShortcutEvents es _) frs = findField' as (es!!i) frs -findField' (BindR:as) (BindEvent e1 f) frs = do +findField' :: FieldAddress -> Event e -> [FieldResult] -> FormField -> EvaluateNE (Maybe SomeField) +findField' [] (BaseEvent f) _ ft = return $ do + ft' <- getFormField (SomeField f) + guard (ft' == ft) + return $ SomeField f +findField' (SumL:as) (SumEvent e1 _) frs ft = findField' as e1 (filterPath SumL frs) ft +findField' (SumR:as) (SumEvent _ e2) frs ft = findField' as e2 (filterPath SumR frs) ft +findField' (AppL:as) (AppEvent e1 _) frs ft = findField' as e1 (filterPath AppL frs) ft +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 - Done e2 -> findField' as (f e2) (filterPath BindR frs) + Done e2 -> findField' as (f e2) (filterPath BindR frs) ft Todo _ -> return Nothing -findField' _ _ _ = error "findField: wrong field address" +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 +findField' fa _ _ _ = error $ "findField: wrong field address: " ++ (show fa) + 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 + +getFormField :: SomeField -> Maybe FormField +getFormField (SomeField (Input pn s (Radio choices))) = Just $ RadioField pn s (zip [0..] (snd <$> choices)) +getFormField (SomeField (Input pn s Text)) = Just $ TextField pn s +getFormField (SomeField (Input pn s TextArea)) = Just $ TextAreaField pn s +getFormField (SomeField (Input pn s Button)) = Just $ ButtonField pn s +getFormField (SomeField (Input pn s (Checkbox choices))) = Just $ CheckboxField pn s (zip [0..] (snd <$> choices)) +getFormField _ = Nothing + + +--get the fields left to be completed in an event +getEventFields :: EventInfo -> Game -> [(FieldAddress, SomeField)] +getEventFields (EventInfo _ rn e _ _ env) g = case runEvaluateNE g rn $ getEventResult e env of + Done _ -> [] + Todo a -> a + -- 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 -> [FieldResult] -> EvaluateNE (Todo (FieldAddress, SomeField) a) @@ -325,67 +341,60 @@ Nothing -> Todo [(fa, SomeField a)] getEventResult' (ShortcutEvents es f) ers fa = do - ers <- mapM (\i -> getEventResult' (es!!i) ers (fa ++ [Index i]) ) [0.. (length es -1)] - case f (toMaybe <$> ers) of - True -> return $ Done $ toMaybe <$> ers - False -> return $ Todo $ join $ lefts $ toEither <$> ers + (ers :: [Todo (FieldAddress, SomeField) a]) <- mapM (\e -> getEventResult' e ers (fa ++ [Shortcut])) es -- get the result for each event in the list + return $ case f (toMaybe <$> ers) of -- apply f to the event results that we already have + True -> Done $ toMaybe <$> ers -- if the result is true, we are done. Return the list of maybe results + False -> Todo $ join $ lefts $ toEither <$> ers -- otherwise, return the list of remaining fields to complete from each event + -- trigger an event triggerEvent :: (Typeable e, Show e) => Field e -> e -> Evaluate () -triggerEvent e dat = do - evs <- access (eGame >>> events) - triggerEvent' (FieldResult e dat Nothing) evs +triggerEvent e dat = access (eGame >>> events) >>= triggerEvent' (FieldResult e dat Nothing) -- trigger some specific events triggerEvent' :: FieldResult -> [EventInfo] -> Evaluate () triggerEvent' res evs = do - evs' <- mapM (liftEval . (updateEventInfo res)) evs - (eGame >>> events) %= union (map fst evs') - mapM triggerIfComplete evs' - return () + 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 -- if the 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) - withRN rn $ (evalNomex exp) `catchError` (errorHandler en) - return () - Nothing -> error "Bad trigger data type" +triggerIfComplete (EventInfo en rn _ h SActive _, Just (SomeData val)) = case (cast val) of + Just a -> void $ withRN rn $ (evalNomex $ h (en, a)) `catchError` (errorHandler en) + Nothing -> error "Bad trigger data type" triggerIfComplete _ = return () - --- update the EventInfo with the field result +-- update the EventInfo with the field result. +-- get the event result if all fields are completed updateEventInfo :: FieldResult -> EventInfo -> EvaluateNE (EventInfo, Maybe SomeData) updateEventInfo (FieldResult field dat addr) ei@(EventInfo _ _ ev _ _ envi) = do g <- asks _eGame let eventRes = FieldResult field dat addr er <- getEventResult ev (eventRes : envi) - if (SomeField field) `elem` (map snd $ getEventFields ei g) then do -- if the field if found among the remaining fields of the event - case er of -- then check the event with that field result included - Todo _ -> return $ (env ^= (eventRes : envi) $ ei, Nothing) -- some fields are left to complete: add ours in the environment - Done a -> return $ (env ^= [] $ ei, Just $ SomeData a) -- the event is now complete: empty the environment and output the result - else return $ (ei, Nothing) -- field not found: do nothin - + return $ case er of -- check if the event will be complete + Todo _ -> if (SomeField field) `elem` (map snd $ getEventFields ei g) -- is yes, check if our field is really a missing field of the event + then (env ^= (eventRes : envi) $ ei, Nothing) -- some fields are left to complete: add ours in the environment + else (ei, Nothing) -- field not found: do nothing + Done a -> (env ^= [] $ ei, Just $ SomeData a) -- the event is complete: empty the environment and output the result -- * input triggers -- trigger the input event with the input data -triggerInput :: EventNumber -> FieldAddress -> InputData -> Evaluate () -triggerInput en fa ir = do +triggerInput :: EventNumber -> FieldAddress -> FormField -> InputData -> Evaluate () +triggerInput en fa ft ir = do evs <- access (eGame >>> events) let mei = find ((== en) . getL eventNumber) evs - when (isJust mei) $ execInputHandler ir fa (fromJust mei) + when (isJust mei) $ execInputHandler ir fa ft (fromJust mei) -- execute the corresponding handler -execInputHandler :: InputData -> FieldAddress -> EventInfo -> Evaluate () -execInputHandler ir fa ei@(EventInfo _ _ _ _ SActive _) = do - i <- liftEval $ findField ei fa +execInputHandler :: InputData -> FieldAddress -> FormField -> EventInfo -> Evaluate () +execInputHandler ir fa ft ei@(EventInfo _ _ _ _ SActive _) = do + i <- liftEval $ findField ei fa ft case i of Just sf -> execInputHandler' ir sf fa ei Nothing -> logAll "Input not found" -execInputHandler _ _ _ = return () +execInputHandler _ _ _ _ = return () -- execute the event handler using the data received from user execInputHandler' :: InputData -> SomeField -> FieldAddress -> EventInfo -> Evaluate () @@ -427,7 +436,13 @@ let toDelete = filter ((== rn) . getL oRuleNumber) os mapM_ (evDelOutput . _outputNumber) toDelete +--delete victory of a rule +delVictoryRule :: RuleNumber -> Evaluate () +delVictoryRule rn = do + vic <- access (eGame >>> victory) + when (isJust vic && _vRuleNumber (fromJust vic) == rn) $ void $ (eGame >>> victory) ~= Nothing + -- | Show instance for Game -- showing a game involves evaluating some parts (such as victory and outputs) instance Show Game where @@ -446,8 +461,11 @@ displayEvent g ei@(EventInfo en rn _ _ s env) = "event num: " ++ (show en) ++ ", rule num: " ++ (show rn) ++ - ", event fields: " ++ (show $ getEventFields ei g) ++ + ", event fields: " ++ (show $ getEventFields ei g) ++ --TODO: display also event result? ", envs: " ++ (show env) ++ ", status: " ++ (show s) - +displayEvent' :: EventInfo -> EvaluateNE String +displayEvent' ei = do + (EvalEnv _ g) <- ask + return $ displayEvent g ei 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 @@ -24,7 +24,7 @@ | JoinGame PlayerNumber PlayerName | LeaveGame PlayerNumber | ProposeRuleEv PlayerNumber SubmitRule - | InputResult PlayerNumber EventNumber FieldAddress InputData + | InputResult PlayerNumber EventNumber FieldAddress FormField InputData | GLog (Maybe PlayerNumber) String | TimeEvent UTCTime | SystemAddRule SubmitRule @@ -51,7 +51,7 @@ 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 fa ir) _ = mapStateIO $ inputResult pn en fa ir +enactEvent (InputResult pn en fa ft ir) _ = mapStateIO $ inputResult pn en fa ft ir enactEvent (GLog mpn s) _ = mapStateIO $ logGame s mpn enactEvent (TimeEvent t) _ = mapStateIO $ runSystemEval' $ evTriggerTime t enactEvent (SystemAddRule r) (Just inter) = systemAddRule r inter @@ -136,10 +136,10 @@ void $ logs %= (Log mpn time s : ) -- | the user has provided an input result -inputResult :: PlayerNumber -> EventNumber -> FieldAddress -> InputData -> State Game () -inputResult pn en fa ir = do - tracePN pn $ "input result: EventNumber " ++ show en ++ ", FieldAddress " ++ show fa ++ ", choice " ++ show ir - runSystemEval pn $ triggerInput en fa ir +inputResult :: PlayerNumber -> EventNumber -> FieldAddress -> FormField -> InputData -> State Game () +inputResult pn en fa ft ir = do + tracePN pn $ "input result: EventNumber " ++ show en ++ ", FieldAddress " ++ show fa ++ ", Form " ++ show ft ++ ", choice " ++ show ir + runSystemEval pn $ triggerInput en fa ft ir getGameTimes :: Game -> [UTCTime] getGameTimes g = concatMap (\ei -> getTimes ei g) (_events 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 @@ -55,11 +55,11 @@ execRuleEvents :: (Show e, Typeable e) => Nomex a -> [(Field e, e)] -> Game execRuleEvents f eds = execState (runSystemEval' $ evalNomex f >> mapM (\(a,b) -> triggerEvent a b) eds) testGame -execRuleInput :: Nomex a -> EventNumber -> FieldAddress -> InputData -> Game -execRuleInput r en fa d = execState (runSystemEval' $ evalNomex r >> triggerInput en fa d) testGame +execRuleInput :: Nomex a -> EventNumber -> FieldAddress -> FormField -> InputData -> Game +execRuleInput r en fa ft d = execState (runSystemEval' $ evalNomex r >> triggerInput en fa ft d) testGame -execRuleInputs :: Nomex a -> EventNumber -> [(FieldAddress, InputData)] -> Game -execRuleInputs r en fads = execState (runSystemEval' $ evalNomex r >> mapM (\(fa, d) -> triggerInput en fa d) fads) testGame +execRuleInputs :: Nomex a -> EventNumber -> [(FieldAddress, FormField, InputData)] -> Game +execRuleInputs r en fads = execState (runSystemEval' $ evalNomex r >> mapM (\(fa, ft, d) -> triggerInput en fa ft d) fads) testGame execRuleGame :: Nomex a -> Game -> Game execRuleGame r g = execState (runSystemEval' $ void $ evalNomex r) g @@ -90,7 +90,6 @@ ("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), @@ -102,13 +101,15 @@ ("test assess on every vote 3", testVoteAssessOnEveryVote3), ("test assess on every vote 4", testVoteAssessOnEveryVote4), ("test majority with", testVoteMajorityWith), --- ("test number positive votes", testVoteNumberPositiveVotes), + ("test number positive votes", testVoteNumberPositiveVotes), ("test vote with quorum 1", testVoteWithQuorum1), ("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 vote player arrives", testVotePlayerArriveEx), + ("test vote player leaves", testVotePlayerLeaveEx), ("test composed event sum", testSumComposeEx), ("test composed event prod 1", testProdComposeEx1), ("test composed event prod 2", testProdComposeEx2), @@ -296,12 +297,14 @@ actions evProposeRule testRule evs <- lift getChoiceEvents - let pos = take positives evs - let neg = take negatives $ drop positives evs - mapM_ (\(en, fa) -> triggerInput en fa (RadioData 0)) pos --issuing positive votes - mapM_ (\(en, fa) -> triggerInput en fa (RadioData 1)) neg --issuing negative votes + mapM_ (triggerVote 0) (take positives evs) --issuing positive votes + mapM_ (triggerVote 1) (take negatives $ drop positives evs) --issuing negative votes when timeEvent $ evTriggerTime date2 +--Trigger a vote event (0 for positive, 1 for negative), using event details +triggerVote :: Int -> (EventNumber, FieldAddress, PlayerNumber, String) -> Evaluate () +triggerVote res (en, fa, pn, t) = triggerInput en fa (RadioField pn t [(0,"For"),(1,"Against")]) (RadioData res) + voteGame' :: Int -> Int -> Int -> Bool -> Rule -> Game voteGame' positives negatives notVoted timeEvent rf = voteGameActions positives negatives notVoted timeEvent $ addActivateRule rf 1 @@ -329,6 +332,34 @@ testVoteRule s g = (_rStatus $ head $ _rules g) == s +--Test with a player arriving in the middle of a vote (he should be able to vote) +testVotePlayerArrive :: Game +testVotePlayerArrive = flip execState testGame {_players = []} $ runSystemEval' $ do + addPlayer (PlayerInfo 1 "coco 1" Nothing) + addActivateRule (onRuleProposed $ callVoteRule (unanimity `withQuorum` 2) oneDay) 1 + evProposeRule testRule + evs <- lift getChoiceEvents + mapM_ (triggerVote 0) evs --issuing positive vote player 1 + addPlayer (PlayerInfo 2 "coco 2" Nothing) --new player + evs <- lift getChoiceEvents + mapM_ (triggerVote 0) evs --issuing positive vote player 2 + +testVotePlayerArriveEx = testVoteRule Active testVotePlayerArrive + +--Test with a player leaving in the middle of a vote +--in some cases a player leaving can trigger the end of the vote (i.e when everybody voted except him) +testVotePlayerLeave :: Game +testVotePlayerLeave = flip execState testGame {_players = []} $ runSystemEval' $ do + addPlayer (PlayerInfo 1 "coco 1" Nothing) + addPlayer (PlayerInfo 2 "coco 2" Nothing) + addActivateRule (onRuleProposed $ callVoteRule unanimity oneDay) 1 + evProposeRule testRule + evs <- lift getChoiceEvents + triggerVote 0 (last evs) -- issuing positive vote player 1 + evDelPlayer 2 -- player 2 leaving + +testVotePlayerLeaveEx = testVoteRule Active testVotePlayerLeave + -- Event composition testSumCompose :: Rule @@ -336,7 +367,7 @@ f a = outputAll_ $ show a testSumComposeEx = isOutput "True" g where - g = execRuleInput testSumCompose 1 [SumL, AppR] ButtonData + g = execRuleInput testSumCompose 1 [SumL, AppR] (ButtonField 1 "click here:") ButtonData testProdCompose :: Rule @@ -344,10 +375,10 @@ f a = outputAll_ $ show a testProdComposeEx1 = null $ allOutputs g where - g = execRuleInput testProdCompose 1 [AppR] (TextData "toto") + g = execRuleInput testProdCompose 1 [AppR] (TextField 1 "") (TextData "toto") testProdComposeEx2 = isOutput "(\"toto\",\"tata\")" g where - g = execRuleInputs testProdCompose 1 [([AppL, AppR], TextData "toto"), ([AppR], TextData "tata")] + g = execRuleInputs testProdCompose 1 [([AppL, AppR], (TextField 1 ""), TextData "toto"), ([AppR], (TextField 1 ""), TextData "tata")] testTwoEvents :: Rule testTwoEvents = do @@ -356,7 +387,7 @@ f a = outputAll_ $ show a testTwoEventsEx = (length $ allOutputs g) == 1 where - g = execRuleInput testTwoEvents 1 [] (TextData "toto") + g = execRuleInput testTwoEvents 1 [] (TextField 1 "") (TextData "toto") testMonadicEvent :: Rule testMonadicEvent = do @@ -367,31 +398,32 @@ void $ onEvent_ e displayMsg testMonadicEventEx = isOutput "coco2" g where - g = execRuleInputs testMonadicEvent 1 [([BindL], TextData "coco1"), ([BindR, BindR], TextData "coco2")] + g = execRuleInputs testMonadicEvent 1 [([BindL], (TextField 1 ""), TextData "coco1"), ([BindR, BindR], (TextField 1 ""), TextData "coco2")] testShorcutEvent :: Rule testShorcutEvent = do let displayMsg a = void $ newOutput_ Nothing (concat $ catMaybes a) let e = do - let a = inputText 1 "" - shortcut [a,a] (\as -> length (filter isJust as) == 1) + let a = inputText 1 "a" + let b = inputText 1 "b" + shortcut [a,b] (\as -> length (filter isJust as) >= 1) void $ onEvent_ e displayMsg testShorcutEventEx = isOutput "coco1" g where - g = execRuleInputs testShorcutEvent 1 [([Index 0], TextData "coco1")] + g = execRuleInputs testShorcutEvent 1 [([Shortcut], (TextField 1 "a"), TextData "coco1")] --Get all event numbers of type choice (radio button) -getChoiceEvents :: State EvalEnv [(EventNumber, FieldAddress)] +getChoiceEvents :: State EvalEnv [(EventNumber, FieldAddress, PlayerNumber, String)] getChoiceEvents = do evs <- access (eGame >>> events) g <- access eGame - return $ [(_eventNumber ev, inum) | ev <- evs, inum <- getInputChoices ev g] + return $ [(_eventNumber ev, fa, pn, t) | ev <- evs, (fa, pn, t) <- getInputChoices ev g] -getInputChoices :: EventInfo -> Game -> [FieldAddress] +getInputChoices :: EventInfo -> Game -> [(FieldAddress, PlayerNumber, String)] getInputChoices ei g = mapMaybe isInput (getEventFields ei g) where - isInput :: (t, SomeField) -> Maybe t - isInput (fa, (SomeField (Input _ _ (Radio _)))) = Just fa + isInput :: (FieldAddress, SomeField) -> Maybe (FieldAddress, PlayerNumber, String) + isInput (fa, (SomeField (Input pn t (Radio _)))) = Just (fa, pn, t) isInput _ = Nothing --Get all event numbers of type text (text field) 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 @@ -4,6 +4,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveGeneric #-} -- | Types for the engine module Nomyx.Core.Engine.Types where @@ -17,6 +18,7 @@ import Control.Monad.Error (ErrorT(..)) import Control.Monad.State import Control.Monad.Reader +import GHC.Generics -- * Evaluation @@ -79,7 +81,15 @@ -- * Events --- data sent back by the forms +-- a form field +data FormField = RadioField PlayerNumber String [(Int, String)] + | TextField PlayerNumber String + | TextAreaField PlayerNumber String + | ButtonField PlayerNumber String + | CheckboxField PlayerNumber String [(Int, String)] + deriving (Show, Read, Ord, Eq, Generic) + +-- data sent back by the form fields data InputData = RadioData Int | CheckboxData [Int] | TextData String 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 @@ -22,7 +22,7 @@ -> [a] -- ^ Output list replaceWith f y = map (\z -> if f z then y else z) -tracePN :: (Monad m ) => Int -> String -> m () +tracePN :: (Monad m) => Int -> String -> m () tracePN pn s = traceM $ "Player " ++ (show pn) ++ " " ++ s traceData :: (Show a) => String -> a -> a 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 @@ -79,6 +79,7 @@ $(deriveJSON defaultOptions ''GameInfo) $(deriveJSON defaultOptions ''TimedEvent) $(deriveJSON defaultOptions ''FieldAddressElem) +$(deriveJSON defaultOptions ''FormField) $(deriveJSON defaultOptions ''GameEvent) $(deriveJSON defaultOptions ''InputData) $(deriveJSON defaultOptions ''SubmitRule) 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 @@ -40,7 +40,7 @@ newGame' name desc pn isPublic sh = do gs <- access gameInfos if not $ any ((== name) . getL gameNameLens) gs then do - tracePN pn $ "Creating a new game of name: " ++ name + tracePN pn $ "Creating a new game with name: " ++ name t <- lift T.getCurrentTime -- create a game with zero players lg <- lift $ initialGameInfo name desc isPublic (Just pn) t sh @@ -119,8 +119,8 @@ tracePN pn ("Error in submitted rule: " ++ errorMsg) modifyProfile pn (pLastRule ^= Just (sr, errorMsg)) -inputResult :: PlayerNumber -> EventNumber -> FieldAddress -> InputData -> GameName -> StateT Session IO () -inputResult pn en fa ir gn = inGameDo gn $ execGameEvent $ InputResult pn en fa ir +inputResult :: PlayerNumber -> EventNumber -> FieldAddress -> FormField -> InputData -> GameName -> StateT Session IO () +inputResult pn en fa ft ir gn = inGameDo gn $ execGameEvent $ InputResult pn en fa ft 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 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 @@ -136,7 +136,7 @@ onePlayerOneGame sh <- access sh submitRule (SubmitRule "" "" r) 1 "test" sh - inputAllRadios 0 1 + inputAllRadios 0 testFile' :: FilePath -> FilePath -> String -> StateT Session IO Bool testFile' path name func = do @@ -144,7 +144,7 @@ dataDir <- lift PNC.getDataDir res <- inputUpload 1 (dataDir testDir path) name sh submitRule (SubmitRule "" "" func) 1 "test" sh - inputAllRadios 0 1 + inputAllRadios 0 return res testFile :: FilePath -> String -> StateT Session IO Bool @@ -165,8 +165,7 @@ twoPlayersOneGame sh <- access sh submitRule (SubmitRule "" "" [cr|helloWorld|]) 1 "test" sh - inputAllRadios 0 1 - inputAllRadios 0 2 + inputAllRadios 0 condHelloWorld2Players :: Multi -> Bool condHelloWorld2Players = isOutput' "hello, world!" @@ -180,8 +179,7 @@ submitRule (SubmitRule "" "" [cr|createBankAccount|]) 1 "test" sh submitRule (SubmitRule "" "" [cr|winXEcuOnRuleAccepted 100|]) 1 "test" sh submitRule (SubmitRule "" "" [cr|moneyTransfer|]) 2 "test" sh - inputAllRadios 0 1 - inputAllRadios 0 2 + inputAllRadios 0 inputAllTexts "50" 1 condMoneyTransfer :: Multi -> Bool @@ -312,19 +310,19 @@ isOutput' :: String -> Multi -> Bool isOutput' s m = any (isOutput s . _game . _loggedGame) (_gameInfos m) --- select first choice for all radio buttons -inputAllRadios :: Int -> PlayerNumber -> StateT Session IO () -inputAllRadios choice pn = do +-- select a choice for all radio buttons +inputAllRadios :: Int -> StateT Session IO () +inputAllRadios choice = do s <- get let evs = evalState getChoiceEvents (EvalEnv 0 (firstGame $ _multi s)) - mapM_ (\(en, inum) -> inputResult pn en inum (RadioData choice) "test") evs + mapM_ (\(en, fa, pn, t) -> inputResult pn en fa (RadioField pn t [(0,"For"),(1,"Against")]) (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, fa) -> inputResult pn en fa (TextData a) "test") evs + mapM_ (\(en, fa) -> inputResult pn en fa (TextField 1 "") (TextData a) "test") evs firstGame :: Multi -> Game firstGame = G._game . _loggedGame . head . _gameInfos