module Language.Nomyx.Definition where
import Language.Nomyx.Expression
import Data.Typeable
import Control.Monad.State
import Data.List
import Data.Maybe
import Data.Time hiding (getCurrentTime)
import qualified Data.Map as M
import Data.Map hiding (map, filter, insert, mapMaybe, null)
import Data.Time.Recurrence hiding (filter)
import Safe
import Data.Lens
import Control.Applicative
import Data.Boolean
import Control.Monad.Error
import Language.Nomyx.Utils
newVar :: (Typeable a, Show a, Eq a) => VarName -> a -> Nomex (Maybe (V a))
newVar = NewVar
newVar_ :: (Typeable a, Show a, Eq a) => VarName -> a -> Nomex (V a)
newVar_ s a = do
mv <- NewVar s a
case mv of
Just var -> return var
Nothing -> throwError "newVar_: Variable existing"
readVar :: (Typeable a, Show a, Eq a) => (V a) -> Nomex (Maybe a)
readVar = ReadVar
readVar_ :: forall a. (Typeable a, Show a, Eq a) => (V a) -> Nomex a
readVar_ v@(V a) = do
ma <- ReadVar v
case ma of
Just (val:: a) -> return val
Nothing -> throwError $ "readVar_: Variable \"" ++ a ++ "\" with type \"" ++ (show $ typeOf v) ++ "\" not existing"
writeVar :: (Typeable a, Show a, Eq a) => (V a) -> a -> Nomex Bool
writeVar = WriteVar
writeVar_ :: (Typeable a, Show a, Eq a) => (V a) -> a -> Nomex ()
writeVar_ var val = do
ma <- WriteVar var val
case ma of
True -> return ()
False -> throwError "writeVar_: Variable not existing"
modifyVar :: (Typeable a, Show a, Eq a) => (V a) -> (a -> a) -> Nomex ()
modifyVar v f = writeVar_ v . f =<< readVar_ v
delVar :: (V a) -> Nomex Bool
delVar = DelVar
delVar_ :: (V a) -> Nomex ()
delVar_ v = DelVar v >> return ()
data ArrayVar i a = ArrayVar (Msg [(i, Maybe a)]) (V (Map i (Maybe a)))
newArrayVar :: (Ord i, Typeable a, Show a, Eq a, Typeable i, Show i) => VarName -> [i] -> Nomex (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,Maybe a)] -> Nomex ()) -> Nomex (ArrayVar i a)
newArrayVar' name l f = do
av@(ArrayVar m _) <- 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, Maybe a)] -> Nomex ()) -> Nomex (ArrayVar i a)
newArrayVarOnce name l f = do
av@(ArrayVar m _) <- newArrayVar name l
onMessage m $ \a -> do
f $ messageData a
full <- (isFullArrayVar av)
when full $ delArrayVar av
return av where
isFullArrayVar :: (Ord i, Typeable a, Show a, Eq a, Typeable i, Show i) => (ArrayVar i a) -> Nomex (Bool)
isFullArrayVar av = do
d <- getArrayVarData av
let full = and $ map isJust $ map snd d
return full
putArrayVar :: (Ord i, Typeable a, Show a, Eq a, Typeable i, Show i) => (ArrayVar i a) -> i -> a -> Nomex ()
putArrayVar (ArrayVar m v) i a = do
ar <- readVar_ v
let ar2 = M.insert i (Just a) ar
writeVar_ v ar2
sendMessage m (toList ar2)
getArrayVarMessage :: (Ord i, Typeable a, Show a, Eq a, Typeable i, Show i) => (ArrayVar i a) -> Nomex (Msg [(i, Maybe a)])
getArrayVarMessage (ArrayVar m _) = return m
getArrayVarData :: (Ord i, Typeable a, Show a, Eq a, Typeable i, Show i) => (ArrayVar i a) -> Nomex ([(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) -> Nomex ([(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) -> Nomex ()
delArrayVar (ArrayVar m v) = delAllEvents m >> delVar_ v
onEvent :: (Typeable e, Show e, Eq e) => Event e -> ((EventNumber, EventData e) -> Nomex ()) -> Nomex EventNumber
onEvent = OnEvent
onEvent_ :: forall e. (Typeable e, Show e, Eq e) => Event e -> (EventData e -> Nomex ()) -> Nomex ()
onEvent_ e h = do
OnEvent e (\(_, d) -> h d)
return ()
onEventOnce :: (Typeable e, Show e, Eq e) => Event e -> (EventData e -> Nomex ()) -> Nomex 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 -> Nomex ()) -> Nomex ()
onEventOnce_ e h = do
let handler (en, ed) = delEvent_ en >> h ed
OnEvent e handler
return ()
delEvent :: EventNumber -> Nomex Bool
delEvent = DelEvent
delEvent_ :: EventNumber -> Nomex ()
delEvent_ e = delEvent e >> return ()
delAllEvents :: (Typeable e, Show e, Eq e) => Event e -> Nomex ()
delAllEvents = DelAllEvents
sendMessage :: (Typeable a, Show a, Eq a) => Msg a -> a -> Nomex ()
sendMessage = SendMessage
sendMessage_ :: Msg () -> Nomex ()
sendMessage_ m = SendMessage m ()
onMessage :: (Typeable m, Show m) => Msg m -> (MsgData m -> Nomex ()) -> Nomex ()
onMessage m f = onEvent_ m f
onMessageOnce :: (Typeable m, Show m) => Msg m -> (MsgData m -> Nomex ()) -> Nomex ()
onMessageOnce m f = onEventOnce_ m f
schedule :: (Schedule Freq) -> (UTCTime -> Nomex ()) -> Nomex ()
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 -> Nomex ()) -> (Schedule Freq) -> (EventData Time) -> Nomex ()
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) -> Nomex () -> Nomex ()
schedule_ ts f = schedule ts (\_-> f)
schedule' :: [UTCTime] -> (UTCTime -> Nomex ()) -> Nomex ()
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 -> Nomex ()) -> [UTCTime] -> (EventData Time) -> Nomex ()
executeAndScheduleNext' f sched now = do
f now
let rest = drop 1 $ sched
when (rest /= []) $ onEventOnce_ (Time $ head rest) $ executeAndScheduleNext' f sched
schedule'_ :: [UTCTime] -> Nomex () -> Nomex ()
schedule'_ ts f = schedule' ts (\_-> f)
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 :: Nomex [Rule]
getRules = GetRules
getActiveRules :: Nomex [Rule]
getActiveRules = return . (filter ((== Active) . _rStatus) ) =<< getRules
getRule :: RuleNumber -> Nomex (Maybe Rule)
getRule rn = do
rs <- GetRules
return $ find ((== rn) . getL rNumber) rs
getRulesByNumbers :: [RuleNumber] -> Nomex [Rule]
getRulesByNumbers rns = mapMaybeM getRule rns
getRuleFuncs :: Nomex [RuleFunc]
getRuleFuncs = return . (map _rRuleFunc) =<< getRules
addRule :: Rule -> Nomex Bool
addRule r = AddRule r
addRule_ :: Rule -> Nomex ()
addRule_ r = void $ AddRule r
addRuleParams :: RuleName -> RuleFunc -> RuleCode -> String -> Nomex RuleNumber
addRuleParams name func code desc = do
number <- getFreeRuleNumber
res <- addRule $ defaultRule {_rName = name, _rRuleFunc = func, _rRuleCode = code, _rNumber = number, _rDescription = desc}
return $ if res then number else error "addRuleParams: cannot add rule"
getFreeRuleNumber :: Nomex RuleNumber
getFreeRuleNumber = do
rs <- getRules
return $ getFreeNumber $ map _rNumber rs
suppressRule :: RuleNumber -> Nomex Bool
suppressRule rn = RejectRule rn
suppressRule_ :: RuleNumber -> Nomex ()
suppressRule_ rn = void $ RejectRule rn
suppressAllRules :: Nomex Bool
suppressAllRules = do
rs <- getRules
res <- mapM (suppressRule . _rNumber) rs
return $ and res
modifyRule :: RuleNumber -> Rule -> Nomex 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 -> Nomex ()) -> PlayerNumber -> Nomex 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 -> Nomex ()) -> PlayerNumber -> Nomex ()
onInputChoice_ title choices handler pn = onEvent_ (inputChoiceHead pn title choices) (handler . inputChoiceData)
onInputChoiceOnce :: (Typeable a, Eq a, Show a) => String -> [a] -> (a -> Nomex ()) -> PlayerNumber -> Nomex EventNumber
onInputChoiceOnce title choices handler pn = onEventOnce (inputChoiceHead pn title choices) (handler . inputChoiceData)
onInputChoiceOnce_ :: (Typeable a, Eq a, Show a) => String -> [a] -> (a -> Nomex ()) -> PlayerNumber -> Nomex ()
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 -> Nomex ()) -> PlayerNumber -> Nomex 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 -> Nomex ()) -> PlayerNumber -> Nomex ()
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 -> Nomex ()) -> PlayerNumber -> Nomex ()
onInputChoiceEnumOnce_ title defaultChoice handler pn = onEventOnce_ (inputChoiceEnum pn title defaultChoice) (handler . inputChoiceData)
onInputString :: String -> (EventNumber -> String -> Nomex ()) -> PlayerNumber -> Nomex EventNumber
onInputString title handler pn = onEvent (inputString pn title) (\(en, a) -> handler en (inputStringData a))
onInputString_ :: String -> (String -> Nomex ()) -> PlayerNumber -> Nomex ()
onInputString_ title handler pn = onEvent_ (inputString pn title) (handler . inputStringData)
onInputStringOnce_ :: String -> (String -> Nomex ()) -> PlayerNumber -> Nomex ()
onInputStringOnce_ title handler pn = onEventOnce_ (inputString pn title) (handler . inputStringData)
getPlayers :: Nomex [PlayerInfo]
getPlayers = GetPlayers
getPlayer :: PlayerNumber -> Nomex (Maybe PlayerInfo)
getPlayer pn = do
pls <- GetPlayers
return $ find ((== pn) . getL playerNumber) pls
getPlayerName :: PlayerNumber -> Nomex (Maybe PlayerName)
getPlayerName pn = do
p <- getPlayer pn
return $ _playerName <$> p
setPlayerName :: PlayerNumber -> PlayerName -> Nomex Bool
setPlayerName = SetPlayerName
modifyPlayerName :: PlayerNumber -> (PlayerName -> PlayerName) -> Nomex Bool
modifyPlayerName pn f = do
mn <- getPlayerName pn
case mn of
Just name -> setPlayerName pn (f name)
Nothing -> return False
getPlayersNumber = length <$> getPlayers
getAllPlayerNumbers :: Nomex [PlayerNumber]
getAllPlayerNumbers = map _playerNumber <$> getPlayers
delPlayer :: PlayerNumber -> Nomex Bool
delPlayer = DelPlayer
setVictory :: [PlayerNumber] -> Nomex ()
setVictory = SetVictory
giveVictory :: PlayerNumber -> Nomex ()
giveVictory pn = SetVictory [pn]
output :: String -> PlayerNumber -> Nomex ()
output s pn = Output pn s
outputAll :: String -> Nomex ()
outputAll s = getPlayers >>= mapM_ ((output s) . _playerNumber)
getCurrentTime :: Nomex UTCTime
getCurrentTime = CurrentTime
getSelfRuleNumber :: Nomex RuleNumber
getSelfRuleNumber = SelfRuleNumber
getSelfRule :: Nomex Rule
getSelfRule = do
srn <- getSelfRuleNumber
rs:[] <- getRulesByNumbers [srn]
return rs
getSelfProposedByPlayer :: Nomex PlayerNumber
getSelfProposedByPlayer = getSelfRule >>= return . _rProposedBy
voidRule :: Nomex a -> Nomex RuleResp
voidRule e = e >> return Void
instance Boolean (Nomex BoolResp) where
true = return $ BoolResp True
false = return $ BoolResp False
notB = undefined
(||*) = undefined
(&&*) na nb = do
a <- na
b <- nb
case a of
(BoolResp a') -> case b of
(BoolResp b') -> return $ BoolResp $ a' && b'
(MsgResp b') -> andMsgBool a' b' >>= (return . MsgResp)
(MsgResp a') -> case b of
(BoolResp b') -> andMsgBool b' a' >>= (return . MsgResp)
(MsgResp b') -> andMsgMsg a' b' >>= (return . MsgResp)
andMsgBool :: Bool -> (Msg Bool) -> Nomex (Msg Bool)
andMsgBool a b = do
let m = Message ((show a) ++ " &&* " ++ (show b))
onMessageOnce b (f m)
return m where
f m (MessageData b1) = sendMessage m $ a && b1
andMsgMsg :: Msg Bool -> Msg Bool -> Nomex (Msg Bool)
andMsgMsg a b = do
let m = Message ((show a) ++ " &&* " ++ (show b))
newArrayVarOnce ((show a) ++ ", " ++ (show b)) [1::Integer, 2] (f m)
return m where
f m ((_, Just a):(_, Just b):[]) = sendMessage m $ a && b
f _ _ = return ()
defaultRule = Rule {
_rNumber = 1,
_rName = "",
_rDescription = "",
_rProposedBy = 0,
_rRuleCode = "",
_rRuleFunc = return Void,
_rStatus = Pending,
_rAssessedBy = Nothing}