module Language.Nomyx.Rule where
import Language.Nomyx.Expression
import Data.Typeable
import Control.Monad.State
import Data.List
import Data.Maybe
import Data.Time hiding (getCurrentTime)
import Data.Function
import Data.Map hiding (map, filter, insert, mapMaybe)
import qualified Data.Map as M (map, insert)
import System.Locale (defaultTimeLocale, rfc822DateFormat)
import Control.Arrow
import Data.Time.Recurrence hiding (filter)
import Safe
import Control.Applicative
newVar :: (Typeable a, Show a, Eq a) => VarName -> a -> Exp (Maybe (V a))
newVar = NewVar
newVar_ :: (Typeable a, Show a, Eq a) => VarName -> a -> Exp (V a)
newVar_ s a = do
mv <- NewVar s a
case mv of
Just var -> return var
Nothing -> error "newVar_: Variable existing"
readVar :: (Typeable a, Show a, Eq a) => (V a) -> Exp (Maybe a)
readVar = ReadVar
readVar_ :: forall a. (Typeable a, Show a, Eq a) => (V a) -> Exp a
readVar_ v@(V a) = do
ma <- ReadVar v
case ma of
Just (val:: a) -> return val
Nothing -> error $ "readVar_: Variable \"" ++ a ++ "\" with type \"" ++ (show $ typeOf v) ++ "\" not existing"
writeVar :: (Typeable a, Show a, Eq a) => (V a) -> a -> Exp Bool
writeVar = WriteVar
writeVar_ :: (Typeable a, Show a, Eq a) => (V a) -> a -> Exp ()
writeVar_ var val = do
ma <- WriteVar var val
case ma of
True -> return ()
False -> error "writeVar_: Variable not existing"
modifyVar :: (Typeable a, Show a, Eq a) => (V a) -> (a -> a) -> Exp ()
modifyVar v f = writeVar_ v . f =<< readVar_ v
delVar :: (V a) -> Exp Bool
delVar = DelVar
delVar_ :: (V a) -> Exp ()
delVar_ v = DelVar v >> return ()
data ArrayVar i a = ArrayVar (Event (Message [(i, a)])) (V (Map i (Maybe a)))
newArrayVar :: (Ord i, Typeable a, Show a, Eq a, Typeable i, Show i) => VarName -> [i] -> Exp (ArrayVar i a)
newArrayVar name l = do
let list = map (\i -> (i, Nothing)) l
v <- newVar_ name (fromList list)
return $ ArrayVar (Message name) v
newArrayVar' :: (Ord i, Typeable a, Show a, Eq a, Typeable i, Show i) => VarName -> [i] -> ([(i,a)] -> Exp ()) -> Exp (ArrayVar i a)
newArrayVar' name l f = do
av@(ArrayVar m v) <- newArrayVar name l
onMessage m $ f . messageData
return av
newArrayVarOnce :: (Ord i, Typeable a, Show a, Eq a, Typeable i, Show i) => VarName -> [i] -> ([(i,a)] -> Exp ()) -> Exp (ArrayVar i a)
newArrayVarOnce name l f = do
av@(ArrayVar m v) <- newArrayVar name l
onMessageOnce m (\a -> (f $ messageData a) >> (delVar_ v))
return av
putArrayVar :: (Ord i, Typeable a, Show a, Eq a, Typeable i, Show i) => (ArrayVar i a) -> i -> a -> Exp ()
putArrayVar (ArrayVar m v) i a = do
ar <- readVar_ v
let ar2 = M.insert i (Just a) ar
writeVar_ v ar2
let finish = and $ map isJust $ elems ar2
when finish $ sendMessage m (toList $ M.map fromJust ar2)
getArrayVarMessage :: (Ord i, Typeable a, Show a, Eq a, Typeable i, Show i) => (ArrayVar i a) -> Exp (Event (Message [(i, a)]))
getArrayVarMessage (ArrayVar m _) = return m
getArrayVarData :: (Ord i, Typeable a, Show a, Eq a, Typeable i, Show i) => (ArrayVar i a) -> Exp ([(i, Maybe a)])
getArrayVarData (ArrayVar _ v) = toList <$> (readVar_ v)
getArrayVarData' :: (Ord i, Typeable a, Show a, Eq a, Typeable i, Show i) => (ArrayVar i a) -> Exp ([(i, a)])
getArrayVarData' v = catMaybes . map sndMaybe <$> (getArrayVarData v)
delArrayVar :: (Ord i, Typeable a, Show a, Eq a, Typeable i, Show i) => (ArrayVar i a) -> Exp ()
delArrayVar (ArrayVar m v) = delAllEvents m >> delVar_ v
onEvent :: (Typeable e, Show e, Eq e) => Event e -> ((EventNumber, EventData e) -> Exp ()) -> Exp EventNumber
onEvent = OnEvent
onEvent_ :: forall e. (Typeable e, Show e, Eq e) => Event e -> (EventData e -> Exp ()) -> Exp ()
onEvent_ e h = do
OnEvent e (\(_, d) -> h d)
return ()
onEventOnce :: (Typeable e, Show e, Eq e) => Event e -> (EventData e -> Exp ()) -> Exp EventNumber
onEventOnce e h = do
let handler (en, ed) = delEvent_ en >> h ed
n <- OnEvent e handler
return n
onEventOnce_ :: (Typeable e, Show e, Eq e) => Event e -> (EventData e -> Exp ()) -> Exp ()
onEventOnce_ e h = do
let handler (en, ed) = delEvent_ en >> h ed
OnEvent e handler
return ()
delEvent :: EventNumber -> Exp Bool
delEvent = DelEvent
delEvent_ :: EventNumber -> Exp ()
delEvent_ e = delEvent e >> return ()
delAllEvents :: (Typeable e, Show e, Eq e) => Event e -> Exp ()
delAllEvents = DelAllEvents
sendMessage :: (Typeable a, Show a, Eq a) => Event (Message a) -> a -> Exp ()
sendMessage = SendMessage
sendMessage_ :: Event (Message ()) -> Exp ()
sendMessage_ m = SendMessage m ()
onMessage :: (Typeable m, Show m) => Event (Message m) -> ((EventData (Message m)) -> Exp ()) -> Exp ()
onMessage m f = onEvent_ m f
onMessageOnce :: (Typeable m, Show m) => Event (Message m) -> ((EventData (Message m)) -> Exp ()) -> Exp ()
onMessageOnce m f = onEventOnce_ m f
schedule :: (Schedule Freq) -> (UTCTime -> Exp ()) -> Exp ()
schedule sched f = do
now <- getCurrentTime
let next = head $ starting now $ sched
if (next == now) then executeAndScheduleNext (f . timeData) sched (TimeData now)
else onEventOnce_ (Time next) $ executeAndScheduleNext (f . timeData) sched where
executeAndScheduleNext :: (EventData Time -> Exp ()) -> (Schedule Freq) -> (EventData Time) -> Exp ()
executeAndScheduleNext f sched now = do
f now
let rest = drop 1 $ starting (timeData now) $ sched
when (rest /= []) $ onEventOnce_ (Time $ head rest) $ executeAndScheduleNext f sched
schedule_ :: (Schedule Freq) -> Exp () -> Exp ()
schedule_ ts f = schedule ts (\_-> f)
schedule' :: [UTCTime] -> (UTCTime -> Exp ()) -> Exp ()
schedule' sched f = do
let sched' = sort sched
now <- getCurrentTime
let nextMay = headMay $ filter (>=now) $ sched'
case nextMay of
Just next -> do
if (next == now) then executeAndScheduleNext' (f . timeData) sched' (TimeData now)
else onEventOnce_ (Time next) $ executeAndScheduleNext' (f . timeData) sched'
Nothing -> return ()
executeAndScheduleNext' :: (EventData Time -> Exp ()) -> [UTCTime] -> (EventData Time) -> Exp ()
executeAndScheduleNext' f sched now = do
f now
let rest = drop 1 $ sched
when (rest /= []) $ onEventOnce_ (Time $ head rest) $ executeAndScheduleNext' f sched
schedule'_ :: [UTCTime] -> Exp () -> Exp ()
schedule'_ ts f = schedule' ts (\_-> f)
activateRule :: RuleNumber -> Exp Bool
activateRule = ActivateRule
activateRule_ :: RuleNumber -> Exp ()
activateRule_ r = activateRule r >> return ()
rejectRule :: RuleNumber -> Exp Bool
rejectRule = RejectRule
rejectRule_ :: RuleNumber -> Exp ()
rejectRule_ r = rejectRule r >> return ()
getRules :: Exp [Rule]
getRules = GetRules
getActiveRules :: Exp [Rule]
getActiveRules = return . (filter ((== Active) . rStatus) ) =<< getRules
getRule :: RuleNumber -> Exp (Maybe Rule)
getRule rn = do
rs <- GetRules
return $ find (\(Rule {rNumber = n}) -> n == rn) rs
getRulesByNumbers :: [RuleNumber] -> Exp [Rule]
getRulesByNumbers rns = mapMaybeM getRule rns
getRuleFuncs :: Exp [RuleFunc]
getRuleFuncs = return . (map rRuleFunc) =<< getRules
addRule :: Rule -> Exp Bool
addRule r = AddRule r
addRule_ :: Rule -> Exp ()
addRule_ r = AddRule r >> return ()
addRuleParams_ :: RuleName -> RuleFunc -> RuleCode -> RuleNumber -> String -> Exp ()
addRuleParams_ name func code number desc = addRule_ $ defaultRule {rName = name, rRuleFunc = func, rRuleCode = code, rNumber = number, rDescription = desc}
suppressRule :: RuleNumber -> Exp Bool
suppressRule rn = DelRule rn
suppressRule_ :: RuleNumber -> Exp ()
suppressRule_ rn = DelRule rn >> return ()
suppressAllRules :: Exp Bool
suppressAllRules = do
rs <- getRules
res <- mapM (suppressRule . rNumber) rs
return $ and res
modifyRule :: RuleNumber -> Rule -> Exp Bool
modifyRule rn r = ModifyRule rn r
inputChoice :: (Eq c, Show c) => PlayerNumber -> String -> [c] -> c -> Event (InputChoice c)
inputChoice = InputChoice
inputChoiceHead :: (Eq c, Show c) => PlayerNumber -> String -> [c] -> Event (InputChoice c)
inputChoiceHead pn title choices = inputChoice pn title choices (head choices)
inputChoiceEnum :: forall c. (Enum c, Bounded c, Typeable c, Eq c, Show c) => PlayerNumber -> String -> c -> Event (InputChoice c)
inputChoiceEnum pn title defaultChoice = inputChoice pn title (enumFrom (minBound::c)) defaultChoice
inputString :: PlayerNumber -> String -> Event InputString
inputString = InputString
onInputChoice :: (Typeable a, Eq a, Show a) => String -> [a] -> (EventNumber -> a -> Exp ()) -> PlayerNumber -> Exp EventNumber
onInputChoice title choices handler pn = onEvent (inputChoiceHead pn title choices) (\(en, a) -> handler en (inputChoiceData a))
onInputChoice_ :: (Typeable a, Eq a, Show a) => String -> [a] -> (a -> Exp ()) -> PlayerNumber -> Exp ()
onInputChoice_ title choices handler pn = onEvent_ (inputChoiceHead pn title choices) (handler . inputChoiceData)
onInputChoiceOnce :: (Typeable a, Eq a, Show a) => String -> [a] -> (a -> Exp ()) -> PlayerNumber -> Exp EventNumber
onInputChoiceOnce title choices handler pn = onEventOnce (inputChoiceHead pn title choices) (handler . inputChoiceData)
onInputChoiceOnce_ :: (Typeable a, Eq a, Show a) => String -> [a] -> (a -> Exp ()) -> PlayerNumber -> Exp ()
onInputChoiceOnce_ title choices handler pn = onEventOnce_ (inputChoiceHead pn title choices) (handler . inputChoiceData)
onInputChoiceEnum :: forall a. (Enum a, Bounded a, Typeable a, Eq a, Show a) => String -> a -> (EventNumber -> a -> Exp ()) -> PlayerNumber -> Exp EventNumber
onInputChoiceEnum title defaultChoice handler pn = onEvent (inputChoiceEnum pn title defaultChoice) (\(en, a) -> handler en (inputChoiceData a))
onInputChoiceEnum_ :: forall a. (Enum a, Bounded a, Typeable a, Eq a, Show a) => String -> a -> (a -> Exp ()) -> PlayerNumber -> Exp ()
onInputChoiceEnum_ title defaultChoice handler pn = onEvent_ (inputChoiceEnum pn title defaultChoice) (handler . inputChoiceData)
onInputChoiceEnumOnce_ :: forall a. (Enum a, Bounded a, Typeable a, Eq a, Show a) => String -> a -> (a -> Exp ()) -> PlayerNumber -> Exp ()
onInputChoiceEnumOnce_ title defaultChoice handler pn = onEventOnce_ (inputChoiceEnum pn title defaultChoice) (handler . inputChoiceData)
onInputString :: String -> (EventNumber -> String -> Exp ()) -> PlayerNumber -> Exp EventNumber
onInputString title handler pn = onEvent (inputString pn title) (\(en, a) -> handler en (inputStringData a))
onInputString_ :: String -> (String -> Exp ()) -> PlayerNumber -> Exp ()
onInputString_ title handler pn = onEvent_ (inputString pn title) (handler . inputStringData)
onInputStringOnce_ :: String -> (String -> Exp ()) -> PlayerNumber -> Exp ()
onInputStringOnce_ title handler pn = onEventOnce_ (inputString pn title) (handler . inputStringData)
setVictory :: [PlayerNumber] -> Exp ()
setVictory = SetVictory
giveVictory :: PlayerNumber -> Exp ()
giveVictory pn = SetVictory [pn]
getPlayers :: Exp [PlayerInfo]
getPlayers = GetPlayers
getPlayersNumber :: Exp Int
getPlayersNumber = length <$> getPlayers
getAllPlayerNumbers :: Exp [PlayerNumber]
getAllPlayerNumbers = map playerNumber <$> getPlayers
output :: String -> PlayerNumber -> Exp ()
output s pn = Output pn s
outputAll :: String -> Exp ()
outputAll s = getPlayers >>= mapM_ ((output s) . playerNumber)
getCurrentTime :: Exp UTCTime
getCurrentTime = CurrentTime
getSelfRuleNumber :: Exp RuleNumber
getSelfRuleNumber = SelfRuleNumber
getSelfRule :: Exp Rule
getSelfRule = do
srn <- getSelfRuleNumber
rs:[] <- getRulesByNumbers [srn]
return rs
getSelfProposedByPlayer :: Exp PlayerNumber
getSelfProposedByPlayer = getSelfRule >>= return . rProposedBy
autoActivate :: RuleFunc
autoActivate = VoidRule $ onEvent_ (RuleEv Proposed) (activateRule_ . rNumber . ruleData)
immutableRule :: RuleNumber -> RuleFunc
immutableRule rn = RuleRule f where
f r = do
protectedRule <- getRule rn
case protectedRule of
Just pr -> case rRuleFunc r of
RuleRule paramRule -> paramRule pr
otherwise -> return $ BoolResp True
Nothing -> return $ BoolResp True
legal :: RuleFunc
legal = RuleRule $ \_ -> return $ BoolResp True
illegal :: RuleFunc
illegal = RuleRule $ \_ -> return $ BoolResp False
simpleApplicationRule :: RuleFunc
simpleApplicationRule = VoidRule $ do
v <- newVar_ "rules" ([]:: [RuleNumber])
onEvent_ (RuleEv Proposed) (h v) where
h v (RuleData rule) = do
(rns:: [RuleNumber]) <- readVar_ v
rs <- getRulesByNumbers rns
oks <- mapM (applyRule rule) rs
when (and oks) $ activateRule_ $ rNumber rule
applyRule :: Rule -> Rule -> Exp Bool
applyRule (Rule {rRuleFunc = rf}) r = do
case rf of
RuleRule f1 -> f1 r >>= return . boolResp
otherwise -> return False
checkWithMetarules :: Rule -> Exp RuleResponse
checkWithMetarules r = do
rs <- getActiveRules
let rrs = mapMaybe maybeMetaRule rs
evals <- mapM (\rr -> rr r) rrs
andrrs evals
maybeMetaRule :: Rule -> Maybe (OneParamRule Rule)
maybeMetaRule Rule {rRuleFunc = (RuleRule r)} = Just r
maybeMetaRule _ = Nothing
onRuleProposed :: (Rule -> Exp RuleResponse) -> 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)
voteWith :: ([(PlayerNumber, ForAgainst)] -> Bool) -> Rule -> Exp RuleResponse
voteWith f rule = do
pns <- getAllPlayerNumbers
let rn = show $ rNumber rule
let m = Message ("Unanimity for " ++ rn)
voteVar <- newArrayVarOnce ("Votes for " ++ rn) pns (sendMessage m . f)
let askPlayer pn = onInputChoiceOnce_ ("Vote for rule " ++ rn) [For, Against] (putArrayVar voteVar pn) pn
mapM_ askPlayer pns
return $ MsgResp m
unanimity :: [(PlayerNumber, ForAgainst)] -> Bool
unanimity l = ((length $ filter ((== Against) . snd) l) == 0)
majority :: [(PlayerNumber, ForAgainst)] -> Bool
majority l = ((length $ filter ((== For) . snd) l) >= (length l) `div` 2 + 1)
activateOrReject :: Rule -> Bool -> Exp ()
activateOrReject r b = if b then activateRule_ (rNumber r) else rejectRule_ (rNumber r)
voteWithTimeLimit :: ([(PlayerNumber, ForAgainst)] -> Bool) -> UTCTime -> RuleFunc
voteWithTimeLimit f t = RuleRule $ \rule -> do
pns <- getAllPlayerNumbers
let rn = show $ rNumber rule
let m = Message ("Unanimity for " ++ rn)
voteVar <- newArrayVarOnce ("Votes for " ++ rn) pns (sendMessage m . f)
let askPlayer pn = onInputChoiceOnce ("Vote for rule " ++ rn) [For, Against] (putArrayVar voteVar pn) pn
ics <- mapM askPlayer pns
onEventOnce_ (Time t) $ \_ -> do
getArrayVarData' voteVar >>= sendMessage m . f
delArrayVar voteVar
mapM_ delEvent ics
return $ MsgResp m
forEachPlayer :: (PlayerNumber -> Exp ()) -> (PlayerNumber -> Exp ()) -> (PlayerNumber -> Exp ()) -> Exp ()
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 -> Exp ()) -> Exp ()
forEachPlayer_ action = forEachPlayer action action (\_ -> return ())
forEachPlayer' :: (PlayerNumber -> Exp a) -> ((PlayerNumber, a) -> Exp ()) -> Exp ()
forEachPlayer' = undefined
createValueForEachPlayer :: Int -> V [(Int, Int)] -> Exp ()
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)] -> Exp ()
createValueForEachPlayer_ = createValueForEachPlayer 0
modifyValueOfPlayer :: PlayerNumber -> V [(Int, Int)] -> (Int -> Int) -> Exp ()
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) -> Exp ()
modifyAllValues var f = modifyVar var $ map $ second f
noPlayPlayer :: PlayerNumber -> RuleFunc
noPlayPlayer p = RuleRule $ \r -> return $ BoolResp $ (rProposedBy r) /= p
autoDelete :: Exp ()
autoDelete = getSelfRuleNumber >>= suppressRule_
eraseAllRules :: PlayerNumber -> Exp Bool
eraseAllRules p = do
rs <- getRules
let myrs = filter (\r -> (rProposedBy r) == p) rs
res <- mapM (suppressRule . rNumber) myrs
return $ and res
mapMaybeM :: (Monad m) => (a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM f = liftM catMaybes . mapM f
parse822Time :: String -> UTCTime
parse822Time = zonedTimeToUTC
. fromJust
. parseTime defaultTimeLocale rfc822DateFormat
sndMaybe :: (a, Maybe b) -> Maybe (a,b)
sndMaybe (a, Just b) = Just (a,b)
sndMaybe (a, Nothing) = Nothing
andrr :: RuleResponse -> RuleResponse -> Exp RuleResponse
andrr a@(BoolResp _) b@(MsgResp _) = andrr b a
andrr (BoolResp a) (BoolResp b) = return $ BoolResp $ a && b
andrr (MsgResp m1@(Message s1)) (MsgResp m2@(Message s2)) = do
let m = Message (s1 ++ " and " ++ s2)
v <- newArrayVarOnce (s1 ++ ", " ++ s2) [1::Integer, 2] (f m)
return (MsgResp m) where
f m ((_, a):(_, b):[]) = sendMessage m $ a && b
andrr (MsgResp m1@(Message s1)) (BoolResp b2) = do
let m = Message (s1 ++ " and " ++ (show b2))
onMessageOnce m1 (f m)
return (MsgResp m) where
f m (MessageData b1) = sendMessage m $ b1 && b2
andrrs :: [RuleResponse] -> Exp RuleResponse
andrrs l = foldM andrr (BoolResp True) l
(&&.) :: RuleFunc -> RuleFunc -> RuleFunc
(VoidRule r1) &&. (VoidRule r2) = VoidRule $ r1 >> r2
rf1@(VoidRule _) &&. rf2@(RuleRule _) = rf2 &&. rf1
(RuleRule r1) &&. (VoidRule r2) = RuleRule $ \a -> do
res <- r1 a
r2
return res
(RuleRule r1) &&. (RuleRule r2) = RuleRule $ \a -> do
res1 <- r1 a
res2 <- r2 a
res <- andrr res1 res2
return res
_ &&. _ = error "rules impossible to combine"
defaultRule = Rule {
rNumber = 1,
rName = "",
rDescription = "",
rProposedBy = 0,
rRuleCode = "",
rRuleFunc = VoidRule $ return (),
rStatus = Pending,
rAssessedBy = Nothing}