diff --git a/Nomyx-Language.cabal b/Nomyx-Language.cabal --- a/Nomyx-Language.cabal +++ b/Nomyx-Language.cabal @@ -1,5 +1,5 @@ name: Nomyx-Language -version: 0.2.3 +version: 0.3.0 cabal-version: >=1.6 ---Warning: For using "cabal sdist", this patch is needed in cabal: https://github.com/haskell/cabal/pull/1110 ---To allow sdist to work with exported generated modules (Paths_Nomyx_Language) @@ -14,26 +14,41 @@ category: Language author: Corentin Dupont data-files: src/Language/Nomyx/Definition.hs - src/Language/Nomyx/Examples.hs src/Language/Nomyx/Expression.hs - src/Language/Nomyx/Rule.hs src/Language/Nomyx/Test.hs + src/Language/Nomyx/Examples.hs + src/Language/Nomyx/Expression.hs + src/Language/Nomyx/Rule.hs + src/Language/Nomyx/Test.hs src/Language/Nomyx/Vote.hs data-dir: "" extra-source-files: AUTHORS README library - build-depends: base ==4.*, containers -any, ghc -any, - hint-server -any, hslogger -any, mtl -any, old-locale -any, - safe -any, stm -any, template-haskell -any, time -any, - time-recurrence -any, DebugTraceHelpers -any, data-lens -any, - data-lens-template -any, data-lens-fd -any, Boolean -any, - safecopy -any + build-depends: base ==4.*, + containers -any, + ghc -any, + hint-server -any, + hslogger -any, + mtl -any, + old-locale -any, + safe -any, + stm -any, + template-haskell -any, + time -any, + time-recurrence -any, + DebugTraceHelpers -any, + data-lens -any, + data-lens-template -any, + data-lens-fd -any, + Boolean -any, + safecopy -any, + transformers -any exposed-modules: Language.Nomyx - Language.Nomyx.Expression + Language.Nomyx.Expression Language.Nomyx.Definition - Language.Nomyx.Evaluation + Language.Nomyx.Evaluation Language.Nomyx.Examples Language.Nomyx.Rule - Language.Nomyx.Vote + Language.Nomyx.Vote Language.Nomyx.Test Language.Nomyx.Game Language.Nomyx.Utils diff --git a/src/Language/Nomyx/Definition.hs b/src/Language/Nomyx/Definition.hs --- a/src/Language/Nomyx/Definition.hs +++ b/src/Language/Nomyx/Definition.hs @@ -25,33 +25,21 @@ 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" +newVar_ s a = partial "newVar_: Variable existing" (newVar s a) -- | variable reading 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" +readVar_ v@(V a) = partial ("readVar_: Variable \"" ++ a ++ "\" with type \"" ++ (show $ typeOf v) ++ "\" not existing") (readVar v) -- | variable writing 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" +writeVar_ var val = void $ writeVar var val -- | modify a variable using the provided function modifyVar :: (Typeable a, Show a, Eq a) => (V a) -> (a -> a) -> Nomex () @@ -62,69 +50,141 @@ delVar = DelVar delVar_ :: (V a) -> Nomex () -delVar_ v = DelVar v >> return () +delVar_ v = void $ delVar v + + +data VEvent a = VUpdated a | VDeleted deriving (Typeable, Show, Eq) +data MsgVar a = MsgVar (Msg (VEvent a)) (V a) + +msgVar :: String -> MsgVar a +msgVar a = MsgVar (Message a) (V a) + +newMsgVar :: (Typeable a, Show a, Eq a) => VarName -> a -> Nomex (Maybe (MsgVar a)) +newMsgVar name a = do + mv <- newVar name a + return $ mv >>= Just . MsgVar (Message name) + +newMsgVar' :: (Typeable a, Show a, Eq a) => VarName -> a -> (VEvent a -> Nomex()) -> Nomex (Maybe (MsgVar a)) +newMsgVar' name a f = do + mv <- newMsgVar name a + case mv of + Just (MsgVar m _) -> do + onMessage m $ f . messageData + return mv + Nothing -> return Nothing + +writeMsgVar :: (Typeable a, Show a, Eq a) => MsgVar a -> a -> Nomex Bool +writeMsgVar (MsgVar m v) a = do + r <- writeVar v a + sendMessage m (VUpdated a) + return r + +writeMsgVar_ :: (Typeable a, Show a, Eq a) => MsgVar a -> a -> Nomex () +writeMsgVar_ mv a = void $ writeMsgVar mv a + +readMsgVar :: (Typeable a, Show a, Eq a) => MsgVar a -> Nomex (Maybe a) +readMsgVar (MsgVar _ v) = readVar v + +readMsgVar_ :: (Typeable a, Show a, Eq a) => MsgVar a -> Nomex a +readMsgVar_ mv = partial "readMsgVar_: variable not existing" (readMsgVar mv) + +delMsgVar :: (Typeable a, Show a, Eq a) => MsgVar a -> Nomex Bool +delMsgVar (MsgVar m v) = do + sendMessage m VDeleted + delAllEvents m + delVar v + +onMsgVarChange :: (Typeable a, Show a, Eq a) => MsgVar a -> (VEvent a -> Nomex()) -> Nomex () +onMsgVarChange mv f = do + m <- getMsgVarMessage mv + onMessage m $ \(MessageData v) -> f v + +onMsgVarEvent :: (Typeable a, Show a, Eq a) + => MsgVar a + -> (a -> Nomex b) + -> (a -> b -> Nomex()) + -> (b -> Nomex()) + -> Nomex () +onMsgVarEvent mv create update delete = do + val <- readMsgVar_ mv + c <- create val + onMsgVarChange mv $ f c where + f c' (VUpdated v) = update v c' + f c' VDeleted = delete c' + + +-- | get the messsage triggered when the array is filled +getMsgVarMessage :: (Typeable a, Show a, Eq a) => (MsgVar a) -> Nomex (Msg (VEvent a)) +getMsgVarMessage (MsgVar m _) = return m + +-- | get the association array +getMsgVarData :: (Typeable a, Show a, Eq a) => (MsgVar a) -> Nomex (Maybe a) +getMsgVarData (MsgVar _ v) = readVar v + +getMsgVarData_ :: (Typeable a, Show a, Eq a) => (MsgVar a) -> Nomex a +getMsgVarData_ (MsgVar _ v) = readVar_ v + + -- * Variable arrays --- | ArrayVar is an indexed array with a signal attached to warn when the array is filled. --- | each indexed elements starts empty (value=Nothing), and when the array is full, the signal is triggered. --- | This is useful to wait for a serie of events to happen, and trigger a computation on the collected results. -data ArrayVar i a = ArrayVar (Msg [(i, Maybe a)]) (V (Map i (Maybe a))) +-- | ArrayVar is an indexed array with a signal attached triggered at every change. +-- | each indexed elements starts empty (value=Nothing). +type ArrayVar i a = MsgVar [(i, Maybe a)] -- | initialize an empty ArrayVar -newArrayVar :: (Ord i, Typeable a, Show a, Eq a, Typeable i, Show i) => VarName -> [i] -> Nomex (ArrayVar i a) +newArrayVar :: (Typeable a, Show a, Eq a, Typeable i, Show i, Eq i) => VarName -> [i] -> Nomex (Maybe (ArrayVar i a)) newArrayVar name l = do let list = map (\i -> (i, Nothing)) l - v <- newVar_ name (fromList list) - return $ ArrayVar (Message name) v + newMsgVar name list + +newArrayVar_ :: (Typeable a, Show a, Eq a, Typeable i, Show i, Eq i) => VarName -> [i] -> Nomex (ArrayVar i a) +newArrayVar_ name l = partial "newArrayVar_: Variable existing" (newArrayVar name l) --- | initialize an empty ArrayVar, registering a callback that will be triggered when the array is filled -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 +-- | initialize an empty ArrayVar, registering a callback that will be triggered at every change +newArrayVar' :: (Typeable a, Show a, Eq a, Typeable i, Show i, Eq i) => VarName -> [i] -> (VEvent [(i,Maybe a)] -> Nomex ()) -> Nomex (Maybe (ArrayVar i a)) +newArrayVar' name l f = do + let list = map (\i -> (i, Nothing)) l + newMsgVar' name list f -- | initialize an empty ArrayVar, registering a callback. ---the callback will be triggered when the array is filled, and then the ArrayVar will be deleted -newArrayVarOnce :: (Ord i, Typeable a, Show a, Eq a, Typeable i, Show i) => VarName -> [i] -> ([(i, Maybe a)] -> Nomex ()) -> Nomex (ArrayVar i a) +-- the ArrayVar will be deleted when full +newArrayVarOnce :: (Ord i, Typeable a, Show a, Eq a, Typeable i, Show i) => VarName -> [i] -> (VEvent [(i, Maybe a)] -> Nomex ()) -> Nomex (Maybe (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 - + mv <- newArrayVar' name l f + when (isJust mv) $ cleanOnFull $ fromJust mv + return mv + +cleanOnFull :: (Typeable a, Show a, Eq a, Ord i, Typeable i, Show i) => (ArrayVar i a) -> Nomex () +cleanOnFull ar = do + m <- getMsgVarMessage ar + onMessage m $ \_ -> do + full <- (isFullArrayVar_ ar) + when full $ void $ delMsgVar ar + return () + return () -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 +isFullArrayVar_ :: (Ord i, Typeable a, Show a, Eq a, Typeable i, Show i) => (ArrayVar i a) -> Nomex Bool +isFullArrayVar_ av = do + md <- getMsgVarData av + return $ and $ map isJust $ map snd $ fromJust md + -- | store one value and the given index. If this is the last filled element, the registered callbacks are triggered. -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) +putArrayVar :: (Ord i, Typeable a, Show a, Eq a, Typeable i, Show i) => (ArrayVar i a) -> i -> a -> Nomex Bool +putArrayVar mv i a = do + ma <- readMsgVar mv + case ma of + Just ar -> do + let ar2 = M.insert i (Just a) (fromList ar) + writeMsgVar mv (toList ar2) + Nothing -> return False + +putArrayVar_ :: (Ord i, Typeable a, Show a, Eq a, Typeable i, Show i) => (ArrayVar i a) -> i -> a -> Nomex () +putArrayVar_ mv i a = void $ putArrayVar mv i a --- | get the messsage triggered when the array is filled -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 + --- | get the association array -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) --- | get the association array with only the filled values -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 - -- * Events -- | register a callback on an event @@ -287,62 +347,122 @@ -- * Inputs - -inputChoice :: (Eq c, Show c) => PlayerNumber -> String -> [c] -> c -> Event (InputChoice c) -inputChoice = InputChoice + + +-- ** Radio inputs -inputChoiceHead :: (Eq c, Show c) => PlayerNumber -> String -> [c] -> Event (InputChoice c) -inputChoiceHead pn title choices = inputChoice pn title choices (head choices) +inputRadio :: (Eq c, Show c, Typeable c) => PlayerNumber -> String -> [c] -> c -> Event (Input c) +inputRadio pn title cs _ = InputEv (Input pn title (Radio (zip cs (show <$> cs)))) -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 +inputRadioHead :: (Eq c, Show c, Typeable c) => PlayerNumber -> String -> [c] -> Event (Input c) +inputRadioHead pn title choices = inputRadio pn title choices (head choices) -inputString :: PlayerNumber -> String -> Event InputString -inputString = InputString +inputRadioEnum :: forall c. (Enum c, Bounded c, Typeable c, Eq c, Show c) => PlayerNumber -> String -> c -> Event (Input c) +inputRadioEnum pn title defaultChoice = inputRadio pn title (enumFrom (minBound::c)) defaultChoice + +inputRadioData :: (Show c) => EventData (Input c) -> c +inputRadioData (InputData (RadioData a)) = a +inputRadioData a = error $ "Not a Radio Data: " ++ (show a) -- | triggers a choice input to the user. The result will be sent to the callback -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)) +onInputRadio :: (Typeable a, Eq a, Show a) => String -> [a] -> (EventNumber -> a -> Nomex ()) -> PlayerNumber -> Nomex EventNumber +onInputRadio title choices handler pn = onEvent (inputRadioHead pn title choices) (\(en, InputData (RadioData a)) -> handler en a) -- | the same, disregard the event number -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) +onInputRadio_ :: (Typeable a, Eq a, Show a) => String -> [a] -> (a -> Nomex ()) -> PlayerNumber -> Nomex () +onInputRadio_ title choices handler pn = onEvent_ (inputRadioHead pn title choices) (handler . inputRadioData) -- | the same, suppress the event after first trigger -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) +onInputRadioOnce :: (Typeable a, Eq a, Show a) => String -> [a] -> (a -> Nomex ()) -> PlayerNumber -> Nomex EventNumber +onInputRadioOnce title choices handler pn = onEventOnce (inputRadioHead pn title choices) (handler . inputRadioData) -- | the same, disregard the event number -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) +onInputRadioOnce_ :: (Typeable a, Eq a, Show a) => String -> [a] -> (a -> Nomex ()) -> PlayerNumber -> Nomex () +onInputRadioOnce_ title choices handler pn = onEventOnce_ (inputRadioHead pn title choices) (handler . inputRadioData) -- | triggers a choice input to the user, using an enumerate as input -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)) +onInputRadioEnum :: forall a. (Enum a, Bounded a, Typeable a, Eq a, Show a) => String -> a -> (EventNumber -> a -> Nomex ()) -> PlayerNumber -> Nomex EventNumber +onInputRadioEnum title defaultChoice handler pn = onEvent (inputRadioEnum pn title defaultChoice) (\(en, a) -> handler en (inputRadioData a)) -- | the same, disregard the event number -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) +onInputRadioEnum_ :: forall a. (Enum a, Bounded a, Typeable a, Eq a, Show a) => String -> a -> (a -> Nomex ()) -> PlayerNumber -> Nomex () +onInputRadioEnum_ title defaultChoice handler pn = onEvent_ (inputRadioEnum pn title defaultChoice) (handler . inputRadioData) -- | the same, suppress the event after first trigger -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) +onInputRadioEnumOnce_ :: forall a. (Enum a, Bounded a, Typeable a, Eq a, Show a) => String -> a -> (a -> Nomex ()) -> PlayerNumber -> Nomex () +onInputRadioEnumOnce_ title defaultChoice handler pn = onEventOnce_ (inputRadioEnum pn title defaultChoice) (handler . inputRadioData) +-- ** Text inputs +inputText :: PlayerNumber -> String -> Event (Input String) +inputText pn title = InputEv (Input pn title Text) + +inputTextData :: EventData (Input String) -> String +inputTextData (InputData (TextData a)) = a +inputTextData a = error $ "Not a Text Data: " ++ (show a) + -- | triggers a string input to the user. The result will be sent to the callback -onInputString :: String -> (EventNumber -> String -> Nomex ()) -> PlayerNumber -> Nomex EventNumber -onInputString title handler pn = onEvent (inputString pn title) (\(en, a) -> handler en (inputStringData a)) +onInputText :: String -> (EventNumber -> String -> Nomex ()) -> PlayerNumber -> Nomex EventNumber +onInputText title handler pn = onEvent (inputText pn title) (\(en, a) -> handler en (inputTextData a)) -- | asks the player pn to answer a question, and feed the callback with this data. -onInputString_ :: String -> (String -> Nomex ()) -> PlayerNumber -> Nomex () -onInputString_ title handler pn = onEvent_ (inputString pn title) (handler . inputStringData) +onInputText_ :: String -> (String -> Nomex ()) -> PlayerNumber -> Nomex () +onInputText_ title handler pn = onEvent_ (inputText pn title) (handler . inputTextData) -- | asks the player pn to answer a question, and feed the callback with this data. -onInputStringOnce_ :: String -> (String -> Nomex ()) -> PlayerNumber -> Nomex () -onInputStringOnce_ title handler pn = onEventOnce_ (inputString pn title) (handler . inputStringData) +onInputTextOnce_ :: String -> (String -> Nomex ()) -> PlayerNumber -> Nomex () +onInputTextOnce_ title handler pn = onEventOnce_ (inputText pn title) (handler . inputTextData) + +-- ** Checkbox inputs + +inputCheckboxData :: (Show c) => EventData (Input c) -> [c] +inputCheckboxData (InputData (CheckboxData a)) = a +inputCheckboxData a = error $ "Not a Checkbox Data: " ++ (show a) + +inputCheckbox :: (Eq c, Show c, Typeable c) => PlayerNumber -> String -> [(c, String)] -> Event (Input c) +inputCheckbox pn title cs = InputEv (Input pn title (Checkbox cs)) + +onInputCheckbox :: (Typeable a, Eq a, Show a) => String -> [(a, String)] -> (EventNumber -> [a] -> Nomex ()) -> PlayerNumber -> Nomex EventNumber +onInputCheckbox title choices handler pn = onEvent (inputCheckbox pn title choices) (\(en, InputData (CheckboxData a)) -> handler en a) + +onInputCheckbox_ :: (Typeable a, Eq a, Show a) => String -> [(a, String)] -> ([a] -> Nomex ()) -> PlayerNumber -> Nomex () +onInputCheckbox_ title choices handler pn = onEvent_ (inputCheckbox pn title choices) (handler . inputCheckboxData) + +-- ** Button inputs + +inputButtonData :: EventData (Input ()) -> () +inputButtonData (InputData ButtonData) = () +inputButtonData a = error $ "Not a Button Data: " ++ (show a) + +inputButton :: PlayerNumber -> String -> Event (Input ()) +inputButton pn title = InputEv (Input pn title Button) + +onInputButton :: String -> (EventNumber -> () -> Nomex ()) -> PlayerNumber -> Nomex EventNumber +onInputButton title handler pn = onEvent (inputButton pn title) (\(en, InputData ButtonData) -> handler en ()) + +onInputButton_ :: String -> (() -> Nomex ()) -> PlayerNumber -> Nomex () +onInputButton_ title handler pn = onEvent_ (inputButton pn title) (handler . inputButtonData) + +-- ** Textarea inputs + +inputTextareaData :: EventData (Input String) -> String +inputTextareaData (InputData (TextAreaData a)) = a +inputTextareaData a = error $ "Not a Textarea Data: " ++ (show a) + +inputTextarea :: PlayerNumber -> String -> Event (Input String) +inputTextarea pn title = InputEv (Input pn title TextArea) + +onInputTextarea :: String -> (EventNumber -> String -> Nomex ()) -> PlayerNumber -> Nomex EventNumber +onInputTextarea title handler pn = onEvent (inputTextarea pn title) (\(en, a) -> handler en (inputTextareaData a)) --- * Victory, players +onInputTextarea_ :: String -> (String -> Nomex ()) -> PlayerNumber -> Nomex () +onInputTextarea_ title handler pn = onEvent_ (inputTextarea pn title) (handler . inputTextareaData) +onInputTextareaOnce_ :: String -> (String -> Nomex ()) -> PlayerNumber -> Nomex () +onInputTextareaOnce_ title handler pn = onEventOnce_ (inputTextarea pn title) (handler . inputTextareaData) + +-- * Players + -- | get all the players getPlayers :: Nomex [PlayerInfo] getPlayers = GetPlayers @@ -382,10 +502,50 @@ delPlayer :: PlayerNumber -> Nomex Bool delPlayer = DelPlayer +-- * Outputs + +-- | outputs a message to one player +newOutput :: String -> PlayerNumber -> Nomex OutputNumber +newOutput s pn = NewOutput pn s +newOutput_ :: String -> PlayerNumber -> Nomex () +newOutput_ s pn = void $ NewOutput pn s --- * Victory, output, time and self-number +outputAll :: String -> Nomex () +outputAll s = getPlayers >>= mapM_ ((newOutput s) . _playerNumber) + +updateOutput :: OutputNumber -> String -> Nomex Bool +updateOutput = UpdateOutput + +updateOutput_ :: OutputNumber -> String -> Nomex () +updateOutput_ on s = void $ updateOutput on s + +delOutput :: OutputNumber -> Nomex Bool +delOutput = DelOutput + +delOutput_ :: OutputNumber -> Nomex () +delOutput_ on = void $ delOutput on + +-- permanently display a variable (update display when variable is updated) +displayVar :: (Typeable a, Show a, Eq a) => PlayerNumber -> MsgVar a -> (a -> String) -> Nomex () +displayVar pn mv dis = onMsgVarEvent + mv + (\a -> newOutput (dis a) pn) + (\a n -> updateOutput_ n (dis a)) + delOutput_ + +displaySimpleVar :: (Typeable a, Show a, Eq a) => PlayerNumber -> String -> MsgVar a -> Nomex () +displaySimpleVar pn title mv = displayVar pn mv (\a -> title ++ ": " ++ (show a) ++ "\n") + +displayArrayVar :: (Typeable a, Show a, Eq a, Typeable i, Show i, Eq i) => PlayerNumber -> String -> ArrayVar i a -> Nomex () +displayArrayVar pn title mv = displayVar pn mv (showArrayVar title) + +showArrayVar :: (Show a, Show i) => String -> [(i,a)] -> String +showArrayVar title l = title ++ "\n" ++ + concatMap (\(i,a) -> (show i) ++ "\t" ++ (show a) ++ "\n") l +-- * Victory, time and self-number + -- | set victory to a list of players setVictory :: [PlayerNumber] -> Nomex () setVictory = SetVictory @@ -394,17 +554,10 @@ giveVictory :: PlayerNumber -> Nomex () giveVictory pn = SetVictory [pn] --- | outputs a message to one player -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 --- | allows a rule to retrieve its self number (for auto-deleting for example) +-- | allows a rule to retrieve its own number (for auto-deleting for example) getSelfRuleNumber :: Nomex RuleNumber getSelfRuleNumber = SelfRuleNumber @@ -416,11 +569,9 @@ getSelfProposedByPlayer :: Nomex PlayerNumber getSelfProposedByPlayer = getSelfRule >>= return . _rProposedBy - + -- * Miscellaneous - - voidRule :: Nomex a -> Nomex RuleResp voidRule e = e >> return Void @@ -453,8 +604,16 @@ 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 m (VUpdated ((_, Just a):(_, Just b):[])) = sendMessage m $ a && b f _ _ = return () + + +partial :: String -> Nomex (Maybe a) -> Nomex a +partial s nm = do + m <- nm + case m of + Just a -> return a + Nothing -> throwError s -- | a default rule diff --git a/src/Language/Nomyx/Evaluation.hs b/src/Language/Nomyx/Evaluation.hs --- a/src/Language/Nomyx/Evaluation.hs +++ b/src/Language/Nomyx/Evaluation.hs @@ -2,7 +2,7 @@ module Language.Nomyx.Evaluation where -import Prelude hiding ((.)) +import Prelude hiding ((.), log) import Language.Nomyx.Utils import Control.Monad import Control.Monad.State.Lazy @@ -14,11 +14,9 @@ import Control.Category import Control.Monad.Error (ErrorT(..)) import Control.Monad.Error.Class (MonadError(..)) -import Language.Nomyx.Definition (outputAll) import Control.Applicative ((<$>)) import Language.Nomyx.Expression - type Evaluate a = ErrorT String (State Game) a -- | evaluate an expression. @@ -32,7 +30,6 @@ return $ Just (V name) Just _ -> return Nothing - evalExp (DelVar (V name)) _ = do vars <- access variables case find ((== name) . getL vName) vars of @@ -50,19 +47,18 @@ Just v -> return $ Just v Nothing -> return Nothing -evalExp (WriteVar (V name) val) rn = do +evalExp (WriteVar (V name) val) _ = do vars <- access variables - let newVars = replaceWith ((== name) . getL vName) (Var rn name val) vars case find (\(Var _ myName _) -> myName == name) vars of Nothing -> return False - Just _ -> do - variables ~= newVars + Just (Var rn myName _) -> do + variables %= replaceWith ((== name) . getL vName) (Var rn myName val) return True evalExp (OnEvent event handler) rn = do evs <- access events let en = getFreeNumber (map _eventNumber evs) - events %= ((EH en rn event handler EvActive) : ) + events %= ((EH en rn event handler SActive) : ) return en evalExp (DelEvent en) _ = evDelEvent en @@ -70,17 +66,17 @@ evalExp (DelAllEvents e) _ = do evs <- access events let filtered = filter (\EH {event} -> event === e) evs - --traceM ("DelAllEvents: deleting " ++ show filtered) mapM_ (\e -> evDelEvent e) (_eventNumber <$> filtered) evalExp (SendMessage (Message id) myData) _ = triggerEvent_ (Message id) (MessageData myData) -evalExp (Output pn string) _ = outputS pn string >> return () +evalExp (NewOutput pn s) rn = evNewOutput pn rn s +evalExp (UpdateOutput on s) _ = evUpdateOutput on s +evalExp (DelOutput on) _ = evDelOutput on evalExp (ProposeRule rule) _ = evProposeRule rule evalExp (ActivateRule rule) rn = evActivateRule rule rn evalExp (RejectRule rule) rn = evRejectRule rule rn evalExp (AddRule rule) _ = evAddRule rule -evalExp (DelRule del) _ = evDelRule del evalExp (ModifyRule mod rule) _ = evModifyRule mod rule evalExp GetRules _ = access rules evalExp GetPlayers _ = access players @@ -97,8 +93,6 @@ let victorious = filter (\pl -> _playerNumber pl `elem` ps) pls triggerEvent_ Victory (VictoryData victorious) - - evalExp (Bind exp f) rn = do a <- evalExp exp rn evalExp (f a) rn @@ -108,36 +102,42 @@ triggerEvent :: (Typeable e, Show e, Eq e) => Event e -> EventData e -> Evaluate Bool triggerEvent e dat = do evs <- access events - let filtered = filter (\(EH {event, _evStatus}) -> e === event && _evStatus == EvActive) evs + let filtered = filter (\(EH {event, _evStatus}) -> e === event && _evStatus == SActive) (reverse evs) case filtered of - [] -> do - --traceM $ "triggerEvent: Event not found:" ++ (show e) - return False + [] -> return False xs -> do - mapM_ f xs - return True where - f (EH {_ruleNumber, _eventNumber, handler}) = case cast handler of - Just castedH -> do - let (exp :: Nomex ()) = castedH (_eventNumber, dat) - evalExp (exp `catchError` errorHandler) _ruleNumber - Nothing -> outputS 1 ("failed " ++ (show $ typeOf handler)) + mapM_ (triggerHandler dat) xs + return True + +triggerHandler :: (Typeable e, Show e, Eq e) => EventData e -> EventHandler -> Evaluate () +triggerHandler dat (EH {_ruleNumber, _eventNumber, handler}) = case cast handler of + Just castedH -> do + let (exp :: Nomex ()) = castedH (_eventNumber, dat) + (evalExp exp _ruleNumber) `catchError` (errorHandler _ruleNumber _eventNumber) + Nothing -> logAll ("failed " ++ (show $ typeOf handler)) + triggerEvent_ :: (Typeable e, Show e, Eq e) => Event e -> EventData e -> Evaluate () triggerEvent_ e ed = void $ triggerEvent e ed -errorHandler :: String -> Nomex () -errorHandler s = outputAll $ "Error: " ++ s +errorHandler :: RuleNumber -> EventNumber -> String -> Evaluate () +errorHandler rn en s = logAll $ "Error in rule " ++ (show rn) ++ " (triggered by event " ++ (show en) ++ "): " ++ s -triggerChoice :: EventNumber -> Int -> Evaluate () -triggerChoice en choiceIndex = do +-- trigger the input event with the input data +triggerInput :: EventNumber -> UInputData -> Evaluate () +triggerInput en ir = do evs <- access events let filtered = filter ((== en) . getL eventNumber) evs - mapM_ (execChoiceHandler en choiceIndex) filtered - -execChoiceHandler :: EventNumber -> Int -> EventHandler -> Evaluate () -execChoiceHandler eventNumber choiceIndex (EH _ rn (InputChoice _ _ cs _) handler _) = evalExp (handler (eventNumber, InputChoiceData (cs!!choiceIndex))) rn -execChoiceHandler _ _ _ = return () + mapM_ (execInputHandler ir) filtered +-- execute the event handler using the data received from user +execInputHandler :: UInputData -> EventHandler -> Evaluate () +execInputHandler (UTextData s) (EH en rn (InputEv (Input _ _ Text)) h SActive) = evalExp (h (en, InputData $ TextData s)) rn +execInputHandler (UTextAreaData s) (EH en rn (InputEv (Input _ _ TextArea)) h SActive) = evalExp (h (en, InputData $ TextAreaData s)) rn +execInputHandler (UButtonData) (EH en rn (InputEv (Input _ _ Button)) h SActive) = evalExp (h (en, InputData $ ButtonData)) rn +execInputHandler (URadioData i) (EH en rn (InputEv (Input _ _ (Radio cs))) h SActive) = evalExp (h (en, InputData $ RadioData $ fst $ cs!!i)) rn +execInputHandler (UCheckboxData is) (EH en rn (InputEv (Input _ _ (Checkbox cs))) h SActive) = evalExp (h (en, InputData $ CheckboxData $ fst <$> cs `sel` is)) rn +execInputHandler _ _ = return () findEvent :: EventNumber -> [EventHandler] -> Maybe (EventHandler) findEvent en evs = find ((== en) . getL eventNumber) evs @@ -146,11 +146,9 @@ getChoiceEvents = do evs <- access events return $ map _eventNumber $ filter choiceEvent evs - where choiceEvent (EH _ _ (InputChoice _ _ _ _) _ _) = True + where choiceEvent (EH _ _ (InputEv (Input _ _ (Radio _))) _ _) = True choiceEvent _ = False -outputS :: PlayerNumber -> String -> Evaluate () -outputS pn s = void $ outputs %= ((pn, s) : ) evProposeRule :: Rule -> Evaluate Bool evProposeRule rule = do @@ -166,7 +164,7 @@ evActivateRule :: RuleNumber -> RuleNumber -> Evaluate Bool evActivateRule rn by = do rs <- access rules - case find ((== rn) . getL rNumber) rs of + case find (\r -> _rNumber r == rn && _rStatus r /= Active) rs of Nothing -> return False Just r -> do let newrules = replaceWith ((== rn) . getL rNumber) r{_rStatus = Active, _rAssessedBy = Just by} rs @@ -179,7 +177,7 @@ evRejectRule :: RuleNumber -> RuleNumber -> Evaluate Bool evRejectRule rn by = do rs <- access rules - case find ((== rn) . getL rNumber) rs of + case find (\r -> _rNumber r == rn && _rStatus r /= Reject) rs of Nothing -> return False Just r -> do let newrules = replaceWith ((== rn) . getL rNumber) r{_rStatus = Reject, _rAssessedBy = Just by} rs @@ -199,18 +197,6 @@ return True Just _ -> return False -evDelRule :: RuleNumber -> Evaluate Bool -evDelRule del = do - rs <- access rules - case find ((== del) . getL rNumber) rs of - Nothing -> return False - Just r -> do - let newRules = filter ((/= del) . getL rNumber) rs - rules ~= newRules - delVarsRule del - delEventsRule del - triggerEvent_ (RuleEv Deleted) (RuleData r) - return True --TODO: clean and execute new rule evModifyRule :: RuleNumber -> Rule -> Evaluate Bool @@ -265,17 +251,15 @@ return False Just eh -> do case (_evStatus eh) of - EvActive -> do + SActive -> do --traceM ("DelEvent: deleting event en=" ++ (show en) ++ " rn=" ++ (show rn)) - let newEvents = replaceWith ((== en) . getL eventNumber) eh{_evStatus = EvDeleted} evs + let newEvents = replaceWith ((== en) . getL eventNumber) eh{_evStatus = SDeleted} evs events ~= newEvents return True - EvDeleted -> do + SDeleted -> do --traceM ("DelEvent: Event already deleted! en=" ++ (show en) ++ "rn event=" ++ (show $ _ruleNumber eh) ++ " rn=" ++ (show rn)) return False -evInputChoice :: (Eq d, Show d, Typeable d, Read d) => Event(InputChoice d) -> d -> Evaluate Bool -evInputChoice ic d = triggerEvent ic (InputChoiceData d) evTriggerTime :: UTCTime -> Evaluate Bool evTriggerTime t = triggerEvent (Time t) (TimeData t) @@ -292,6 +276,50 @@ let toDelete = filter ((== rn) . getL ruleNumber) evs mapM_ (evDelEvent . _eventNumber) toDelete + +evNewOutput :: PlayerNumber -> RuleNumber -> String -> Evaluate OutputNumber +evNewOutput pn rn s = do + ops <- access outputs + let on = getFreeNumber (map _outputNumber ops) + outputs %= ((Output on rn pn s SActive) : ) + return on + +evUpdateOutput :: OutputNumber -> String -> Evaluate Bool +evUpdateOutput on s = do + ops <- access outputs + case find (\(Output myOn _ _ _ s) -> myOn == on && s == SActive) ops of + Nothing -> return False + Just (Output _ rn pn _ _) -> do + outputs %= replaceWith ((== on) . getL outputNumber) (Output on rn pn s SActive) + return True + +evDelOutput :: OutputNumber -> Evaluate Bool +evDelOutput on = do + ops <- access outputs + case find ((== on) . getL outputNumber) ops of + Nothing -> do + return False + Just o -> do + case (_oStatus o) of + SActive -> do + let newOutputs = replaceWith ((== on) . getL outputNumber) o{_oStatus = SDeleted} ops + outputs ~= newOutputs + return True + SDeleted -> do + return False + +logPlayer :: PlayerNumber -> String -> Evaluate () +logPlayer pn s = log (Just pn) s + +logAll :: String -> Evaluate () +logAll s = log Nothing s + +log :: Maybe PlayerNumber -> String -> Evaluate () +log mpn s = do + time <- access currentTime + void $ logs %= (Log mpn time s : ) + + runEvalError :: PlayerNumber -> Evaluate () -> State Game () runEvalError pn egs = do e <- runErrorT egs @@ -299,4 +327,4 @@ Right gs -> return gs Left e -> do tracePN pn $ "Error: " ++ e - void $ outputs %= ((pn, "Error: " ++ e) : ) + void $ runErrorT (logPlayer pn "Error: ") diff --git a/src/Language/Nomyx/Examples.hs b/src/Language/Nomyx/Examples.hs --- a/src/Language/Nomyx/Examples.hs +++ b/src/Language/Nomyx/Examples.hs @@ -7,7 +7,8 @@ module Language.Nomyx.Examples(nothing, helloWorld, accounts, createBankAccount, winXEcuPerDay, winXEcuOnRuleAccepted, moneyTransfer, delRule, voteWithMajority, king, makeKing, monarchy, revolution, victoryXRules, victoryXEcu, displayTime, noGroupVictory, iWin, returnToDemocracy, - banPlayer, referendum, referendumOnKickPlayer, gameMasterElections, gameMaster, + banPlayer, referendum, referendumOnKickPlayer, gameMasterElections, gameMaster, bravoButton, + enterHaiku, module Data.Time.Recurrence, module Control.Monad, module Data.List, module Data.Time.Clock) where import Language.Nomyx.Definition @@ -22,6 +23,7 @@ import Language.Nomyx.Vote (elections, referendum, assessOnTimeDelay, assessOnEveryVote, withQuorum, majority, voteWith_) import Language.Nomyx.Utils (oneDay) +import Safe (readDef) -- | A rule that does nothing nothing :: RuleFunc @@ -54,13 +56,13 @@ moneyTransfer = voidRule $ do pls <- getAllPlayerNumbers when (length pls >= 2) $ forEachPlayer_ (selPlayer pls) where - selPlayer pls src = onInputChoice_ "Transfer money to player: " (delete src $ sort pls) (selAmount src) src - selAmount src dst = onInputStringOnce_ ("Select Amount to transfert to player: " ++ show dst) (transfer src dst) src + selPlayer pls src = onInputRadio_ "Transfer money to player: " (delete src $ sort pls) (selAmount src) src + selAmount src dst = onInputTextOnce_ ("Select Amount to transfert to player: " ++ show dst) (transfer src dst) src transfer src dst amount = do - modifyValueOfPlayer dst accounts (\a -> a + (read amount)) - modifyValueOfPlayer src accounts (\a -> a - (read amount)) - output ("You gave " ++ amount ++ " to " ++ show dst) src - output (show src ++ " gaved you " ++ amount ++ " Ecus") dst + modifyValueOfPlayer dst accounts (\a -> a + (readDef 0 amount)) + modifyValueOfPlayer src accounts (\a -> a - (readDef 0 amount)) + newOutput_ ("You gave " ++ amount ++ " to " ++ show dst) src + newOutput_ (show src ++ " gaved you " ++ amount ++ " Ecus") dst -- | delete a rule @@ -81,7 +83,7 @@ monarchy :: RuleFunc monarchy = voidRule $ onEvent_ (RuleEv Proposed) $ \(RuleData rule) -> do k <- readVar_ king - onInputChoiceEnumOnce_ ("Your Royal Highness, do you accept rule " ++ (show $ _rNumber rule) ++ "?") True (activateOrReject rule) k + onInputRadioEnumOnce_ ("Your Royal Highness, do you accept rule " ++ (show $ _rNumber rule) ++ "?") True (activateOrReject rule) k -- | Revolution! Hail to the king! @@ -165,3 +167,10 @@ gameMaster :: V PlayerNumber gameMaster = V "GameMaster" + +-- | display a button and greets you when pressed (for player 1) +bravoButton :: RuleFunc +bravoButton = voidRule $ voidRule $ onInputButton_ "Click here:" (const $ outputAll "Bravo!") 1 + +enterHaiku :: RuleFunc +enterHaiku = voidRule $ onInputTextarea_ "Enter a haiku:" outputAll 1 diff --git a/src/Language/Nomyx/Expression.hs b/src/Language/Nomyx/Expression.hs --- a/src/Language/Nomyx/Expression.hs +++ b/src/Language/Nomyx/Expression.hs @@ -34,8 +34,10 @@ type EventName = String type VarName = String type GameName = String -type Code = String +type Code = String +type OutputNumber = Int + -- * Nomyx Expression -- | A Nomex (Nomyx Expression) allows the players to write rules. @@ -57,16 +59,18 @@ ActivateRule :: RuleNumber -> Nomex Bool RejectRule :: RuleNumber -> Nomex Bool AddRule :: Rule -> Nomex Bool - DelRule :: RuleNumber -> Nomex Bool ModifyRule :: RuleNumber -> Rule -> Nomex Bool GetRules :: Nomex [Rule] --Players management GetPlayers :: Nomex [PlayerInfo] SetPlayerName:: PlayerNumber -> PlayerName -> Nomex Bool DelPlayer :: PlayerNumber -> Nomex Bool + --Output + NewOutput :: PlayerNumber -> String -> Nomex OutputNumber + UpdateOutput :: OutputNumber -> String -> Nomex Bool + DelOutput :: OutputNumber -> Nomex Bool --Mileacenous SetVictory :: [PlayerNumber] -> Nomex () - Output :: PlayerNumber -> String -> Nomex () CurrentTime :: Nomex UTCTime SelfRuleNumber :: Nomex RuleNumber --Monadic bindings @@ -75,7 +79,6 @@ ThrowError :: String -> Nomex a CatchError :: Nomex a -> (String -> Nomex a) -> Nomex a deriving (Typeable) - instance Monad Nomex where return = Return @@ -95,10 +98,10 @@ throwError = ThrowError catchError = CatchError -instance Show a => Show (Nomex a) where - show _ = "Nomex" -- ++ (show a) +instance Typeable a => Show (Nomex a) where + show e = '<' : (show . typeOf) e ++ ">" - + -- * Variables -- | a container for a variable name and type @@ -106,19 +109,16 @@ -- | stores the variable's data data Var = forall a . (Typeable a, Show a, Eq a) => - Var { _vRuleNumber :: Int, - _vName :: String, - vData :: a} + Var { _vRuleNumber :: RuleNumber, + _vName :: String, + vData :: a} instance Show Var where - show (Var a b c) = (show a) ++ " " ++ (show b) ++ " " ++ (show c) + show (Var a b c) = "Rule number = " ++ (show a) ++ ", Name = " ++ (show b) ++ ", Value = " ++ (show c) ++ "\n" instance Eq Var where Var a b c == Var d e f = (a,b,c) === (d,e,f) -type Output = (PlayerNumber, String) - -type Id a = a -- * Events -- | events types @@ -127,48 +127,67 @@ data Time deriving Typeable data EvRule deriving Typeable data Message m deriving Typeable -data InputChoice c deriving Typeable -data InputString deriving Typeable -data Victory deriving Typeable +data Victory deriving Typeable +data Input a = Input PlayerNumber String (InputForm a) +data InputForm a = Radio [(a, String)] + | Text + | TextArea + | Button + | Checkbox [(a, String)] -- | events names data Event a where - Player :: Player -> Event Player - RuleEv :: RuleEvent -> Event RuleEvent - Time :: UTCTime -> Event Time - Message :: String -> Event (Message m) - InputChoice :: (Eq c, Show c) => PlayerNumber -> String -> [c] -> c -> Event (InputChoice c) - InputString :: PlayerNumber -> String -> Event InputString - Victory :: Event Victory - + Player :: Player -> Event Player + RuleEv :: RuleEvent -> Event RuleEvent + Time :: UTCTime -> Event Time + Message :: String -> Event (Message m) + InputEv :: (Eq a, Show a, Typeable a) => Input a -> Event (Input a) + Victory :: Event Victory + +-- data sent back by inputs +data InputData a = RadioData a + | CheckboxData [a] + | TextData String + | TextAreaData String + | ButtonData +-- an untyped version of InputData for serialization +data UInputData = URadioData Int + | UCheckboxData [Int] + | UTextData String + | UTextAreaData String + | UButtonData + deriving (Show, Read, Eq, Ord) + -- | data associated with each events data EventData a where - PlayerData :: {playerData :: PlayerInfo} -> EventData Player - RuleData :: {ruleData :: Rule} -> EventData RuleEvent - TimeData :: {timeData :: UTCTime} -> EventData Time - MessageData :: (Show m) => {messageData :: m} -> EventData (Message m) - InputChoiceData :: (Show c) => {inputChoiceData :: c} -> EventData (InputChoice c) - InputStringData :: {inputStringData :: String} -> EventData InputString - VictoryData :: {victoryData :: [PlayerInfo]} -> EventData Victory + PlayerData :: {playerData :: PlayerInfo} -> EventData Player + RuleData :: {ruleData :: Rule} -> EventData RuleEvent + TimeData :: {timeData :: UTCTime} -> EventData Time + MessageData :: (Show m) => {messageData :: m} -> EventData (Message m) + InputData :: (Show a) => {inputData :: InputData a} -> EventData (Input a) + VictoryData :: {victoryData :: [PlayerInfo]} -> EventData Victory deriving instance Typeable1 EventData -deriving instance Typeable1 Event -deriving instance (Show a) => Show (Event a) +deriving instance Typeable1 Event +deriving instance Typeable1 Input +deriving instance Typeable1 InputForm +deriving instance (Show a) => Show (Event a) +deriving instance (Show a) => Show (InputForm a) +deriving instance (Show a) => Show (Input a) deriving instance (Show a) => Show (EventData a) +deriving instance (Show a) => Show (InputData a) deriving instance (Show a) => Show (Message a) -deriving instance (Show a) => Show (InputChoice a) deriving instance Show Time -deriving instance Show InputString deriving instance Show Victory deriving instance Eq Time deriving instance Eq Victory deriving instance Eq EvRule -deriving instance Eq (InputChoice a) -deriving instance Eq InputString deriving instance Eq (Message m) -deriving instance (Eq e) => Eq (Event e) +deriving instance (Eq e) => Eq (Event e) +deriving instance (Eq e) => Eq (Input e) +deriving instance (Eq e) => Eq (InputForm e) -data EventStatus = EvActive | EvDeleted deriving (Eq, Show) +data Status = SActive | SDeleted deriving (Eq, Show) data EventHandler where EH :: (Typeable e, Show e, Eq e) => @@ -176,7 +195,7 @@ _ruleNumber :: RuleNumber, event :: Event e, handler :: (EventNumber, EventData e) -> Nomex (), - _evStatus :: EventStatus} -> EventHandler + _evStatus :: Status} -> EventHandler instance Show EventHandler where show (EH en rn e _ _) = (show en) ++ " " ++ (show rn) ++ " (" ++ (show e) ++"),\n" @@ -189,6 +208,22 @@ type Msg a = Event (Message a) type MsgData a = EventData (Message a) + +-- * Outputs + +data Output = Output { _outputNumber :: OutputNumber, + _oRuleNumber :: PlayerNumber, + _oPlayerNumber :: PlayerNumber, + _output :: String, + _oStatus :: Status} + deriving (Show) + +-- * Logs + +data Log = Log { _lPlayerNumber :: Maybe PlayerNumber, + _lTime :: UTCTime, + _lMsg :: String} + deriving (Show) -- * Rule @@ -204,7 +239,6 @@ --An extended type for booleans supporting immediate or delayed response (through a message) data BoolResp = BoolResp Bool | MsgResp (Msg Bool) - instance Show RuleResp where show _ = "RuleResp" @@ -242,18 +276,20 @@ _playerName :: String} deriving (Eq, Typeable, Show) --- * Game +-- * Game + -- | The state of the game: -data Game = Game { _gameName :: GameName, - _gameDesc :: GameDesc, - _rules :: [Rule], - _players :: [PlayerInfo], - _variables :: [Var], - _events :: [EventHandler], - _outputs :: [Output], - _victory :: [PlayerNumber], - _currentTime :: UTCTime +data Game = Game { _gameName :: GameName, + _gameDesc :: GameDesc, + _rules :: [Rule], + _players :: [PlayerInfo], + _variables :: [Var], + _events :: [EventHandler], + _outputs :: [Output], + _victory :: [PlayerNumber], + _logs :: [Log], + _currentTime :: UTCTime } deriving (Typeable) @@ -272,31 +308,31 @@ Punc "{" <- lexP; Ident "_gameName" <- lexP; Punc "=" <- lexP; - a1 <- reset readPrec; + name <- reset readPrec; Punc "," <- lexP; Ident "_gameDesc" <- lexP; Punc "=" <- lexP; - a2 <- reset readPrec; + desc <- reset readPrec; Punc "," <- lexP; Ident "_currentTime" <- lexP; Punc "=" <- lexP; - a3 <- reset readPrec; + time <- reset readPrec; Punc "}" <- lexP; - return $ Game a1 a2 [] [] [] [] [] [] a3 + return $ Game name desc [] [] [] [] [] [] [] time readList = readListDefault readListPrec = readListPrecDefault instance Show Game where - showsPrec p(Game b1 b2 _ _ _ _ _ _ b3) = showParen (p >= 11) $ + showsPrec p(Game name desc _ _ _ _ _ _ _ time) = showParen (p >= 11) $ showString "Game {" . showString "_gameName = " . - showsPrec 0 b1 . + showsPrec 0 name . showString ", " . showString "_gameDesc = " . - showsPrec 0 b2 . + showsPrec 0 desc . showString ", " . showString "_currentTime = " . - showsPrec 0 b3 . + showsPrec 0 time . showString "}" showList = showList__ (showsPrec 0) @@ -305,5 +341,5 @@ "Game Name = " ++ (show _gameName) ++ "\n Rules = " ++ (concat $ intersperse "\n " $ map show _rules) ++ "\n Players = " ++ (show _players) ++ "\n Variables = " ++ (show _variables) ++ "\n Events = " ++ (show _events) ++ "\n Outputs = " ++ (show _outputs) ++ "\n Victory = " ++ (show _victory) ++ "\n currentTime = " ++ (show _currentTime) ++ "\n" -$( makeLenses [''Game, ''GameDesc, ''Rule, ''PlayerInfo, ''EventHandler, ''Var] ) +$( makeLenses [''Game, ''GameDesc, ''Rule, ''PlayerInfo, ''EventHandler, ''Var, ''Output] ) diff --git a/src/Language/Nomyx/Game.hs b/src/Language/Nomyx/Game.hs --- a/src/Language/Nomyx/Game.hs +++ b/src/Language/Nomyx/Game.hs @@ -1,5 +1,5 @@ {-# LANGUAGE StandaloneDeriving, GADTs, DeriveDataTypeable, - FlexibleContexts, GeneralizedNewtypeDeriving, + FlexibleContexts, GeneralizedNewtypeDeriving, ScopedTypeVariables, MultiParamTypeClasses, TemplateHaskell, TypeFamilies, TypeOperators, FlexibleInstances, NoMonomorphismRestriction, TypeSynonymInstances, DoAndIfThenElse, RecordWildCards #-} @@ -8,9 +8,10 @@ -- a game is a set of rules, and results of actions made by players (usually vote results) -- the module manages the effects of rules over each others. module Language.Nomyx.Game (GameEvent(..), update, update', LoggedGame(..), game, gameLog, emptyGame, - execWithGame, execWithGame', outputAll, getLoggedGame, tracePN, getTimes, activeRules, pendingRules, rejectedRules) where + execWithGame, execWithGame', getLoggedGame, tracePN, getTimes, activeRules, pendingRules, + rejectedRules, UInputData(..)) where -import Prelude +import Prelude hiding (log) import Control.Monad.State import Data.List import Language.Nomyx hiding (outputAll) @@ -18,7 +19,7 @@ import Control.Category ((>>>)) import Data.Lens.Template import Control.Exception - +import Control.Monad.Trans.State hiding (get) data TimedEvent = TimedEvent UTCTime GameEvent deriving (Show, Read, Eq, Ord) @@ -26,9 +27,8 @@ | JoinGame PlayerNumber PlayerName | LeaveGame PlayerNumber | ProposeRuleEv PlayerNumber SubmitRule - | InputChoiceResult PlayerNumber EventNumber Int - | InputStringResult PlayerNumber String String - | OutputPlayer PlayerNumber String + | InputResult PlayerNumber EventNumber UInputData + | GLog (Maybe PlayerNumber) String | TimeEvent UTCTime | SystemAddRule SubmitRule deriving (Show, Read, Eq, Ord) @@ -54,6 +54,7 @@ _events = [], _outputs = [], _victory = [], + _logs = [], _currentTime = date} $( makeLens ''LoggedGame) @@ -64,19 +65,25 @@ enactEvent (JoinGame pn name) _ = mapStateIO $ joinGame name pn enactEvent (LeaveGame pn) _ = mapStateIO $ leaveGame pn enactEvent (ProposeRuleEv pn sr) (Just inter) = void $ proposeRule sr pn inter -enactEvent (InputChoiceResult pn en ci) _ = mapStateIO $ inputChoiceResult en ci pn -enactEvent (InputStringResult pn ti res) _ = mapStateIO $ inputStringResult (InputString pn ti) res pn -enactEvent (OutputPlayer pn s) _ = mapStateIO $ outputPlayer s pn +enactEvent (InputResult pn en ir) _ = mapStateIO $ inputResult pn en ir +enactEvent (GLog mpn s) _ = mapStateIO $ logGame s mpn enactEvent (TimeEvent t) _ = mapStateIO $ runEvalError 0 $ void $ evTriggerTime t enactEvent (SystemAddRule r) (Just inter) = systemAddRule r inter enactEvent (ProposeRuleEv _ _) Nothing = error "ProposeRuleEv: interpreter function needed" enactEvent (SystemAddRule _) Nothing = error "SystemAddRule: interpreter function needed" enactTimedEvent :: Maybe (RuleCode -> IO RuleFunc) -> TimedEvent -> StateT Game IO () -enactTimedEvent inter (TimedEvent t ge) = do +enactTimedEvent inter (TimedEvent t ge) = flip stateCatch updateError $ do currentTime ~= t enactEvent ge inter + lg <- get + lift $ evaluate lg + return () +updateError :: SomeException -> StateT Game IO () +updateError e = do + liftIO $ putStrLn $ "IO error: " ++ (show e) + mapStateIO $ logGame ("IO error: " ++ (show e)) Nothing update :: GameEvent -> StateT LoggedGame IO () update ge = update' Nothing ge @@ -86,15 +93,7 @@ t <- access $ game >>> currentTime let te = TimedEvent t ge gameLog %= \gl -> gl ++ [te] - evalTimedEvent te inter - -evalTimedEvent :: TimedEvent -> Maybe (RuleCode -> IO RuleFunc) -> StateT LoggedGame IO () -evalTimedEvent (TimedEvent _ e) inter = focus game $ do - enactEvent e inter - lg <- get - lift $ evaluate lg - --liftIO $! putStrLn $ "evaluating " ++ (show e) - return () + focus game $ enactTimedEvent inter te getLoggedGame :: Game -> (RuleCode -> IO RuleFunc) -> [TimedEvent] -> IO LoggedGame getLoggedGame g mInter tes = do @@ -129,7 +128,6 @@ leaveGame :: PlayerNumber -> State Game () leaveGame pn = runEvalError pn $ void $ evDelPlayer pn - -- | insert a rule in pending rules. proposeRule :: SubmitRule -> PlayerNumber -> (RuleCode -> IO RuleFunc) -> StateT Game IO () proposeRule sr pn inter = do @@ -139,33 +137,21 @@ if r == True then tracePN pn $ "Your rule has been added to pending rules." else tracePN pn $ "Error: Rule could not be proposed" - -outputPlayer :: String -> PlayerNumber -> State Game () -outputPlayer s pn = void $ outputs %= ((pn, s) : ) - -outputAll :: String -> StateT LoggedGame IO () -outputAll s = do - pls <- access (game >>> players) - mapM_ (update . ((flip OutputPlayer) s)) (map _playerNumber pls) - -inputChoiceResult :: EventNumber -> Int -> PlayerNumber -> State Game () -inputChoiceResult eventNumber choiceIndex pn = do - tracePN pn $ "input choice result: Event " ++ (show eventNumber) ++ ", choice " ++ (show choiceIndex) - runEvalError pn $ triggerChoice eventNumber choiceIndex - --- TODO maybe homogeneise both inputs event -inputStringResult :: Event InputString -> String -> PlayerNumber -> State Game () -inputStringResult event input pn = do - tracePN pn $ "input String result: input " ++ input - runEvalError pn $ triggerEvent_ event (InputStringData input) +logGame :: String -> (Maybe PlayerNumber) -> State Game () +logGame s mpn = do + time <- access currentTime + void $ logs %= (Log mpn time s : ) +inputResult :: PlayerNumber -> EventNumber -> UInputData -> State Game () +inputResult pn en ir = do + tracePN pn $ "input result: Event " ++ (show en) ++ ", choice " ++ (show ir) + runEvalError pn $ triggerInput en ir getTimes :: EventHandler -> Maybe UTCTime -getTimes (EH _ _ (Time t) _ EvActive) = Just t +getTimes (EH _ _ (Time t) _ SActive) = Just t getTimes _ = Nothing - --- | An helper function to use the state transformer GameState. +-- | A helper function to use the state transformer GameState. -- It additionally sets the current time. execWithGame :: UTCTime -> State LoggedGame () -> LoggedGame -> LoggedGame execWithGame t gs g = execState gs $ ((game >>> currentTime) `setL` t $ g) @@ -205,6 +191,8 @@ systemAddRule :: SubmitRule -> (RuleCode -> IO RuleFunc) -> StateT Game IO () systemAddRule sr inter = do rule <- createRule sr 0 inter - let sysRule = (rStatus ^= Active).(rAssessedBy ^= Just 0) + let sysRule = (rStatus ^= Active) >>> (rAssessedBy ^= Just 0) rules %= (sysRule rule : ) mapStateIO $ runEvalError 0 $ void $ evalExp (_rRuleFunc rule) (_rNumber rule) + +stateCatch = liftCatch catch diff --git a/src/Language/Nomyx/Test.hs b/src/Language/Nomyx/Test.hs --- a/src/Language/Nomyx/Test.hs +++ b/src/Language/Nomyx/Test.hs @@ -24,6 +24,7 @@ _events = [], _outputs = [], _victory = [], + _logs = [], _currentTime = date1} testRule = Rule { _rNumber = 0, @@ -47,6 +48,7 @@ ("test var 4", testVarEx4), ("test var 5", testVarEx5), ("test single input", testSingleInputEx), + ("test multiple input", testMultipleInputsEx), ("test input string", testInputStringEx), ("test send messsage", testSendMessageEx), ("test send message 2", testSendMessageEx2), @@ -97,10 +99,10 @@ var <- newVar_ "toto" (1::Int) a <- readVar var case a of - Just (1::Int) -> output "ok" 1 - _ -> output "nok" 1 + Just (1::Int) -> newOutput_ "ok" 1 + _ -> newOutput_ "nok" 1 -testVarEx3 = _outputs (execRuleFunc testVar3) == [(1,"ok")] +testVarEx3 = isOutput "ok" (execRuleFunc testVar3) --Test variable writing testVar4 :: RuleFunc @@ -109,10 +111,10 @@ writeVar var (2::Int) a <- readVar var case a of - Just (2::Int) -> output "ok" 1 - _ -> output "nok" 1 + Just (2::Int) -> newOutput_ "ok" 1 + _ -> newOutput_ "nok" 1 -testVarEx4 = _outputs (execRuleFunc testVar4) == [(1,"ok")] +testVarEx4 = isOutput "ok" (execRuleFunc testVar4) --Test variable writing testVar5 :: RuleFunc @@ -124,7 +126,7 @@ Just (a::[Int]) -> do writeVar var (2:a) return () - Nothing -> output "nok" 1 + Nothing -> newOutput_ "nok" 1 testVarEx5 = _variables (execRuleFunc testVar5) == [(Var 0 "toto" ([2,1]::[Int]))] @@ -133,17 +135,28 @@ -- Test input testSingleInput :: RuleFunc testSingleInput = voidRule $ do - onInputChoiceEnum_ "Vote for Holland or Sarkozy" Holland h 1 where - h a = output ("voted for " ++ (show a)) 1 + onInputRadioEnum_ "Vote for Holland or Sarkozy" Holland h 1 where + h a = newOutput_ ("voted for " ++ (show a)) 1 -testSingleInputEx = (_outputs $ execRuleFuncEvent testSingleInput (inputChoiceEnum 1 "Vote for Holland or Sarkozy" Holland) (InputChoiceData Holland)) == [(1, "voted for Holland")] +testSingleInputEx = isOutput "voted for Holland" g where + g = execRuleFuncEvent testSingleInput (inputRadioEnum 1 "Vote for Holland or Sarkozy" Holland) (InputData (RadioData Holland)) +testMultipleInputs :: RuleFunc +testMultipleInputs = voidRule $ do + onInputCheckbox_ "Vote for Holland and Sarkozy" [(Holland, "Holland"), (Sarkozy, "Sarkozy")] h 1 where + h a = newOutput_ ("voted for " ++ (show a)) 1 + +testMultipleInputsEx = isOutput "voted for [Holland,Sarkozy]" g where + g = execRuleFuncEvent testMultipleInputs (inputCheckbox 1 "Vote for Holland and Sarkozy" [(Holland, "Holland"), (Sarkozy, "Sarkozy")]) (InputData (CheckboxData [Holland, Sarkozy])) + + testInputString :: RuleFunc testInputString = voidRule $ do - onInputString_ "Enter a number:" h 1 where - h a = output ("You entered: " ++ a) 1 + onInputText_ "Enter a number:" h 1 where + h a = newOutput_ ("You entered: " ++ a) 1 -testInputStringEx = (_outputs $ execRuleFuncEvent testInputString (inputString 1 "Enter a number:") (InputStringData "1")) == [(1, "You entered: 1")] +testInputStringEx = isOutput "You entered: 1" g where + g = execRuleFuncEvent testInputString (inputText 1 "Enter a number:") (InputData (TextData "1")) -- Test message testSendMessage :: RuleFunc @@ -151,17 +164,17 @@ let msg = Message "msg" :: Event(Message String) onEvent_ msg f sendMessage msg "toto" where - f (MessageData a :: EventData(Message String)) = output a 1 + f (MessageData a :: EventData(Message String)) = newOutput_ a 1 -testSendMessageEx = _outputs (execRuleFunc testSendMessage) == [(1,"toto")] +testSendMessageEx = isOutput "toto" (execRuleFunc testSendMessage) testSendMessage2 :: RuleFunc testSendMessage2 = voidRule $ do - onEvent_ (Message "msg":: Event(Message ())) $ const $ output "Received" 1 + onEvent_ (Message "msg":: Event(Message ())) $ const $ newOutput_ "Received" 1 sendMessage_ (Message "msg") -testSendMessageEx2 = _outputs (execRuleFunc testSendMessage2) == [(1,"Received")] +testSendMessageEx2 = isOutput "Received" (execRuleFunc testSendMessage2) data Choice2 = Me | You deriving (Enum, Typeable, Show, Eq, Bounded) @@ -170,18 +183,20 @@ testUserInputWrite = voidRule $ do newVar_ "vote" (Nothing::Maybe Choice2) onEvent_ (Message "voted" :: Event (Message ())) h2 - onEvent_ (InputChoice 1 "Vote for" [Me, You] Me) h1 where - h1 (InputChoiceData a :: EventData (InputChoice Choice2)) = do + onEvent_ (InputEv (Input 1 "Vote for" (Radio [(Me, "Me"), (You, "You")]))) h1 where + h1 (InputData (RadioData a) :: EventData (Input Choice2)) = do writeVar (V "vote") (Just a) SendMessage (Message "voted") () + h1 _ = undefined h2 (MessageData _) = do a <- readVar (V "vote") case a of - Just (Just Me) -> output "voted Me" 1 - _ -> output "problem" 1 + Just (Just Me) -> newOutput_ "voted Me" 1 + _ -> newOutput_ "problem" 1 h2 _ = undefined -testUserInputWriteEx = (_outputs $ execRuleFuncEvent testUserInputWrite (InputChoice 1 "Vote for" [Me, You] Me) (InputChoiceData Me)) == [(1,"voted Me")] +testUserInputWriteEx = isOutput "voted Me" g where + g = execRuleFuncEvent testUserInputWrite (InputEv (Input 1 "Vote for" (Radio [(Me, "Me"), (You, "You")]))) (InputData (RadioData Me)) -- Test rule activation testActivateRule :: RuleFunc @@ -204,12 +219,14 @@ onEvent_ (Time date1) f where f _ = outputAll $ show date1 -testTimeEventEx = (_outputs $ execRuleFuncEvent testTimeEvent (Time date1) (TimeData date1)) == [(1,show date1)] +testTimeEventEx = isOutput (show date1) g where + g = execRuleFuncEvent testTimeEvent (Time date1) (TimeData date1) testTimeEvent2 :: Nomex () testTimeEvent2 = schedule' [date1, date2] (outputAll . show) -testTimeEventEx2 = (_outputs $ flip execState testGame (runEvalError 0 $ evalExp testTimeEvent2 0 >> void gameEvs)) == [(1,show date2), (1,show date1)] where +testTimeEventEx2 = isOutput (show date1) g && isOutput (show date2) g where + g = flip execState testGame (runEvalError 0 $ evalExp testTimeEvent2 0 >> void gameEvs) gameEvs = do evTriggerTime date1 evTriggerTime date2 @@ -225,13 +242,13 @@ evs <- getChoiceEvents let pos = take positives evs let neg = take negatives $ drop positives evs - mapM_ (\x -> triggerChoice x (fromEnum For)) pos - mapM_ (\x -> triggerChoice x (fromEnum Against)) neg + mapM_ (\x -> triggerInput x (URadioData $ fromEnum For)) pos + mapM_ (\x -> triggerInput x (URadioData $ fromEnum Against)) neg when timeEvent $ void $ evTriggerTime date2 voteGame' :: Int -> Int -> Int -> Bool -> RuleFunc -> Game voteGame' positives negatives notVoted timeEvent rf = voteGameActions positives negatives notVoted timeEvent $ do - let rule = testRule {_rName = "testRule", _rRuleFunc = rf, _rNumber = 1, _rStatus = Active} + let rule = testRule {_rName = "testRule", _rRuleFunc = rf, _rNumber = 1, _rStatus = Pending} evAddRule rule evActivateRule (_rNumber rule) 0 return () @@ -273,4 +290,8 @@ testVoteAssessOnTimeLimit5 = testVoteRule Pending $ voteGameTimed 10 0 10 $ onRuleProposed $ voteWith_ unanimity $ assessOnTimeLimit date3 testVoteRule s g = (_rStatus $ head $ _rules g) == s + +isOutput :: String -> Game -> Bool +isOutput s g = any (\(Output _ _ _ mys SActive) -> mys == s) (_outputs g) + diff --git a/src/Language/Nomyx/Utils.hs b/src/Language/Nomyx/Utils.hs --- a/src/Language/Nomyx/Utils.hs +++ b/src/Language/Nomyx/Utils.hs @@ -54,3 +54,9 @@ getFreeNumber :: (Eq a, Num a, Enum a) => [a] -> a getFreeNumber l = head [a| a <- [1..], not $ a `elem` l] + + +sel :: [a] -- ^ List of indices to select + -> [Int] -- ^ List of elements + -> [a] -- ^ List composed of elements selected from original set by indices provided +sel xs is = map (\i -> xs!!i) is diff --git a/src/Language/Nomyx/Vote.hs b/src/Language/Nomyx/Vote.hs --- a/src/Language/Nomyx/Vote.hs +++ b/src/Language/Nomyx/Vote.hs @@ -13,11 +13,12 @@ import Data.Time hiding (getCurrentTime) import Control.Arrow import Control.Applicative -import Data.List (sort, group) -import Language.Nomyx.Utils (oneDay) +import Language.Nomyx.Utils +import Data.List import qualified Data.Map as M import Control.Monad.Error (MonadError(..)) + data VoteType a = ExclusiveVote (Maybe (Alts a)) | NonExclusiveVote [Alts a] @@ -50,8 +51,6 @@ assessFunction :: VoteResult a} -- function used to count the votes type Assessor a = StateT (VoteData a) Nomex () - - -- | Perform a vote. voteWith :: (Votable a) => VoteResult a -- ^ the function used to count the votes. -> Assessor a -- ^ assessors: when and how to perform the vote assessment (several assessors can be chained). @@ -63,12 +62,14 @@ let toVoteName = name toVote let msgEnd = Message ("Result of votes for " ++ toVoteName) :: Msg [Alts a] --create an array variable to store the votes. - (voteVar :: ArrayVar PlayerNumber (Alts a)) <- newArrayVar ("Votes for " ++ toVoteName) pns - let askPlayer pn = onInputChoiceOnce ("Vote for " ++ toVoteName ++ ":") als (putArrayVar voteVar pn) pn + (voteVar :: ArrayVar PlayerNumber (Alts a)) <- newArrayVar_ ("Votes for " ++ toVoteName) pns + let askPlayer pn = onInputRadioOnce ("Vote for " ++ toVoteName ++ ":") als (putArrayVar_ voteVar pn) pn inputs <- mapM askPlayer pns let voteData = VoteData msgEnd voteVar inputs countVotes - evalStateT assessors voteData - cleanVote voteData + evalStateT assessors voteData + mapM (\n -> displayVoteVar n ("Votes for " ++ toVoteName ++ ":") voteVar) pns + displayVoteResult toVoteName voteData + cleanVote voteData return $ msgEnd -- | Performs a vote, all the possible alternatives are selected. @@ -81,10 +82,11 @@ assessOnEveryVote = do (VoteData msgEnd voteVar _ assess) <- get lift $ do - msgVotes <- getArrayVarMessage voteVar - onMessage msgVotes $ \(MessageData votes) -> do - let res = assess $ getVoteStats votes False - when (not $ null res) $ sendMessage msgEnd res + onMsgVarChange voteVar $ f assess msgEnd where + f assess msgEnd (VUpdated votes) = do + let res = assess $ getVoteStats votes False + when (not $ null res) $ sendMessage msgEnd res + f _ _ _ = return () -- | assess the vote with the assess function when time is reached, and sends a signal with the issue (positive of negative) @@ -93,7 +95,7 @@ (VoteData msgEnd voteVar _ assess) <- get lift $ do onEvent_ (Time time) $ \_ -> do - votes <- getArrayVarData voteVar + votes <- getMsgVarData_ voteVar sendMessage msgEnd (assess $ getVoteStats votes True) @@ -108,16 +110,16 @@ assessWhenEverybodyVoted = do (VoteData msgEnd voteVar _ assess) <- get lift $ do - msgVotes <- getArrayVarMessage voteVar - onMessage msgVotes $ \(MessageData vs) -> do - when (all isJust (map snd vs)) $ sendMessage msgEnd $ assess $ getVoteStats vs True + onMsgVarChange voteVar $ f assess msgEnd where + f assess msgEnd (VUpdated votes) = when (all isJust (map snd votes)) $ sendMessage msgEnd $ assess $ getVoteStats votes True + f _ _ _ = return () -- | clean events and variables necessary for the vote cleanVote :: (Votable a) => VoteData a -> Nomex () -cleanVote (VoteData msgEnd voteVar inputsNumber _) = onMessage msgEnd$ \_ -> do +cleanVote (VoteData msgEnd voteVar inputsNumber _) = onMessage msgEnd $ \_ -> do delAllEvents msgEnd - delArrayVar voteVar + delMsgVar voteVar mapM_ delEvent inputsNumber @@ -179,7 +181,39 @@ counts :: (Eq a, Ord a) => [a] -> [(a, Int)] counts as = map (head &&& length) (group $ sort as) - + + +displayVoteVar :: (Votable a) => PlayerNumber -> String -> ArrayVar PlayerNumber (Alts a) -> Nomex () +displayVoteVar pn title mv = do + sp <- showPlayer + displayVar pn mv (showVotes title sp) + +showPlayer :: Nomex (PlayerNumber -> String) +showPlayer = do + pls <- getPlayers + return $ (\pn -> _playerName $ fromJust $ find (\(PlayerInfo mypn _) -> mypn == pn) pls) + +showChoice :: (Votable a) => Maybe (Alts a) -> String +showChoice (Just a) = show a +showChoice Nothing = "Not Voted " + +showChoices :: (Votable a) => [(Alts a)] -> String +showChoices cs = concat $ intersperse ", " $ map show cs + +showVotes :: (Votable a) => String -> (PlayerNumber -> String) -> [(PlayerNumber, Maybe (Alts a))] -> String +showVotes title showPlayer l = title ++ "\n" ++ + concatMap (\(i,a) -> (showPlayer i) ++ "\t" ++ (showChoice a) ++ "\n") l + +showVotes' :: (Votable a) => (PlayerNumber -> String) -> [(PlayerNumber, Maybe (Alts a))] -> String +showVotes' showPlayer l = concat $ intersperse ", " $ map (\(i,a) -> (showPlayer i) ++ ": " ++ (showChoice a)) voted where + voted = filter (\(_, r) -> isJust r) l + +displayVoteResult :: (Votable a) => String -> VoteData a -> Nomex () +displayVoteResult toVoteName (VoteData msgEnd voteVar _ _) = onMessage msgEnd $ \(MessageData result) -> do + vs <- getMsgVarData_ voteVar + sp <- showPlayer + outputAll $ "Vote result for " ++ toVoteName ++ ": " ++ (showChoices result) ++ + " (" ++ showVotes' sp vs ++ ")" -- * Referendum & elections