diff --git a/Nomyx-Language.cabal b/Nomyx-Language.cabal --- a/Nomyx-Language.cabal +++ b/Nomyx-Language.cabal @@ -1,5 +1,5 @@ name: Nomyx-Language -version: 0.7.3 +version: 0.7.4 cabal-version: >=1.6 ---Warning: to use "cabal sdist", this patch is needed in cabal: https://github.com/haskell/cabal/pull/1110 ---This allows cabal to work with exported generated modules (Paths_Nomyx_Language) diff --git a/src/Language/Nomyx/Examples.hs b/src/Language/Nomyx/Examples.hs --- a/src/Language/Nomyx/Examples.hs +++ b/src/Language/Nomyx/Examples.hs @@ -10,7 +10,8 @@ nothing, helloWorld, accounts, - createBankAccount, + createBankAccounts, + displayBankAccounts, winXEcuPerDay, winXEcuOnRuleAccepted, moneyTransfer, @@ -34,7 +35,6 @@ gameMaster, bravoButton, enterHaiku, - displayBankAccount, helloButton, module X) where @@ -62,12 +62,12 @@ accounts = msgVar "Accounts" -- | Create a bank account for each players -createBankAccount :: Rule -createBankAccount = void $ createValueForEachPlayer_ accounts +createBankAccounts :: Rule +createBankAccounts = void $ createValueForEachPlayer_ accounts -- | Permanently display the bank accounts -displayBankAccount :: Rule -displayBankAccount = do +displayBankAccounts :: Rule +displayBankAccounts = do let displayOneAccount (account_pn, a) = do name <- showPlayer account_pn return $ name ++ "\t" ++ show a ++ "\n" diff --git a/src/Language/Nomyx/Rules.hs b/src/Language/Nomyx/Rules.hs --- a/src/Language/Nomyx/Rules.hs +++ b/src/Language/Nomyx/Rules.hs @@ -19,7 +19,7 @@ addRule, addRule_, addRule', getFreeRuleNumber, suppressRule, suppressRule_, suppressAllRules, - modifyRule, + proposeRule, modifyRule, autoActivate, activateOrRejectRule, simulate, @@ -112,6 +112,10 @@ modifyRule :: RuleNumber -> RuleInfo -> Nomex Bool modifyRule rn r = ModifyRule rn r + +-- | propose a rule that will need to be voted on. +proposeRule :: RuleInfo -> Nomex Bool +proposeRule = ProposeRule -- | allows a rule to retrieve its own number (for auto-deleting for example) getSelfRuleNumber :: NomexNE RuleNumber diff --git a/src/Language/Nomyx/Vote.hs b/src/Language/Nomyx/Vote.hs --- a/src/Language/Nomyx/Vote.hs +++ b/src/Language/Nomyx/Vote.hs @@ -23,6 +23,7 @@ import Control.Applicative import Control.Shortcut import Data.List +import System.Locale import qualified Data.Map as M -- | a vote assessing function (such as unanimity, majority...) @@ -35,9 +36,30 @@ voteFinished :: Bool} deriving (Show, Typeable) +-- | information broadcasted when a vote begins +data VoteBegin = VoteBegin { vbRule :: RuleInfo, + vbEndAt :: UTCTime, + vbEventNumber :: EventNumber } + deriving (Show, Eq, Ord, Typeable) + +-- | information broadcasted when a vote ends +data VoteEnd = VoteEnd { veRule :: RuleInfo, + veVotes :: [(PlayerNumber, Maybe Bool)], + vePassed :: Bool, + veFinishedAt :: UTCTime} + deriving (Show, Eq, Ord, Typeable) + +voteBegin :: Msg VoteBegin +voteBegin = Msg "VoteBegin" + +voteEnd :: Msg VoteEnd +voteEnd = Msg "VoteEnd" + -- | vote at unanimity every incoming rule unanimityVote :: Nomex () -unanimityVote = onRuleProposed $ callVoteRule unanimity oneDay +unanimityVote = do + onRuleProposed $ callVoteRule unanimity oneDay + displayVotes -- | call a vote on a rule for every players, with an assessing function and a delay callVoteRule :: AssessFunction -> NominalDiffTime -> RuleInfo -> Nomex () @@ -46,23 +68,25 @@ callVoteRule' assess endTime ri callVoteRule' :: AssessFunction -> UTCTime -> RuleInfo -> Nomex () -callVoteRule' assess endTime ri = callVote assess endTime (_rName ri) (_rNumber ri) (finishVote assess ri) +callVoteRule' assess endTime ri = do + en <- callVote assess endTime (_rName ri) (_rNumber ri) (finishVote assess ri) + sendMessage voteBegin (VoteBegin ri endTime en) -- | actions to do when the vote is finished finishVote :: AssessFunction -> RuleInfo -> [(PlayerNumber, Maybe Bool)] -> Nomex () finishVote assess ri vs = do let passed = fromJust $ assess $ getVoteStats (map snd vs) True activateOrRejectRule ri passed - void $ outputAll $ showFinishedVote (_rNumber ri) passed vs - + end <- liftEffect getCurrentTime + sendMessage voteEnd (VoteEnd ri vs passed end) -- | call a vote for every players, with an assessing function, a delay and a function to run on the result -callVote :: AssessFunction -> UTCTime -> String -> RuleNumber -> ([(PlayerNumber, Maybe Bool)] -> Nomex ()) -> Nomex () +callVote :: AssessFunction -> UTCTime -> String -> RuleNumber -> ([(PlayerNumber, Maybe Bool)] -> Nomex ()) -> Nomex EventNumber callVote assess endTime name rn payload = do let title = "Vote for rule: \"" ++ name ++ "\" (#" ++ (show rn) ++ "):" - en <- onEventOnce (voteWith endTime assess title) payload - displayVote en rn + onEventOnce (voteWith endTime assess title) payload + -- | vote with a function able to assess the ongoing votes. -- | the vote can be concluded as soon as the result is known. voteWith :: UTCTime -> AssessFunction -> String -> Event [(PlayerNumber, Maybe Bool)] @@ -74,6 +98,12 @@ (vs, _)<- shortcut2b voteEvents timerEvent isFinished return $ zip pns vs +-- | display the votes (ongoing and finished) +displayVotes :: Nomex () +displayVotes = do + void $ onMessage voteEnd displayFinishedVote + void $ onMessage voteBegin displayOnGoingVote + -- trigger the display of a radio button choice on the player screen, yelding either True or False. -- after the time limit, the value sent back is Nothing. singleVote :: String -> PlayerNumber -> Event Bool @@ -131,13 +161,14 @@ notVoted vs = (nbParticipants vs) - (voted vs) voted vs = M.findWithDefault 0 True (voteCounts vs) + M.findWithDefault 0 False (voteCounts vs) -displayVote :: EventNumber -> RuleNumber -> Nomex () -displayVote en rn = void $ outputAll $ do +-- | display an on going vote +displayOnGoingVote :: VoteBegin -> Nomex () +displayOnGoingVote (VoteBegin ri endTime en) = void $ outputAll $ do mds <- getIntermediateResults en let mbs = map getBooleanResult <$> mds pns <- getAllPlayerNumbers case mbs of - Just bs -> showOnGoingVote (getVotes pns bs) rn + Just bs -> showOnGoingVote (getVotes pns bs) (_rNumber ri) endTime Nothing -> return "" getVotes :: [PlayerNumber] -> [(PlayerNumber, Bool)] -> [(PlayerNumber, Maybe Bool)] @@ -152,14 +183,20 @@ Just a -> (pn, a) Nothing -> error "incorrect vote field" -showOnGoingVote :: [(PlayerNumber, Maybe Bool)] -> RuleNumber -> NomexNE String -showOnGoingVote [] rn = return $ "Votes for rule #" ++ (show rn) ++ ": Nobody voted yet" -showOnGoingVote listVotes rn = do +showOnGoingVote :: [(PlayerNumber, Maybe Bool)] -> RuleNumber -> UTCTime -> NomexNE String +showOnGoingVote [] rn _ = return $ "Nobody voted yet for rule #" ++ (show rn) ++ "." +showOnGoingVote listVotes rn endTime = do list <- mapM showVote listVotes - return $ "Votes for rule #" ++ (show rn) ++ ":" ++ "\n" ++ concatMap (\(name, vote) -> name ++ "\t" ++ vote ++ "\n") list + let timeString = formatTime defaultTimeLocale "on %d/%m at %H:%M UTC" endTime + return $ "Votes for rule #" ++ (show rn) ++ ", finishing " ++ timeString ++ "\n" ++ + concatMap (\(name, vote) -> name ++ "\t" ++ vote ++ "\n") list -showFinishedVote :: RuleNumber -> Bool -> [(PlayerNumber, Maybe Bool)] -> NomexNE String -showFinishedVote rn passed l = do +-- | display a finished vote +displayFinishedVote :: VoteEnd -> Nomex () +displayFinishedVote (VoteEnd ri vs passed end) = void $ outputAll $ showFinishedVote (_rNumber ri) passed vs end + +showFinishedVote :: RuleNumber -> Bool -> [(PlayerNumber, Maybe Bool)] -> UTCTime -> NomexNE String +showFinishedVote rn passed l _ = do let title = "Vote finished for rule #" ++ (show rn) ++ ", passed: " ++ (show passed) let voted = filter (\(_, r) -> isJust r) l votes <- mapM showVote voted