--do
module Language.Nomyx.Rules (
RuleNumber,
RuleCode,
RuleEvent(..),
RuleStatus(..),
MetaRule,
activateRule, activateRule_,
rejectRule, rejectRule_,
getRules, getActiveRules, getRule,
getRulesByNumbers,
getRuleFuncs,
addRule, addRule_, addRule',
getFreeRuleNumber,
suppressRule, suppressRule_, suppressAllRules,
proposeRule, modifyRule,
autoActivate,
activateOrRejectRule,
simulate,
metaruleVar, createMetaruleVar, addMetarule, testWithMetaRules, displayMetarules,
legal, illegal, noPlayPlayer, immutableRule,
autoDelete,
eraseAllRules,
getSelfRuleNumber, getSelfRule,
onRuleProposed,
showRule
) where
import Prelude hiding (foldr)
import Language.Nomyx.Expression
import Language.Nomyx.Events
import Language.Nomyx.Variables
import Language.Nomyx.Outputs
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
addRule' :: RuleName -> Rule -> RuleCode -> String -> Nomex RuleNumber
addRule' 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 "addRule': cannot add rule"
getFreeRuleNumber :: NomexNE RuleNumber
getFreeRuleNumber = getFreeNumber . map _rNumber <$> getRules
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
proposeRule :: RuleInfo -> Nomex Bool
proposeRule = ProposeRule
getSelfRuleNumber :: NomexNE RuleNumber
getSelfRuleNumber = SelfRuleNumber
getSelfRule :: NomexNE RuleInfo
getSelfRule = do
srn <- getSelfRuleNumber
rs:[] <- getRulesByNumbers [srn]
return rs
activateOrRejectRule :: RuleInfo -> Bool -> Nomex ()
activateOrRejectRule 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
autoActivate :: Nomex ()
autoActivate = void $ onEvent_ (ruleEvent Proposed) (activateRule_ . _rNumber)
type MetaRule = RuleInfo -> NomexNE Bool
metaruleVar :: MsgVar [(String, MetaRule)]
metaruleVar = msgVar "metarules"
createMetaruleVar :: Nomex ()
createMetaruleVar = void $ newMsgVar' metaruleVar []
addMetarule :: MetaRule -> String -> Nomex ()
addMetarule mr code = void $ modifyMsgVar metaruleVar ((code, mr):)
testWithMetaRules :: RuleInfo -> NomexNE Bool
testWithMetaRules r = do
mmrs <- readMsgVar metaruleVar
case mmrs of
Just mrs -> and <$> mapM (($r) . snd) mrs
Nothing -> return False
displayMetarules :: Nomex ()
displayMetarules = void $ displayVar Nothing metaruleVar dispAll where
dispAll mvs = return $ maybe "No meta rules" (("Meta Rules:\n" ++) . concatMap disp) mvs
disp (s, _) = s ++ "\n"
legal :: MetaRule
legal = const $ return True
illegal :: MetaRule
illegal = 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
onRuleProposed :: (RuleInfo -> Nomex ()) -> Nomex ()
onRuleProposed f = void $ onEvent_ (ruleEvent Proposed) f
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)