--do
module Language.Nomyx.Rules (
RuleNumber,
RuleCode,
RuleEvent(..),
RuleStatus(..),
MetaRule,
activateRule, activateRule_,
rejectRule, rejectRule_,
getRules, getActiveRules, getRule,
getRulesByNumbers,
getRuleFuncs,
addRule, addRule_, addRuleParams,
getFreeRuleNumber,
suppressRule, suppressRule_, suppressAllRules,
modifyRule,
autoActivate,
activateOrReject,
simulate,
metaruleVar, createMetaruleVar, addMetarule, testWithMetaRules,
legal, illegal, noPlayPlayer, immutableRule,
autoDelete,
eraseAllRules,
getSelfRuleNumber, getSelfRule,
showRule
) where
import Prelude hiding (foldr)
import Language.Nomyx.Expression
import Language.Nomyx.Events
import Language.Nomyx.Variables
import Data.Lens
import Control.Monad
import Data.List
import Data.Maybe
import Control.Applicative
activateRule :: RuleNumber -> Nomex Bool
activateRule = ActivateRule
activateRule_ :: RuleNumber -> Nomex ()
activateRule_ r = activateRule r >> return ()
rejectRule :: RuleNumber -> Nomex Bool
rejectRule = RejectRule
rejectRule_ :: RuleNumber -> Nomex ()
rejectRule_ r = void $ rejectRule r
getRules :: NomexNE [RuleInfo]
getRules = GetRules
getActiveRules :: NomexNE [RuleInfo]
getActiveRules = filter ((== Active) . _rStatus) <$> getRules
getRule :: RuleNumber -> NomexNE (Maybe RuleInfo)
getRule rn = do
rs <- GetRules
return $ find ((== rn) . getL rNumber) rs
getRulesByNumbers :: [RuleNumber] -> NomexNE [RuleInfo]
getRulesByNumbers rns = mapMaybeM getRule rns
getRuleFuncs :: NomexNE [Nomex ()]
getRuleFuncs = map _rRule <$> getRules
addRule :: RuleInfo -> Nomex Bool
addRule r = AddRule r
addRule_ :: RuleInfo -> Nomex ()
addRule_ r = void $ AddRule r
addRuleParams :: RuleName -> Rule -> RuleCode -> String -> Nomex RuleNumber
addRuleParams name rule code desc = do
number <- liftEffect getFreeRuleNumber
res <- addRule $ defaultRule {_rName = name, _rRule = rule, _rRuleCode = code, _rNumber = number, _rDescription = desc}
return $ if res then number else error "addRuleParams: cannot add rule"
getFreeRuleNumber :: NomexNE RuleNumber
getFreeRuleNumber = do
rs <- getRules
return $ getFreeNumber $ map _rNumber rs
getFreeNumber :: (Eq a, Num a, Enum a) => [a] -> a
getFreeNumber l = head [a| a <- [1..], not $ a `elem` l]
suppressRule :: RuleNumber -> Nomex Bool
suppressRule rn = RejectRule rn
suppressRule_ :: RuleNumber -> Nomex ()
suppressRule_ rn = void $ RejectRule rn
suppressAllRules :: Nomex Bool
suppressAllRules = do
rs <- liftEffect getRules
res <- mapM (suppressRule . _rNumber) rs
return $ and res
modifyRule :: RuleNumber -> RuleInfo -> Nomex Bool
modifyRule rn r = ModifyRule rn r
autoActivate :: Nomex ()
autoActivate = void $ onEvent_ (RuleEv Proposed) (activateRule_ . _rNumber . ruleData)
type MetaRule = RuleInfo -> NomexNE Bool
metaruleVar :: MsgVar [MetaRule]
metaruleVar = msgVar "metarules"
createMetaruleVar :: Nomex ()
createMetaruleVar = void $ newMsgVar (getMsgVarName metaruleVar) ([] :: [MetaRule])
addMetarule :: MetaRule -> Nomex ()
addMetarule mr = void $ modifyMsgVar metaruleVar (mr:)
testWithMetaRules :: RuleInfo -> NomexNE Bool
testWithMetaRules r = do
mmrs <- readMsgVar metaruleVar
case mmrs of
Just mrs -> do
bs <- sequence $ map (\mr -> mr r) mrs
return $ and bs
Nothing -> return $ False
legal :: Nomex ()
legal = addMetarule (const $ return True)
illegal :: Nomex ()
illegal = addMetarule (const $ return False)
noPlayPlayer :: PlayerNumber -> MetaRule
noPlayPlayer pn rule = return $ (_rProposedBy rule) /= pn
immutableRule :: RuleNumber -> MetaRule
immutableRule rn = \rule -> do
immu <- getRule rn
maybe (return True) (const $ simulate (_rRule rule) (isJust <$> getRule rn)) immu
simulate :: Nomex a -> NomexNE Bool -> NomexNE Bool
simulate sim test = Simu sim test
activateOrReject :: RuleInfo -> Bool -> Nomex ()
activateOrReject r b = if b then activateRule_ (_rNumber r) else rejectRule_ (_rNumber r)
autoDelete :: Nomex ()
autoDelete = liftEffect getSelfRuleNumber >>= suppressRule_
eraseAllRules :: PlayerNumber -> Nomex Bool
eraseAllRules p = do
rs <- liftEffect $ getRules
let myrs = filter ((== p) . getL rProposedBy) rs
res <- mapM (suppressRule . _rNumber) myrs
return $ and res
getSelfRuleNumber :: NomexNE RuleNumber
getSelfRuleNumber = SelfRuleNumber
getSelfRule :: NomexNE RuleInfo
getSelfRule = do
srn <- getSelfRuleNumber
rs:[] <- getRulesByNumbers [srn]
return rs
defaultRule = RuleInfo {
_rNumber = 1,
_rName = "",
_rDescription = "",
_rProposedBy = 0,
_rRuleCode = "",
_rRule = return (),
_rStatus = Pending,
_rAssessedBy = Nothing}
mapMaybeM :: (Monad m) => (a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM f = liftM catMaybes . mapM f
showRule x = void $ NewOutput Nothing (return $ show x)