module Language.Nomyx.Rule where
import Prelude hiding (foldr)
import Language.Nomyx.Expression
import Language.Nomyx.Definition
import Data.Typeable
import Control.Monad.State hiding (forM_)
import Data.Maybe
import Data.Time hiding (getCurrentTime)
import Control.Arrow
import Control.Applicative
import Data.Lens
import Data.Foldable hiding (and, mapM_)
import Data.Boolean
autoActivate :: RuleFunc
autoActivate = voidRule $ onEvent_ (RuleEv Proposed) (activateRule_ . _rNumber . ruleData)
legal :: RuleFunc
legal = return $ Meta (\_ -> return $ BoolResp True)
illegal :: RuleFunc
illegal = return $ Meta (\_ -> return $ BoolResp False)
checkWithMetarules :: Rule -> Nomex BoolResp
checkWithMetarules rule = do
rs <- getActiveRules
(metas :: [Rule -> Nomex BoolResp]) <- mapMaybeM maybeMetaRule rs
let (evals :: [Nomex BoolResp]) = map (\meta -> meta rule) metas
foldr (&&*) true evals
maybeMetaRule :: Rule -> Nomex (Maybe (Rule -> Nomex BoolResp))
maybeMetaRule Rule {_rRuleFunc = rule} = do
meta <- rule
case meta of
(Meta m) -> return $ Just m
_ -> return Nothing
onRuleProposed :: (Rule -> Nomex BoolResp) -> RuleFunc
onRuleProposed r = voidRule $ onEvent_ (RuleEv Proposed) $ \(RuleData rule) -> do
resp <- r rule
case resp of
BoolResp b -> activateOrReject rule b
MsgResp m -> onMessageOnce m $ (activateOrReject rule) . messageData
data ForAgainst = For | Against deriving (Typeable, Enum, Show, Eq, Bounded, Read)
type Vote = (PlayerNumber, Maybe ForAgainst)
type CountVotes = [Vote] -> Maybe Bool
data VoteData = VoteData { msgEnd :: Event (Message Bool),
voteVar :: ArrayVar PlayerNumber ForAgainst,
inputNumbers :: [EventNumber],
assessFunction :: CountVotes}
type Assessor a = StateT VoteData Nomex a
voteWith :: CountVotes -> Assessor () -> Rule -> Nomex BoolResp
voteWith assessFunction assessors rule = do
pns <- getAllPlayerNumbers
let rn = show $ _rNumber rule
let msgEnd = Message ("Result of votes for " ++ rn) :: Event(Message Bool)
voteVar <- newArrayVar ("Votes for rule " ++ rn) pns
let askPlayer pn = onInputChoiceOnce ("Vote for rule " ++ rn) [For, Against] (putArrayVar voteVar pn) pn
inputs <- mapM askPlayer pns
let voteData = VoteData msgEnd voteVar inputs assessFunction
evalStateT assessors voteData
cleanVote voteData
return $ MsgResp msgEnd
assessOnEveryVotes :: Assessor ()
assessOnEveryVotes = do
(VoteData msgEnd voteVar _ assess) <- get
lift $ do
msgVotes <- getArrayVarMessage voteVar
onMessage msgVotes $ \(MessageData votes) -> maybeWhen (assess votes) $ sendMessage msgEnd
assessOnTimeLimit :: UTCTime -> Assessor ()
assessOnTimeLimit time = do
(VoteData msgEnd voteVar _ assess) <- get
lift $ do
onEvent_ (Time time) $ \_ -> do
votes <- getArrayVarData voteVar
let result = assess $ getOnlyVoters $ votes
when (result == Nothing) $ outputAll "Vote: Quorum not reached, rule is rejected"
sendMessage msgEnd $ fromMaybe False $ result
assessOnTimeDelay :: NominalDiffTime -> Assessor ()
assessOnTimeDelay delay = do
t <- addUTCTime delay <$> lift getCurrentTime
assessOnTimeLimit t
assessWhenEverybodyVoted :: Assessor ()
assessWhenEverybodyVoted = do
(VoteData msgEnd voteVar _ assess) <- get
lift $ do
msgVotes <- getArrayVarMessage voteVar
onMessage msgVotes $ \(MessageData votes) -> when (length (voters votes) == length votes) $
sendMessage msgEnd $ fromJust $ assess $ votes
noStatusQuo :: [Vote] -> [Vote]
noStatusQuo = map noVoteCountAsAgainst where
noVoteCountAsAgainst :: Vote -> Vote
noVoteCountAsAgainst (a, Nothing) = (a, Just Against)
noVoteCountAsAgainst a = a
cleanVote :: VoteData -> Nomex ()
cleanVote (VoteData msgEnd voteVar inputsNumber _) = onMessage msgEnd$ \_ -> do
delAllEvents msgEnd
delArrayVar voteVar
mapM_ delEvent inputsNumber
assessOnlyVoters :: CountVotes -> CountVotes
assessOnlyVoters assess vs = assess $ map (second Just) $ voters vs
quorum :: Int -> [Vote] -> Bool
quorum q vs = (length $ voters vs) >= q
withQuorum :: CountVotes -> Int -> CountVotes
withQuorum assess q vs = if (quorum q vs) then assess vs else Nothing
unanimity :: [Vote] -> Maybe Bool
unanimity votes = voteQuota (length votes) votes
majority :: [Vote] -> Maybe Bool
majority votes = voteQuota ((length votes) `div` 2 + 1) votes
majorityWith :: Int -> [Vote] -> Maybe Bool
majorityWith x votes = voteQuota ((length votes) * x `div` 100 + 1) votes
numberPositiveVotes :: Int -> [Vote] -> Maybe Bool
numberPositiveVotes = voteQuota
voteQuota :: Int -> [Vote] -> Maybe Bool
voteQuota quotaFor votes
| nbFor votes >= quotaFor = Just True
| nbAgainst votes > (length votes) quotaFor = Just False
| otherwise = Nothing
nbFor, nbAgainst :: [Vote] -> Int
nbFor = length . filter ((== Just For) . snd)
nbAgainst = length . filter ((== Just Against) . snd)
voters :: [(PlayerNumber, Maybe ForAgainst)] -> [(PlayerNumber, ForAgainst)]
voters vs = catMaybes $ map voter vs where
voter (pn, Just fa) = Just (pn, fa)
voter (_, Nothing) = Nothing
getOnlyVoters :: [(PlayerNumber, Maybe ForAgainst)] -> [(PlayerNumber, Maybe ForAgainst)]
getOnlyVoters vs = map (second Just) $ voters vs
activateOrReject :: Rule -> Bool -> Nomex ()
activateOrReject r b = if b then activateRule_ (_rNumber r) else rejectRule_ (_rNumber r)
forEachPlayer :: (PlayerNumber -> Nomex ()) -> (PlayerNumber -> Nomex ()) -> (PlayerNumber -> Nomex ()) -> Nomex ()
forEachPlayer action actionWhenArrive actionWhenLeave = do
pns <- getAllPlayerNumbers
mapM_ action pns
onEvent_ (Player Arrive) $ \(PlayerData p) -> actionWhenArrive $ _playerNumber p
onEvent_ (Player Leave) $ \(PlayerData p) -> actionWhenLeave $ _playerNumber p
forEachPlayer_ :: (PlayerNumber -> Nomex ()) -> Nomex ()
forEachPlayer_ action = forEachPlayer action action (\_ -> return ())
createValueForEachPlayer :: Int -> V [(Int, Int)] -> Nomex ()
createValueForEachPlayer initialValue var = do
pns <- getAllPlayerNumbers
v <- newVar_ (varName var) $ map (,initialValue::Int) pns
forEachPlayer (\_-> return ())
(\p -> modifyVar v ((p, initialValue) : ))
(\p -> modifyVar v $ filter $ (/= p) . fst)
createValueForEachPlayer_ :: V [(Int, Int)] -> Nomex ()
createValueForEachPlayer_ = createValueForEachPlayer 0
modifyValueOfPlayer :: PlayerNumber -> V [(Int, Int)] -> (Int -> Int) -> Nomex ()
modifyValueOfPlayer pn var f = modifyVar var $ map $ (\(a,b) -> if a == pn then (a, f b) else (a,b))
modifyAllValues :: V [(Int, Int)] -> (Int -> Int) -> Nomex ()
modifyAllValues var f = modifyVar var $ map $ second f
noPlayPlayer :: PlayerNumber -> RuleFunc
noPlayPlayer p = return $ Meta $ \r -> return $ BoolResp $ (_rProposedBy r) /= p
autoDelete :: Nomex ()
autoDelete = getSelfRuleNumber >>= suppressRule_
eraseAllRules :: PlayerNumber -> Nomex Bool
eraseAllRules p = do
rs <- getRules
let myrs = filter ((== p) . getL rProposedBy) rs
res <- mapM (suppressRule . _rNumber) myrs
return $ and res
oneDay :: NominalDiffTime
oneDay = 60 * 60 * 24
maybeWhen :: Maybe a -> (a -> Nomex ()) -> Nomex ()
maybeWhen = forM_