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.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 diff --git a/src/Language/Nomyx/Events.hs b/src/Language/Nomyx/Events.hs --- a/src/Language/Nomyx/Events.hs +++ b/src/Language/Nomyx/Events.hs @@ -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 + + 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 @@ -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 diff --git a/src/Language/Nomyx/Expression.hs b/src/Language/Nomyx/Expression.hs --- a/src/Language/Nomyx/Expression.hs +++ b/src/Language/Nomyx/Expression.hs @@ -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] ) diff --git a/src/Language/Nomyx/Inputs.hs b/src/Language/Nomyx/Inputs.hs --- a/src/Language/Nomyx/Inputs.hs +++ b/src/Language/Nomyx/Inputs.hs @@ -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) 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 @@ -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 { 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 @@ -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) - -