Nomyx-Language 0.6.1 → 0.6.2

raw patch · 7 files changed

+148/−311 lines, 7 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• Nomyx-Language.cabal +2/−2
• src/Language/Nomyx/Events.hs +12/−1
• src/Language/Nomyx/Examples.hs +13/−13
• src/Language/Nomyx/Expression.hs +34/−7
• src/Language/Nomyx/Inputs.hs +8/−8
• src/Language/Nomyx/Rules.hs +7/−4
• src/Language/Nomyx/Vote.hs +72/−276

@@ -1,5 +1,5 @@ name: Nomyx-Language-version: 0.6.1+version: 0.6.2 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)@@ -10,7 +10,7 @@ maintainer: Corentin Dupont stability: Experimental synopsis: Language to express rules for Nomic-description: Provide a DSL to express rules for a Nomic game, with evaluation engine. See package Nomyx for a full game implementation.+description: Provide a DSL to express rules in a Nomic game. See package Nomyx for a full game implementation. category: Language Homepage: http://www.nomyx.net author: Corentin Dupont

@@ -10,7 +10,8 @@    getCurrentTime,    oneWeek, oneDay, oneHour, oneMinute,    timeEvent, messageEvent, victoryEvent, playerEvent, ruleEvent,-   baseEvent, baseInputEvent+   baseEvent, baseInputEvent,+   shortcutEvents    ) where 
 import Language.Nomyx.Expression@@ -110,13 +111,23 @@  timeEvent :: UTCTime -> Event UTCTime timeEvent = BaseEvent . Time+ messageEvent :: (Typeable a) => Msg a -> Event a messageEvent = BaseEvent . Message++victoryEvent :: Event VictoryCond victoryEvent = BaseEvent Victory+ playerEvent :: Player -> Event PlayerInfo playerEvent = BaseEvent . Player+ ruleEvent :: RuleEvent -> Event RuleInfo ruleEvent re = BaseEvent $ RuleEv re  baseInputEvent :: (Typeable a) => PlayerNumber -> String -> (InputForm a) -> Field a baseInputEvent pn s iform = Input Nothing pn s iform++shortcutEvents :: [Event a] -> ([a] -> Maybe b) -> Event b+shortcutEvents = ShortcutEvents++

@@ -25,9 +25,9 @@    victoryXEcu,    --noGroupVictory,    banPlayer,-   referendum,-   referendumOnKickPlayer,-   gameMasterElections,+--   referendum,+--   referendumOnKickPlayer,+--   gameMasterElections,    gameMaster,    bravoButton,    enterHaiku,@@ -112,7 +112,7 @@ monarchy :: Rule monarchy = void $ onEvent_ (ruleEvent Proposed) $ \rule -> do     k <- readMsgVar_ king-    void $ onInputRadioOnce ("Your Royal Highness, do you accept rule " ++ (show $ _rNumber rule) ++ "?") [True, False] (activateOrReject rule) k+    void $ onInputRadioOnce ("Your Royal Highness, do you accept rule " ++ (show $ _rNumber rule) ++ "?") [True, False] (activateOrRejectRule rule) k  -- | Revolution! Hail to the king! -- This rule suppresses the democracy (usually rules 1 and 2), installs the king and activates monarchy.@@ -161,7 +161,7 @@ -- the vote is assessed after every vote in case the winner is already known -- the vote will finish anyway after one day voteWithMajority :: Rule-voteWithMajority = onRuleProposed $ voteWith_ (majority `withQuorum` 2) $ assessOnEveryVote >> assessOnTimeDelay oneDay+voteWithMajority = onRuleProposed $ callVoteRule (majority `withQuorum` 2) oneDay  -- | Change current system (the rules passed in parameter) to absolute majority (half participants plus one) returnToDemocracy :: [RuleNumber] -> Rule@@ -180,14 +180,14 @@ -- * Referendum & elections  -- | triggers a referendum, if the outcome is yes player 2 will be kicked-referendumOnKickPlayer :: Rule-referendumOnKickPlayer = referendum " kick player 2" (void $ delPlayer 2)---- | triggers elections (all players are candidates), the winner becomes game master-gameMasterElections :: Rule-gameMasterElections = do-   pls <- liftEffect getPlayers-   elections "Game Master" pls makeGM+--referendumOnKickPlayer :: Rule+--referendumOnKickPlayer = referendum " kick player 2" (void $ delPlayer 2)+--+---- | triggers elections (all players are candidates), the winner becomes game master+--gameMasterElections :: Rule+--gameMasterElections = do+--   pls <- liftEffect getPlayers+--   elections "Game Master" pls makeGM  makeGM :: PlayerNumber -> Nomex () makeGM pn = do

@@ -54,7 +54,8 @@    DelVar         :: (V a) -> Nomex Bool
    --Events management    OnEvent        :: (Typeable e, Show e) => Event e -> ((EventNumber, e) -> Nomex ()) -> Nomex EventNumber
-   DelEvent       :: EventNumber -> Nomex Bool
+   DelEvent       :: EventNumber -> Nomex Bool+   GetEvents      :: NomexNE [EventInfo]
    SendMessage    :: (Typeable a, Show a) => Msg a -> a -> Nomex ()
    --Rules management
    ProposeRule    :: RuleInfo -> Nomex Bool
@@ -129,11 +130,12 @@  -- | Composable events data Event a where-   SumEvent   :: Event a -> Event a -> Event a        -- The first event to fire will be returned-   AppEvent   :: Event (a -> b) -> Event a -> Event b -- Both events should fire, and then the result is returned-   PureEvent  :: a -> Event a                         -- Create a fake event. The result is useable with no delay.-   EmptyEvent :: Event a                              -- An event that is never fired.-   BaseEvent  :: (Typeable a) => Field a -> Event a   -- Embed a base event+   SumEvent       :: Event a -> Event a -> Event a            -- The first event to fire will be returned+   AppEvent       :: Event (a -> b) -> Event a -> Event b     -- Both events should fire, and then the result is returned+   PureEvent      :: a -> Event a                             -- Create a fake event. The result is useable with no delay.+   EmptyEvent     :: Event a                                  -- An event that is never fired.+   ShortcutEvents :: [Event a] -> ([a] -> Maybe b) -> Event b -- a result is returned as soon as it can be computed, dismissing the events that hasn't fired yet+   BaseEvent      :: (Typeable a) => Field a -> Event a       -- Embed a base event    deriving Typeable  -- | Base events@@ -181,6 +183,31 @@    (<|>) = SumEvent    empty = EmptyEvent +-- EventInfo++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++type EventHandler e = (EventNumber, e) -> Nomex ()++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++ -- * Rule
 
 -- | Type of a rule function.@@ -234,5 +261,5 @@ concatMapM        :: (Monad m) => (a -> m [b]) -> [a] -> m [b] concatMapM f xs   =  liftM concat (mapM f xs)
 -$( makeLenses [''RuleInfo, ''PlayerInfo] )
+$( makeLenses [''RuleInfo, ''PlayerInfo, ''EventInfo] )
 

@@ -28,21 +28,21 @@ 
 -- | triggers a choice input to the user. The result will be sent to the callback
 onInputRadio :: (Typeable a, Eq a,  Show a) => String -> [a] -> (EventNumber -> a -> Nomex ()) -> PlayerNumber -> Nomex EventNumber
-onInputRadio title choices handler pn = onEvent (inputRadioHead pn title choices) (\(en, a) -> handler en a)
+onInputRadio title choices handler pn = onEvent (inputRadio' pn title choices) (\(en, a) -> handler en a)
 
 -- | the same, disregard the event number
 onInputRadio_ :: (Typeable a, Eq a, Show a) => String -> [a] -> (a -> Nomex ()) -> PlayerNumber -> Nomex EventNumber
-onInputRadio_ title choices handler pn = onEvent_ (inputRadioHead pn title choices) handler
+onInputRadio_ title choices handler pn = onEvent_ (inputRadio' pn title choices) handler
 
 -- | the same, suppress the event after first trigger
 onInputRadioOnce :: (Typeable a, Eq a, Show a) => String -> [a] -> (a -> Nomex ()) -> PlayerNumber -> Nomex EventNumber
-onInputRadioOnce title choices handler pn = onEventOnce (inputRadioHead pn title choices) handler
-
-inputRadioHead :: (Eq c, Show c, Typeable c) => PlayerNumber -> String -> [c] -> Event c
-inputRadioHead pn title choices = inputRadio pn title choices (head choices)
+onInputRadioOnce title choices handler pn = onEventOnce (inputRadio' pn title choices) handler
 -inputRadio :: (Eq c, Show c, Typeable c) => PlayerNumber -> String -> [c] -> c -> Event c
-inputRadio pn title cs _ = baseEvent $ baseInputRadio pn title (zip cs (show <$> cs))+inputRadio :: (Eq c, Show c, Typeable c) => PlayerNumber -> String -> [(c, String)] -> Event c
+inputRadio pn title cs = baseEvent $ baseInputRadio pn title cs++inputRadio' :: (Eq c, Show c, Typeable c) => PlayerNumber -> String -> [c] -> Event c
+inputRadio' pn title cs = inputRadio pn title (zip cs (show <$> cs))  baseInputRadio :: (Eq c, Show c, Typeable c) => PlayerNumber -> String -> [(c, String)] -> Field c
 baseInputRadio pn title cs = baseInputEvent pn title (Radio cs)

@@ -21,13 +21,14 @@    suppressRule, suppressRule_, suppressAllRules,    modifyRule,    autoActivate,-   activateOrReject,+   activateOrRejectRule,    simulate,    metaruleVar, createMetaruleVar, addMetarule, testWithMetaRules, displayMetarules,    legal, illegal, noPlayPlayer, immutableRule,    autoDelete,    eraseAllRules,    getSelfRuleNumber, getSelfRule,+   onRuleProposed,    showRule    ) where @@ -124,8 +125,8 @@    return rs  -- | activate or reject a rule-activateOrReject :: RuleInfo -> Bool -> Nomex ()-activateOrReject r b = if b then activateRule_ (_rNumber r) else rejectRule_ (_rNumber r)+activateOrRejectRule :: RuleInfo -> Bool -> Nomex ()+activateOrRejectRule r b = if b then activateRule_ (_rNumber r) else rejectRule_ (_rNumber r)  -- | a rule can autodelete itself (generaly after having performed some actions) autoDelete :: Nomex ()@@ -197,7 +198,9 @@ simulate :: Nomex a -> NomexNE Bool -> NomexNE Bool simulate sim test = Simu sim test -+-- | sets a callback called for each rule proposed+onRuleProposed :: (RuleInfo -> Nomex ()) -> Nomex ()
+onRuleProposed f = void $ onEvent_ (ruleEvent Proposed) f  -- | a default rule
 defaultRule = RuleInfo  {

@@ -11,315 +11,111 @@ import Prelude hiding (foldr)
 import Language.Nomyx.Expression
 import Language.Nomyx.Events-import Language.Nomyx.Variables-import Language.Nomyx.Outputs import Language.Nomyx.Inputs import Language.Nomyx.Players import Language.Nomyx.Rules
-import Data.Typeable
 import Control.Monad.State hiding (forM_)
 import Data.Maybe import Data.Time hiding (getCurrentTime)-import Data.Traversable hiding (mapM) import Control.Arrow
 import Control.Applicative
 import Data.List-import Data.Function import qualified Data.Map as M-import Control.Monad.Error (MonadError(..)) -+-- | a vote assessing function (such as unanimity, majority...)+type AssessFunction = VoteStats -> Maybe Bool -data VoteType a = ExclusiveVote (Maybe (Alts a))-                | NonExclusiveVote [Alts a]+-- | the vote statistics, including the number of votes per choice (Nothing means abstention),+-- the number of persons called to vote, and if the vote if finished (timeout or everybody voted)+data VoteStats = VoteStats { voteCounts     :: M.Map (Maybe Bool) Int,+                             nbParticipants :: Int,+                             voteFinished   :: Bool}+                             deriving (Show) -class (Eq (Alts a), Show (Alts a), Ord (Alts a), Typeable a) => Votable a where-   data Alts a-   alts :: [Alts a]                                -- The alternatives-   quota :: Alts a -> Int -> Int -> Int            -- "quota alts q total" gives the quota to reach for each alternatives-   name :: a -> String-   exclusiveWinner :: a ->  Maybe (Alts a, Alts a) --The Votable as only two alternatives, one excluding the other-   exclusiveWinner _ = Nothing+-- | vote at unanimity every incoming rule+unanimityVote :: Nomex ()+unanimityVote = onRuleProposed $ callVoteRule unanimity oneDay -type ForAgainst = Alts RuleInfo
-instance Votable RuleInfo where-   data Alts RuleInfo = For | Against deriving (Typeable, Enum, Show, Eq, Bounded, Read, Ord)-   alts = [For, Against]-   quota For q _ = q-   quota Against q vs = vs - q + 1-   name r = "rule " ++ (show $ _rNumber r)-   exclusiveWinner _ = Just (For, Against)+-- | call a vote on a rule for every players, with an assessing function and a delay+callVoteRule :: AssessFunction -> NominalDiffTime -> RuleInfo -> Nomex ()+callVoteRule assess delay ri = do+   endTime <- addUTCTime delay <$> liftEffect getCurrentTime+   callVoteRule' assess endTime ri -
-type Vote a = (PlayerNumber, Maybe (Alts a))-type VoteResult a = VoteStats a -> [Alts a]
-data VoteStats a = VoteStats { voteCounts :: M.Map (Maybe (Alts a)) Int,-                               voteFinished :: Bool}+callVoteRule' :: AssessFunction -> UTCTime -> RuleInfo -> Nomex ()+callVoteRule' assess endTime ri = do+   let title = "Vote for rule: \"" ++ (_rName ri) ++ "\" (#" ++ (show $ _rNumber ri) ++ "):"+   callVote assess endTime title (activateOrRejectRule ri) -data VoteData a = VoteData { msgEnd :: Msg [Alts a],                   -- message sent when the vote is finished with the winners
-                             voteVar :: ArrayVar PlayerNumber (Alts a),-- variable containing the votes
-                             inputNumbers :: [EventNumber],            -- numbers of the toggle inputs of the players (to delete them at the end of vote)
-                             assessFunction :: VoteResult a,           -- function used to count the votes-                             timeLimit :: Maybe UTCTime}               -- end of the vote-                             
-type Assessor a = StateT (VoteData a) Nomex ()
+-- | call a vote for every players, with an assessing function, a delay and a function to run on the result+callVote :: AssessFunction -> UTCTime -> String -> (Bool -> Nomex ()) -> Nomex ()+callVote assess endTime title payload = do+   pns <- liftEffect getAllPlayerNumbers+   void $ onEventOnce (voteWith endTime pns assess title) payload ---TODO: decorelate effects and non effects--- | Perform a vote.-voteWith :: (Votable a) => VoteResult a         -- ^ the function used to count the votes.-                        -> Assessor a           -- ^ assessors: when and how to perform the vote assessment (several assessors can be chained).-                        -> a                    -- ^ toVote: the matter to be voted.-                        -> [Alts a]             -- ^ the vote alternatives.-                        -> Nomex (Msg [Alts a]) -- ^ return value: a message containing the result of the vote. 
-voteWith countVotes assessors toVote als = do
-    pns <- liftEffect getAllPlayerNumbers
-    let toVoteName = name toVote
-    let msgEnd = Msg ("Result of votes for " ++ toVoteName) :: Msg [Alts a]
-    --create an array variable to store the votes
-    (voteVar :: ArrayVar PlayerNumber (Alts a)) <- newArrayVar_ ("Votes for " ++ toVoteName) pns
-    --create the voting buttons-    let askPlayer pn = onInputRadioOnce ("Vote for " ++ toVoteName ++ ":") als (putArrayVar_ voteVar pn) pn
-    inputs <- mapM askPlayer pns
-    let voteData = VoteData msgEnd voteVar inputs countVotes Nothing
-    --set the assessors-    evalStateT assessors voteData-    --display the vote-    displayVoteVar Nothing ("On-going vote for " ++ toVoteName ++ ":") voteVar-    displayVoteResult toVoteName voteData-    --clean the vote at the end-    cleanVote voteData-    return msgEnd+-- vote with a function able to assess the ongoing votes.+-- the vote can be concluded as soon as the result is known.+voteWith :: UTCTime -> [PlayerNumber] -> AssessFunction -> String -> Event Bool+voteWith timeLimit pns assess title = shortcutEvents (voteEvents timeLimit title pns) (assess . getVoteStats (length pns)) --- | Performs a vote, all the possible alternatives are selected.-voteWith_ :: (Votable a) => VoteResult a -> Assessor a -> a -> Nomex (Msg [Alts a]) 
-voteWith_ assessFunction assessors toVote = voteWith assessFunction assessors toVote alts
+-- list of vote events+voteEvents :: UTCTime -> String -> [PlayerNumber] -> [Event (Maybe Bool)]+voteEvents time title pns = map (singleVote time title) pns -
--- | assess the vote on every new vote with the assess function, and as soon as the vote has an issue (positive of negative), sends a signal
-assessOnEveryVote :: (Votable a) => Assessor a
-assessOnEveryVote = do
-   (VoteData msgEnd voteVar _ assess _) <- get
-   lift $ void $ onMsgVarEvent voteVar $ f assess msgEnd where-      f assess msgEnd (VUpdated votes) = do-         let res = assess $ getVoteStats votes False-         unless (null res) $ sendMessage msgEnd res-      f _ _ _ = return ()   
-
-
--- | assess the vote with the assess function when time is reached, and sends a signal with the issue (positive of negative)
-assessOnTimeLimit :: (Votable a) => UTCTime -> Assessor a
-assessOnTimeLimit time = do
-   (VoteData msgEnd voteVar i assess _) <- get-   put (VoteData msgEnd voteVar i assess (Just time))
-   lift $ void $ onEvent_ (timeEvent time) $ \_ -> do
-      votes <- getMsgVarData_ voteVar
-      sendMessage msgEnd (assess $ getVoteStats votes True)
+-- trigger the display of a radio button choice on the player screen, yelding either Just True or Just False.+-- after the time limit, the value sent back is Nothing.+singleVote :: UTCTime -> String -> PlayerNumber -> Event (Maybe Bool)+singleVote timeLimit title pn = (Just <$> inputRadio pn title [(True, "For"), (False, "Against")]) <|> (Nothing <$ timeEvent timeLimit) -   
--- | assess the vote with the assess function when time is elapsed, and sends a signal with the issue (positive of negative)
-assessOnTimeDelay :: (Votable a) => NominalDiffTime -> Assessor a
-assessOnTimeDelay delay = do
-   t <- addUTCTime delay <$> lift (liftEffect getCurrentTime)
-   assessOnTimeLimit t
-
--- | assess the vote only when every body voted. An error is generated if the assessing function returns Nothing.
-assessWhenEverybodyVoted :: (Votable a) => Assessor a
-assessWhenEverybodyVoted = do
-   (VoteData msgEnd voteVar _ assess _) <- get
-   lift $ void $ onMsgVarEvent voteVar $ f assess msgEnd where-      f assess msgEnd (VUpdated votes) = when (all isJust (map snd votes)) $ sendMessage msgEnd $ assess $ getVoteStats votes True
-      f _ _ _ = return ()
-
--- | clean events and variables necessary for the vote
-cleanVote :: (Votable a) => VoteData a -> Nomex EventNumber
-cleanVote (VoteData msgEnd voteVar inputsNumber _ _) = onMessageOnce msgEnd $ \_ -> do
-   delMsgVar voteVar
-   mapM_ delEvent inputsNumber
-
--- | a quorum is the neccessary number of voters for the validity of the vote
-quorum :: (Votable a) => Int -> VoteStats a -> Bool
-quorum q vs = (voted vs) >= q
-
--- | adds a quorum to an assessing function
-withQuorum :: (Votable a) => VoteResult a -> Int -> VoteResult a
-withQuorum assess q vs = if quorum q vs then assess vs else []
+-- | assess the vote results according to a unanimity+unanimity :: AssessFunction+unanimity voteStats = voteQuota (nbVoters voteStats) voteStats --- | assess the vote results according to a unanimity (everybody votes for)
-unanimity :: (Votable a) => VoteStats a -> [Alts a]
-unanimity vs = voteQuota (nbVoters vs) vs
-  
--- | assess the vote results according to an absolute majority (half voters plus one, no quorum is needed)
-majority :: (Votable a) => VoteStats a -> [Alts a]
-majority vs = voteQuota ((nbVoters vs) `div` 2 + 1) vs
-
+-- | assess the vote results according to an absolute majority (half voters plus one)
+majority :: AssessFunction
+majority voteStats = voteQuota ((nbVoters voteStats) `div` 2 + 1) voteStats+                       
 -- | assess the vote results according to a majority of x (in %)
-majorityWith :: (Votable a) => Int -> VoteStats a -> [Alts a]
-majorityWith x vs = voteQuota ((nbVoters vs) * x `div` 100 + 1) vs
-
--- | assess the vote results according to a necessary number of positive votes
-numberVotes :: (Votable a) => Int -> VoteStats a -> [Alts a]
-numberVotes = voteQuota
---- | the winners are the x vote alternatives with the more votes
-firstXBest :: forall a. (Votable a) => Int -> VoteStats a -> [Alts a]
-firstXBest x votes = map fst $ takeInGroups x sortedVotesWithExAequoGroups where-   voted (Just a, n) = Just (a, n)-   voted (Nothing, _) = Nothing-   sortedVotesWithExAequoGroups :: [[(Alts a, Int)]]-   sortedVotesWithExAequoGroups = groupBy ((==) `on` snd) $ sortWith snd $ mapMaybe voted $ M.assocs (voteCounts votes)+majorityWith :: Int -> AssessFunction
+majorityWith x voteStats = voteQuota ((nbVoters voteStats) * x `div` 100 + 1) voteStats ---take n elements from the first lists, but do not break groups-takeInGroups :: Int -> [[a]] -> [a]-takeInGroups 0 _ = []-takeInGroups n grps = if grpsSize <= n then head grps ++ takeInGroups (n - grpsSize) (tail grps) else head grps where-   grpsSize = length $ head grps+-- | assess the vote results according to a fixed number of positive votes+numberVotes :: Int -> AssessFunction+numberVotes x voteStats = voteQuota x voteStats+
+-- | adds a quorum to an assessing function
+withQuorum :: AssessFunction -> Int -> AssessFunction
+withQuorum f minNbVotes = \voteStats -> if (voted voteStats) >= minNbVotes+                                        then f voteStats+                                        else if voteFinished voteStats then Just False else Nothing --- | the winner is the vote alternative with the more votes
-firstBest :: (Votable a) => VoteStats a -> [Alts a]
-firstBest = firstXBest 1+getVoteStats :: Int -> [Maybe Bool] -> VoteStats+getVoteStats npPlayers votes = VoteStats+   {voteCounts   = M.fromList $ counts votes,+    nbParticipants = npPlayers,+    voteFinished = length votes == npPlayers} -sortWith :: Ord b => (a -> b) -> [a] -> [a]-sortWith f = sortBy (\x y -> compare (f x) (f y))-
--- | return the vote alternatives that are above threshold
-voteQuota :: forall a. (Votable a) => Int -> VoteStats a -> [Alts a]
-voteQuota q votes = case exclusiveWinner (undefined :: a) of-   Nothing -> catMaybes $ M.keys $ M.filter (>= q) (voteCounts votes)-   Just a -> maybeToList $ exclusiveVoteQuota q votes a+counts :: (Eq a, Ord a) => [a] -> [(a, Int)]+counts as = map (head &&& length) (group $ sort as) --- | in case of exclusive winner-exclusiveVoteQuota :: (Votable a) => Int -> VoteStats a -> (Alts a, Alts a) -> Maybe (Alts a)-exclusiveVoteQuota q votes (for, against)-   | M.findWithDefault 0 (Just for) vs     >= q                   = Just for-   | M.findWithDefault 0 (Just against) vs > (nbVoters votes) - q = Just against+-- | Compute a result based on a quota of positive votes.+-- the result can be positive if the quota if reached, negative if the quota cannot be reached anymore at that point, or still pending.+voteQuota :: Int -> VoteStats -> Maybe Bool+voteQuota q voteStats+   | M.findWithDefault 0 (Just True)  vs >= q                       = Just True+   | M.findWithDefault 0 (Just False) vs > (nbVoters voteStats) - q = Just False    | otherwise = Nothing-   where vs = voteCounts votes+   where vs = voteCounts voteStats   -- | number of people that voted if the voting is finished, -- total number of people that should vote otherwise-nbVoters :: (Votable a) => VoteStats a -> Int+nbVoters :: VoteStats -> Int nbVoters vs-   | voteFinished vs = (totalVoters vs) - (notVoted vs)-   | otherwise = totalVoters vs+   | voteFinished vs = (nbParticipants vs) - (notVoted vs)+   | otherwise = nbParticipants vs -totalVoters, voted, notVoted :: (Votable a) => VoteStats a -> Int+totalVoters, voted, notVoted :: VoteStats -> Int totalVoters vs = M.foldr (+) 0 (voteCounts vs) notVoted    vs = fromMaybe 0 $ M.lookup Nothing (voteCounts vs) voted       vs = (totalVoters vs) - (notVoted vs)---getVoteStats :: (Votable a) => [Vote a] -> Bool -> VoteStats a-getVoteStats vs voteFinished = VoteStats-   {voteCounts = M.fromList $ counts (snd <$> vs),-    voteFinished = voteFinished}--counts :: (Eq a, Ord a) => [a] -> [(a, Int)]-counts as = map (head &&& length) (group $ sort as)---displayVoteVar :: (Votable a) => (Maybe PlayerNumber) -> String -> ArrayVar PlayerNumber (Alts a) -> Nomex EventNumber-displayVoteVar mpn title mv = displayVar' mpn mv (showOnGoingVote title)--showChoice :: (Votable a) => Maybe (Alts a) -> String-showChoice (Just a) = show a-showChoice Nothing  = "Not Voted"--showChoices :: (Votable a) => [Alts a] -> String-showChoices [] = "no result"-showChoices cs = intercalate ", " $ map show cs--showOnGoingVote :: (Votable a) => String -> [(PlayerNumber, Maybe (Alts a))] -> NomexNE String-showOnGoingVote title listVotes = do-   list <- mapM showVote listVotes-   return $ title ++ "\n" ++ concatMap (\(name, vote) -> name ++ "\t" ++ vote ++ "\n") list--showFinishedVote :: (Votable a) =>  [(PlayerNumber, Maybe (Alts a))] -> NomexNE String-showFinishedVote l = do-   let voted = filter (\(_, r) -> isJust r) l-   votes <- mapM showVote voted-   return $ intercalate ", " $ map (\(name, vote) -> name ++ ": " ++ vote) votes--showVote :: (Votable a) => (PlayerNumber, Maybe (Alts a)) -> NomexNE (String, String)-showVote (pn, v) = do-   name <- showPlayer pn-   return (name, showChoice v)-                                              
-displayVoteResult :: (Votable a) => String -> VoteData a -> Nomex OutputNumber-displayVoteResult toVoteName (VoteData msgEnd voteVar _ _ _) = onMessage msgEnd $ \result -> do
-   vs <- getMsgVarData_ voteVar-   votes <- liftEffect $ showFinishedVote vs-   void $ outputAll_ $ "Vote result for " ++ toVoteName ++ ": " ++ showChoices result ++ " (" ++ votes ++ ")"---- | any new rule will be activate if the rule in parameter returns For
-onRuleProposed :: (RuleInfo -> Nomex (Msg [ForAgainst]) ) -> Rule
-onRuleProposed f = void $ onEvent_ (ruleEvent Proposed) $ \rule -> do
-    resp <- f rule-    void $ onMessageOnce resp $ (activateOrReject rule) . (== [For])---- * Referendum & elections--data Referendum = Referendum String deriving (Typeable)-instance Votable Referendum where-   data Alts Referendum = Yes | No deriving (Enum, Show, Eq, Bounded, Read, Ord)-   alts = [Yes, No]-   quota Yes q _ = q-   quota No q vs = vs - q + 1-   name (Referendum n) = "referendum on " ++ n--referendum :: String -> Nomex () -> Rule-referendum name action = do-   msg <- voteWith_ (majority `withQuorum` 2) (assessOnEveryVote >> assessOnTimeDelay oneDay) (Referendum name)-   void $ onMessageOnce msg resolution where-      resolution [Yes] = do-            outputAll_ "Positive result of referendum"-            action-      resolution [No] = void $ outputAll_ "Negative result of referendum"-      resolution []   = void $ outputAll_ "No result for referendum"-      resolution _    = throwError "Impossible result for referendum"---data Election = Election String deriving (Typeable)-instance Votable Election where-   data Alts Election = Candidate {candidate :: PlayerInfo}-   alts = map (\n -> Candidate (PlayerInfo n "" Nothing)) [1..]-   quota _ q _ = q-   name (Election n) = "elections on " ++ n--instance Show (Alts Election) where-   show (Candidate (PlayerInfo _ name _)) = name--instance Eq (Alts Election) where-   (Candidate (PlayerInfo pn1 _ _)) == (Candidate (PlayerInfo pn2 _ _)) = pn1 == pn2--instance Ord (Alts Election) where-   compare (Candidate (PlayerInfo pn1 _ _)) (Candidate (PlayerInfo pn2 _ _)) = compare pn1 pn2--elections :: String -> [PlayerInfo] -> (PlayerNumber -> Nomex ()) -> Nomex ()-elections name pns action = do-   msg <- voteWith majority (assessOnTimeDelay oneDay) (Election name) (Candidate <$> pns)-   void $ onMessageOnce msg resolution where-      resolution [Candidate pi] = do-         outputAll_ $ "Result of elections: player(s) " ++ (show $ _playerName pi) ++ " won!"-         action $ _playerNumber pi-      resolution [] = void $ outputAll_ "Result of elections: nobody won!"-      resolution _  = throwError "Impossible result for elections"--voteEvent :: UTCTime -> [PlayerNumber] -> Event ([Maybe Bool])-voteEvent time pns = sequenceA $ map (singleVote time) pns--singleVote :: UTCTime -> PlayerNumber -> Event (Maybe Bool)-singleVote timeLimit pn = (Just <$> inputRadio pn "Vote for "[True, False] True) <|> (Nothing <$ timeEvent timeLimit)--vote :: UTCTime -> [PlayerNumber] -> Event Bool-vote timeLimit pns = unanimity' <$> (voteEvent timeLimit pns)--unanimity' :: [Maybe Bool] -> Bool-unanimity' = all (== Just True)--callVote :: UTCTime -> Nomex ()-callVote t = do-   pns <- liftEffect getAllPlayerNumbers-   void $ onEventOnce (vote t pns) (outputAll_ . show)--