module Language.Nomyx.Vote where
import Prelude hiding (foldr)
import Language.Nomyx.Expression
import Language.Nomyx.Events
import Language.Nomyx.Inputs
import Language.Nomyx.Players
import Language.Nomyx.Rules
import Control.Monad.State hiding (forM_)
import Data.Maybe
import Data.Time hiding (getCurrentTime)
import Control.Arrow
import Control.Applicative
import Data.List
import qualified Data.Map as M
type AssessFunction = VoteStats -> Maybe Bool
data VoteStats = VoteStats { voteCounts :: M.Map (Maybe Bool) Int,
nbParticipants :: Int,
voteFinished :: Bool}
deriving (Show)
unanimityVote :: Nomex ()
unanimityVote = onRuleProposed $ callVoteRule unanimity oneDay
callVoteRule :: AssessFunction -> NominalDiffTime -> RuleInfo -> Nomex ()
callVoteRule assess delay ri = do
endTime <- addUTCTime delay <$> liftEffect getCurrentTime
callVoteRule' assess endTime ri
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)
callVote :: AssessFunction -> UTCTime -> String -> (Bool -> Nomex ()) -> Nomex ()
callVote assess endTime title payload = do
pns <- liftEffect getAllPlayerNumbers
void $ onEventOnce (voteWith endTime pns assess title) payload
voteWith :: UTCTime -> [PlayerNumber] -> AssessFunction -> String -> Event Bool
voteWith timeLimit pns assess title = shortcutEvents (voteEvents timeLimit title pns) (assess . getVoteStats (length pns))
voteEvents :: UTCTime -> String -> [PlayerNumber] -> [Event (Maybe Bool)]
voteEvents time title pns = map (singleVote time title) pns
singleVote :: UTCTime -> String -> PlayerNumber -> Event (Maybe Bool)
singleVote timeLimit title pn = (Just <$> inputRadio pn title [(True, "For"), (False, "Against")]) <|> (Nothing <$ timeEvent timeLimit)
unanimity :: AssessFunction
unanimity voteStats = voteQuota (nbVoters voteStats) voteStats
majority :: AssessFunction
majority voteStats = voteQuota ((nbVoters voteStats) `div` 2 + 1) voteStats
majorityWith :: Int -> AssessFunction
majorityWith x voteStats = voteQuota ((nbVoters voteStats) * x `div` 100 + 1) voteStats
numberVotes :: Int -> AssessFunction
numberVotes x voteStats = voteQuota x voteStats
withQuorum :: AssessFunction -> Int -> AssessFunction
withQuorum f minNbVotes = \voteStats -> if (voted voteStats) >= minNbVotes
then f voteStats
else if voteFinished voteStats then Just False else Nothing
getVoteStats :: Int -> [Maybe Bool] -> VoteStats
getVoteStats npPlayers votes = VoteStats
{voteCounts = M.fromList $ counts votes,
nbParticipants = npPlayers,
voteFinished = length votes == npPlayers}
counts :: (Eq a, Ord a) => [a] -> [(a, Int)]
counts as = map (head &&& length) (group $ sort as)
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 voteStats
nbVoters :: VoteStats -> Int
nbVoters vs
| voteFinished vs = (nbParticipants vs) (notVoted vs)
| otherwise = nbParticipants vs
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)