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.0 +version: 0.2.1 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) @@ -15,7 +15,8 @@ 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/Rule.hs src/Language/Nomyx/Test.hs + src/Language/Nomyx/Vote.hs data-dir: "" extra-source-files: AUTHORS README @@ -31,9 +32,11 @@ Language.Nomyx.Definition Language.Nomyx.Evaluation Language.Nomyx.Examples - Language.Nomyx.Rule + Language.Nomyx.Rule + Language.Nomyx.Vote Language.Nomyx.Test Language.Nomyx.Game + Language.Nomyx.Utils Paths_Nomyx_Language exposed: True buildable: True diff --git a/src/Language/Nomyx.hs b/src/Language/Nomyx.hs --- a/src/Language/Nomyx.hs +++ b/src/Language/Nomyx.hs @@ -4,12 +4,14 @@ module Language.Nomyx.Definition, module Language.Nomyx.Rule, module Language.Nomyx.Examples, - module Language.Nomyx.Evaluation) where + module Language.Nomyx.Evaluation, + module Language.Nomyx.Vote) where import Language.Nomyx.Expression import Language.Nomyx.Definition import Language.Nomyx.Rule import Language.Nomyx.Examples import Language.Nomyx.Evaluation +import Language.Nomyx.Vote 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 @@ -11,13 +11,13 @@ import Data.Time hiding (getCurrentTime) import qualified Data.Map as M import Data.Map hiding (map, filter, insert, mapMaybe, null) -import System.Locale (defaultTimeLocale, rfc822DateFormat) 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 -- * Variables -- | variable creation @@ -66,9 +66,9 @@ -- * 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 (Event (Message [(i, Maybe a)])) (V (Map i (Maybe a))) +-- | 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))) -- | initialize an empty ArrayVar newArrayVar :: (Ord i, Typeable a, Show a, Eq a, Typeable i, Show i) => VarName -> [i] -> Nomex (ArrayVar i a) @@ -111,7 +111,7 @@ sendMessage m (toList ar2) -- | 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 (Event (Message [(i, Maybe a)])) +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 @@ -161,17 +161,17 @@ delAllEvents = DelAllEvents -- | broadcast a message that can be catched by another rule -sendMessage :: (Typeable a, Show a, Eq a) => Event (Message a) -> a -> Nomex () +sendMessage :: (Typeable a, Show a, Eq a) => Msg a -> a -> Nomex () sendMessage = SendMessage -sendMessage_ :: Event (Message ()) -> Nomex () +sendMessage_ :: Msg () -> Nomex () sendMessage_ m = SendMessage m () -- | subscribe on a message -onMessage :: (Typeable m, Show m) => Event (Message m) -> ((EventData (Message m)) -> Nomex ()) -> Nomex () +onMessage :: (Typeable m, Show m) => Msg m -> (MsgData m -> Nomex ()) -> Nomex () onMessage m f = onEvent_ m f -onMessageOnce :: (Typeable m, Show m) => Event (Message m) -> ((EventData (Message m)) -> Nomex ()) -> Nomex () +onMessageOnce :: (Typeable m, Show m) => Msg m -> (MsgData m -> Nomex ()) -> Nomex () onMessageOnce m f = onEventOnce_ m f -- | on the provided schedule, the supplied function will be called @@ -409,18 +409,8 @@ -- * Miscellaneous -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 (_, Nothing) = Nothing - voidRule :: Nomex a -> Nomex RuleResp voidRule e = e >> return Void @@ -441,14 +431,14 @@ (BoolResp b') -> andMsgBool b' a' >>= (return . MsgResp) (MsgResp b') -> andMsgMsg a' b' >>= (return . MsgResp) -andMsgBool :: Bool -> (Event (Message Bool)) -> Nomex (Event (Message Bool)) +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 :: (Event (Message Bool)) -> (Event (Message Bool)) -> Nomex (Event (Message Bool)) +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) 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 @@ -3,21 +3,22 @@ module Language.Nomyx.Evaluation where import Prelude hiding ((.)) -import Language.Nomyx.Expression +import Language.Nomyx.Utils import Control.Monad -import Data.Maybe import Control.Monad.State.Lazy import Data.List import Data.Typeable import Data.Function hiding ((.)) import Data.Time -import Debug.Trace import Data.Lens 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. @@ -61,24 +62,19 @@ evalExp (OnEvent event handler) rn = do evs <- access events let en = getFreeNumber (map _eventNumber evs) - events %= ((EH en rn event handler) : ) + events %= ((EH en rn event handler EvActive) : ) return en -evalExp (DelEvent en) rn = do +evalExp (DelEvent en) rn = evDelEvent en rn + +evalExp (DelAllEvents e) rn = do evs <- access events - case find ((== en) . getL eventNumber) evs of - Nothing -> return False - Just eh -> do - if ((ruleNumber ^$) eh == rn) then do - events %= filter ((/= en) . getL eventNumber) - return True - else return False + let filtered = filter (\EH {event} -> event === e) evs + --traceM ("DelAllEvents: deleting " ++ show filtered) + mapM_ (\e -> evDelEvent e rn) (_eventNumber <$> filtered) -evalExp (SendMessage (Message id) myData) _ = do - triggerEvent (Message id) (MessageData myData) - return () +evalExp (SendMessage (Message id) myData) _ = triggerEvent_ (Message id) (MessageData myData) -evalExp (DelAllEvents e) _ = void $ events %= filter (\EH {event} -> not $ event === e) evalExp (Output pn string) _ = outputS pn string >> return () evalExp (ProposeRule rule) _ = evProposeRule rule evalExp (ActivateRule rule) rn = evActivateRule rule rn @@ -99,48 +95,59 @@ victory ~= ps pls <- access players let victorious = filter (\pl -> _playerNumber pl `elem` ps) pls - triggerEvent Victory (VictoryData victorious) - return () + triggerEvent_ Victory (VictoryData victorious) + evalExp (Bind exp f) rn = do a <- evalExp exp rn evalExp (f a) rn --execute all the handlers of the specified event with the given data -triggerEvent :: (Typeable e, Show e, Eq e) => Event e -> EventData e -> Evaluate () +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}) -> e === event) evs - mapM_ f filtered 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)) + let filtered = filter (\(EH {event, _evStatus}) -> e === event && _evStatus == EvActive) evs + case filtered of + [] -> do + --traceM $ "triggerEvent: Event not found:" ++ (show e) + 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)) +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 -triggerChoice :: Int -> Int -> Evaluate () -triggerChoice myEventNumber choiceIndex = do +triggerChoice :: EventNumber -> Int -> Evaluate () +triggerChoice en choiceIndex = do evs <- access events - let filtered = filter ((== myEventNumber) . getL eventNumber) evs - mapM_ (execChoiceHandler myEventNumber choiceIndex) filtered + let filtered = filter ((== en) . getL eventNumber) evs + mapM_ (execChoiceHandler en choiceIndex) filtered execChoiceHandler :: EventNumber -> Int -> EventHandler -> Evaluate () -execChoiceHandler eventNumber choiceIndex (EH _ _ (InputChoice ruleNumber _ cs _) handler) = evalExp (handler (eventNumber, InputChoiceData (cs!!choiceIndex))) ruleNumber +execChoiceHandler eventNumber choiceIndex (EH _ rn (InputChoice _ _ cs _) handler _) = evalExp (handler (eventNumber, InputChoiceData (cs!!choiceIndex))) rn execChoiceHandler _ _ _ = return () ---execute all the handlers of the specified event with the given data findEvent :: EventNumber -> [EventHandler] -> Maybe (EventHandler) findEvent en evs = find ((== en) . getL eventNumber) evs - -findChoice :: (Eq a, Read a) => String -> Event (InputChoice a) -> a -findChoice s (InputChoice _ _ choices _) = fromJust $ find (== (read s)) choices +getChoiceEvents :: Evaluate [EventNumber] +getChoiceEvents = do + evs <- access events + return $ map _eventNumber $ filter choiceEvent evs + where choiceEvent (EH _ _ (InputChoice _ _ _ _) _ _) = True + choiceEvent _ = False outputS :: PlayerNumber -> String -> Evaluate () outputS pn s = void $ outputs %= ((pn, s) : ) @@ -155,7 +162,7 @@ case find ((== (rNumber ^$ rule)) . getL rNumber) rs of Nothing -> do rules %= (rule:) - triggerEvent (RuleEv Proposed) (RuleData rule) + triggerEvent_ (RuleEv Proposed) (RuleData rule) return True Just _ -> return False @@ -170,7 +177,7 @@ rules ~= newrules --execute the rule evalExp (_rRuleFunc r) rn - triggerEvent (RuleEv Activated) (RuleData r) + triggerEvent_ (RuleEv Activated) (RuleData r) return True evRejectRule :: RuleNumber -> RuleNumber -> Evaluate Bool @@ -181,7 +188,7 @@ Just r -> do let newrules = replaceWith ((== rn) . getL rNumber) r{_rStatus = Reject, _rAssessedBy = Just by} rs rules ~= newrules - triggerEvent (RuleEv Rejected) (RuleData r) + triggerEvent_ (RuleEv Rejected) (RuleData r) delVarsRule rn delEventsRule rn return True @@ -192,7 +199,7 @@ case find ((== (rNumber ^$ rule)) . getL rNumber) rs of Nothing -> do rules %= (rule:) - triggerEvent (RuleEv Added) (RuleData rule) + triggerEvent_ (RuleEv Added) (RuleData rule) return True Just _ -> return False @@ -206,7 +213,7 @@ rules ~= newRules delVarsRule del delEventsRule del - triggerEvent (RuleEv Deleted) (RuleData r) + triggerEvent_ (RuleEv Deleted) (RuleData r) return True --TODO: clean and execute new rule @@ -218,7 +225,7 @@ Nothing -> return False Just r -> do rules ~= newRules - triggerEvent (RuleEv Modified) (RuleData r) + triggerEvent_ (RuleEv Modified) (RuleData r) return True addPlayer :: PlayerInfo -> Evaluate Bool @@ -227,7 +234,7 @@ let exists = any (((==) `on` _playerNumber) pi) pls when (not exists) $ do players %= (pi:) - triggerEvent (Player Arrive) (PlayerData pi) + triggerEvent_ (Player Arrive) (PlayerData pi) return $ not exists evDelPlayer :: PlayerNumber -> Evaluate Bool @@ -239,7 +246,7 @@ return False Just pi -> do players %= filter ((/= pn) . getL playerNumber) - triggerEvent (Player Leave) (PlayerData pi) + triggerEvent_ (Player Leave) (PlayerData pi) tracePN pn $ "leaving the game: " ++ (_gameName g) return True @@ -252,10 +259,29 @@ players ~= replaceWith ((== pn) . getL playerNumber) (PlayerInfo pn name) pls return True -evInputChoice :: (Eq d, Show d, Typeable d, Read d) => Event(InputChoice d) -> d -> Evaluate () +evDelEvent :: EventNumber -> RuleNumber -> Evaluate Bool +evDelEvent en _ = do + --traceM ("DelEvent: called with en=" ++ (show en)) + evs <- access events + case find ((== en) . getL eventNumber) evs of + Nothing -> do + --traceM ("DelEvent: event number not found! en=" ++ (show en) ++ " rn=" ++ (show rn)) + return False + Just eh -> do + case (_evStatus eh) of + EvActive -> do + --traceM ("DelEvent: deleting event en=" ++ (show en) ++ " rn=" ++ (show rn)) + let newEvents = replaceWith ((== en) . getL eventNumber) eh{_evStatus = EvDeleted} evs + events ~= newEvents + return True + EvDeleted -> 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 () +evTriggerTime :: UTCTime -> Evaluate Bool evTriggerTime t = triggerEvent (Time t) (TimeData t) @@ -266,9 +292,6 @@ --delete all events of a rule delEventsRule :: RuleNumber -> Evaluate () delEventsRule rn = void $ events %= filter ((/= rn) . getL ruleNumber) - -traceState :: String -> State s String -traceState x = state (\s -> trace ("trace: " ++ x) (x, s)) runEvalError :: PlayerNumber -> Evaluate () -> State Game () 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 @@ -1,11 +1,14 @@ -{-# LANGUAGE TupleSections, GADTs #-} +{-# LANGUAGE TupleSections, GADTs, EmptyDataDecls, TypeFamilies, DeriveDataTypeable, + ScopedTypeVariables, TypeSynonymInstances #-} -- | This file gives a list of example rules that the players can submit. --You can copy-paste them in the field "Code" of the web GUI. --Don't hesitate to get inspiration from there and create your own rules! -module Language.Nomyx.Examples(nothing, helloWorld, accounts, createBankAccount, winXEcuPerDay, winXEcuOnRuleAccepted, moneyTransfer, - delRule, voteWithMajority, king, makeKing, monarchy, revolution, victoryXRules, victoryXEcu, displayTime, noGroupVictory, iWin, - returnToDemocracy, banPlayer, module Data.Time.Recurrence, module Control.Monad, module Data.List, module Data.Time.Clock) where +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, + module Data.Time.Recurrence, module Control.Monad, module Data.List, module Data.Time.Clock) where import Language.Nomyx.Definition import Language.Nomyx.Rule @@ -16,6 +19,10 @@ import Control.Arrow import Data.List import Control.Monad +import Language.Nomyx.Vote + (elections, referendum, assessOnTimeDelay, assessOnEveryVotes, + withQuorum, majority, voteWith_) +import Language.Nomyx.Utils (oneDay) -- | A rule that does nothing nothing :: RuleFunc @@ -121,13 +128,13 @@ -- | a majority vote, voteWithMajority :: RuleFunc -voteWithMajority = onRuleProposed $ voteWith (majority `withQuorum` 2) $ assessOnEveryVotes >> assessOnTimeDelay oneDay +voteWithMajority = onRuleProposed $ voteWith_ (majority `withQuorum` 2) $ assessOnEveryVotes >> assessOnTimeDelay oneDay -- | Change unanimity vote (usually rule 1) to absolute majority (half participants plus one) returnToDemocracy :: RuleFunc returnToDemocracy = voidRule $ do suppressRule 1 - addRuleParams_ "vote with majority" voteWithMajority "voteTimeLimit" 1 "meta-rule: return true if a majority of players vote positively for a new rule" + addRuleParams_ "vote with majority" voteWithMajority "voteWithMajority" 1 "meta-rule: return true if a majority of players vote positively for a new rule" activateRule_ 1 autoDelete @@ -137,3 +144,22 @@ delPlayer pn onEvent_ (Player Arrive) $ \(PlayerData _) -> void $ delPlayer pn +-- * Referendum & elections + +-- | triggers a referendum, if the outcome is yes player 2 will be kicked +referendumOnKickPlayer :: RuleFunc +referendumOnKickPlayer = referendum " kick player 2" (void $ delPlayer 2) + +-- | triggers elections (all players are candidates), the winner becomes game master +gameMasterElections :: RuleFunc +gameMasterElections = voidRule $ do + pls <- getPlayers + elections "Game Master" pls makeGM + +makeGM :: PlayerNumber -> Nomex() +makeGM pn = do + newVar "GameMaster" pn + void $ modifyPlayerName pn ("GameMaster " ++) + +gameMaster :: V PlayerNumber +gameMaster = V "GameMaster" 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 @@ -19,8 +19,9 @@ import Text.Read.Lex (Lexeme(..)) import Text.ParserCombinators.ReadPrec (reset) import GHC.Show (showList__) -import Debug.Trace.Helpers (traceM) import Control.Monad.Error +import Language.Nomyx.Utils ((===)) +import Data.List (intersperse) type PlayerNumber = Int type PlayerName = String @@ -97,9 +98,6 @@ instance Show a => Show (Nomex a) where show _ = "Nomex" -- ++ (show a) - - - -- * Variables @@ -120,7 +118,7 @@ type Output = (PlayerNumber, String) - +type Id a = a -- * Events -- | events types @@ -170,22 +168,27 @@ deriving instance Eq (Message m) deriving instance (Eq e) => Eq (Event e) +data EventStatus = EvActive | EvDeleted deriving (Eq, Show) data EventHandler where EH :: (Typeable e, Show e, Eq e) => {_eventNumber :: EventNumber, _ruleNumber :: RuleNumber, - event :: Event e, - handler :: (EventNumber, EventData e) -> Nomex ()} -> EventHandler + event :: Event e, + handler :: (EventNumber, EventData e) -> Nomex (), + _evStatus :: EventStatus} -> EventHandler instance Show EventHandler where - show (EH en rn e _) = (show en) ++ " " ++ " " ++ (show rn) ++ " (" ++ (show e) ++"),\n" + show (EH en rn e _ _) = (show en) ++ " " ++ " " ++ (show rn) ++ " (" ++ (show e) ++"),\n" instance Eq EventHandler where (EH {_eventNumber=e1}) == (EH {_eventNumber=e2}) = e1 == e2 instance Ord EventHandler where (EH {_eventNumber=e1}) <= (EH {_eventNumber=e2}) = e1 <= e2 + +type Msg a = Event (Message a) +type MsgData a = EventData (Message a) -- * Rule @@ -200,7 +203,7 @@ deriving (Typeable) --An extended type for booleans supporting immediate or delayed response (through a message) data BoolResp = BoolResp Bool - | MsgResp (Event (Message Bool)) + | MsgResp (Msg Bool) instance Show RuleResp where @@ -256,11 +259,6 @@ data GameDesc = GameDesc { _desc :: String, _agora :: String} deriving (Eq, Show, Read, Ord) ---instance Show Game where --- show (Game { _gameName, _rules, _players, _variables, _events, _outputs, _victory, _currentTime}) = --- "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" - instance Eq Game where (Game {_gameName=gn1}) == (Game {_gameName=gn2}) = gn1 == gn2 @@ -301,20 +299,11 @@ showsPrec 0 b3 . showString "}" showList = showList__ (showsPrec 0) - --- | an equality that tests also the types. -(===) :: (Typeable a, Typeable b, Eq b) => a -> b -> Bool -(===) x y = cast x == Just y - --- | Replaces all instances of a value in a list by another value. -replaceWith :: (a -> Bool) -- ^ Value to search - -> a -- ^ Value to replace it with - -> [a] -- ^ Input list - -> [a] -- ^ Output list -replaceWith f y = map (\z -> if f z then y else z) -tracePN :: (Monad m ) => PlayerNumber -> String -> m () -tracePN pn s = traceM $ "Player " ++ (show pn) ++ " " ++ s - +displayGame :: Game -> String +displayGame (Game { _gameName, _rules, _players, _variables, _events, _outputs, _victory, _currentTime}) = + "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] ) 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 @@ -18,8 +18,9 @@ import Control.Category ((>>>)) import Data.Lens.Template import Control.Exception -import Control.Monad.Identity +import Language.Nomyx.Utils + data TimedEvent = TimedEvent UTCTime GameEvent deriving (Show, Read, Eq, Ord) data GameEvent = GameSettings GameName GameDesc UTCTime @@ -67,7 +68,7 @@ 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 (TimeEvent t) _ = mapStateIO $ runEvalError 0 $ evTriggerTime t +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" @@ -83,17 +84,17 @@ update' :: Maybe (RuleCode -> IO RuleFunc) -> GameEvent -> StateT LoggedGame IO () update' inter ge = do - --t <- lift $ T.getCurrentTime t <- access $ game >>> currentTime let te = TimedEvent t ge gameLog %= \gl -> gl ++ [te] - evalTimedEvent te inter --`liftCatchIO` commandExceptionHandler' + 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 () getLoggedGame :: Game -> (RuleCode -> IO RuleFunc) -> [TimedEvent] -> IO LoggedGame @@ -122,7 +123,7 @@ tracePN pn $ "Joining game: " ++ (_gameName g) let player = PlayerInfo { _playerNumber = pn, _playerName = name} players %= (player : ) - runEvalError pn $ triggerEvent (Player Arrive) (PlayerData player) + runEvalError pn $ triggerEvent_ (Player Arrive) (PlayerData player) -- | leave the game. @@ -157,11 +158,11 @@ 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) + runEvalError pn $ triggerEvent_ event (InputStringData input) getTimes :: EventHandler -> Maybe UTCTime -getTimes (EH _ _ (Time t) _) = Just t +getTimes (EH _ _ (Time t) _ EvActive) = Just t getTimes _ = Nothing @@ -174,8 +175,6 @@ execWithGame' t gs g = execStateT gs ((game >>> currentTime) `setL` t $ g) ---accessors - activeRules :: Game -> [Rule] activeRules = sort . filter ((==Active) . getL rStatus) . _rules @@ -188,14 +187,13 @@ instance Ord PlayerInfo where h <= g = (_playerNumber h) <= (_playerNumber g) -mapStateIO :: Show s => State s a -> StateT s IO a -mapStateIO = mapStateT $ return . runIdentity createRule :: SubmitRule -> PlayerNumber -> (RuleCode -> IO RuleFunc) -> StateT Game IO Rule createRule (SubmitRule name desc code) pn inter = do rs <- access rules let rn = getFreeNumber $ map _rNumber rs rf <- lift $ inter code + tracePN pn $ "Creating rule n=" ++ (show rn) ++ " code=" ++ code return $ Rule {_rNumber = rn, _rName = name, _rDescription = desc, diff --git a/src/Language/Nomyx/Rule.hs b/src/Language/Nomyx/Rule.hs --- a/src/Language/Nomyx/Rule.hs +++ b/src/Language/Nomyx/Rule.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE DeriveDataTypeable, GADTs, ScopedTypeVariables, TupleSections, FlexibleInstances#-} +{-# LANGUAGE DeriveDataTypeable, GADTs, ScopedTypeVariables, TupleSections, + FlexibleInstances, TypeFamilies, FlexibleContexts, Rank2Types #-} -- | Basic rules examples. module Language.Nomyx.Rule where @@ -6,15 +7,10 @@ import Prelude hiding (foldr) import Language.Nomyx.Expression import Language.Nomyx.Definition -import Data.Typeable -import Control.Monad.State hiding (forM_) -import Data.Maybe -import Data.Time hiding (getCurrentTime) import Control.Arrow -import Control.Applicative import Data.Lens -import Data.Foldable hiding (and, mapM_) -import Data.Boolean +import Language.Nomyx.Vote + -- | This rule will activate automatically any new rule. autoActivate :: RuleFunc @@ -40,12 +36,12 @@ illegal = return $ Meta (\_ -> return $ BoolResp False) -- | active metarules are automatically used to evaluate a given rule -checkWithMetarules :: Rule -> Nomex BoolResp -checkWithMetarules rule = do - rs <- getActiveRules - (metas :: [Rule -> Nomex BoolResp]) <- mapMaybeM maybeMetaRule rs - let (evals :: [Nomex BoolResp]) = map (\meta -> meta rule) metas - foldr (&&*) true evals +--checkWithMetarules :: Rule -> Nomex (Event (Message ForAgainst) +--checkWithMetarules rule = do +-- rs <- getActiveRules +-- (metas :: [Rule -> Nomex BoolResp]) <- mapMaybeM maybeMetaRule rs +-- let (evals :: [Nomex BoolResp]) = map (\meta -> meta rule) metas +-- foldr (&&*) true evals maybeMetaRule :: Rule -> Nomex (Maybe (Rule -> Nomex BoolResp)) @@ -57,138 +53,10 @@ -- | any new rule will be activate if the rule in parameter returns True -onRuleProposed :: (Rule -> Nomex BoolResp) -> 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) -type Vote = (PlayerNumber, Maybe ForAgainst) -type CountVotes = [Vote] -> Maybe Bool -data VoteData = VoteData { msgEnd :: Event (Message Bool), - voteVar :: ArrayVar PlayerNumber ForAgainst, - inputNumbers :: [EventNumber], - assessFunction :: CountVotes} -type Assessor a = StateT VoteData Nomex a - --- | Performs a vote for a rule on all players. The provided function is used to count the votes. --- the assessors allows to configure how and when the vote will be assessed. The assessors can be chained. -voteWith :: CountVotes -> Assessor () -> Rule -> Nomex BoolResp -voteWith assessFunction assessors rule = do - pns <- getAllPlayerNumbers - let rn = show $ _rNumber rule - let msgEnd = Message ("Result of votes for " ++ rn) :: Event(Message Bool) - --create an array variable to store the votes. - voteVar <- newArrayVar ("Votes for rule " ++ rn) pns - let askPlayer pn = onInputChoiceOnce ("Vote for rule " ++ rn) [For, Against] (putArrayVar voteVar pn) pn - inputs <- mapM askPlayer pns - let voteData = VoteData msgEnd voteVar inputs assessFunction - evalStateT assessors voteData - cleanVote voteData - return $ MsgResp msgEnd - --- | assess the vote on every new vote with the assess function, and as soon as the vote has an issue (positive of negative), sends a signal -assessOnEveryVotes :: Assessor () -assessOnEveryVotes = do - (VoteData msgEnd voteVar _ assess) <- get - lift $ do - msgVotes <- getArrayVarMessage voteVar - onMessage msgVotes $ \(MessageData votes) -> maybeWhen (assess votes) $ sendMessage msgEnd - - --- | assess the vote with the assess function when time is reached, and sends a signal with the issue (positive of negative) --- -assessOnTimeLimit :: UTCTime -> Assessor () -assessOnTimeLimit time = do - (VoteData msgEnd voteVar _ assess) <- get - lift $ do - onEvent_ (Time time) $ \_ -> do - votes <- getArrayVarData voteVar - let result = assess $ getOnlyVoters $ votes - when (result == Nothing) $ outputAll "Vote: Quorum not reached, rule is rejected" - sendMessage msgEnd $ fromMaybe False $ result - --- | assess the vote with the assess function when time is elapsed, and sends a signal with the issue (positive of negative) -assessOnTimeDelay :: NominalDiffTime -> Assessor () -assessOnTimeDelay delay = do - t <- addUTCTime delay <$> lift getCurrentTime - assessOnTimeLimit t - --- | assess the vote only when every body voted. An error is generated if the assessing function returns Nothing. -assessWhenEverybodyVoted :: Assessor () -assessWhenEverybodyVoted = do - (VoteData msgEnd voteVar _ assess) <- get - lift $ do - msgVotes <- getArrayVarMessage voteVar - onMessage msgVotes $ \(MessageData votes) -> when (length (voters votes) == length votes) $ - sendMessage msgEnd $ fromJust $ assess $ votes - --- | players that did not voted are counted as negative. -noStatusQuo :: [Vote] -> [Vote] -noStatusQuo = map noVoteCountAsAgainst where - noVoteCountAsAgainst :: Vote -> Vote - noVoteCountAsAgainst (a, Nothing) = (a, Just Against) - noVoteCountAsAgainst a = a - --- | clean events and variables necessary for the vote -cleanVote :: VoteData -> Nomex () -cleanVote (VoteData msgEnd voteVar inputsNumber _) = onMessage msgEnd$ \_ -> do - delAllEvents msgEnd - delArrayVar voteVar - mapM_ delEvent inputsNumber - -assessOnlyVoters :: CountVotes -> CountVotes -assessOnlyVoters assess vs = assess $ map (second Just) $ voters vs - --- | a quorum is the neccessary number of voters for the validity of the vote -quorum :: Int -> [Vote] -> Bool -quorum q vs = (length $ voters vs) >= q - --- | adds a quorum to an assessing function -withQuorum :: CountVotes -> Int -> CountVotes -withQuorum assess q vs = if (quorum q vs) then assess vs else Nothing - --- | assess the vote results according to a unanimity (everybody votes for) -unanimity :: [Vote] -> Maybe Bool -unanimity votes = voteQuota (length votes) votes - --- | assess the vote results according to an absolute majority (half voters plus one, no quorum is needed) -majority :: [Vote] -> Maybe Bool -majority votes = voteQuota ((length votes) `div` 2 + 1) votes - --- | assess the vote results according to a majority of x (in %) -majorityWith :: Int -> [Vote] -> Maybe Bool -majorityWith x votes = voteQuota ((length votes) * x `div` 100 + 1) votes - --- | assess the vote results according to a necessary number of positive votes -numberPositiveVotes :: Int -> [Vote] -> Maybe Bool -numberPositiveVotes = voteQuota - --- | helper function for assessement functions -voteQuota :: Int -> [Vote] -> Maybe Bool -voteQuota quotaFor votes - | nbFor votes >= quotaFor = Just True - | nbAgainst votes > (length votes) - quotaFor = Just False - | otherwise = Nothing - --- | get the number of positive votes and negative votes -nbFor, nbAgainst :: [Vote] -> Int -nbFor = length . filter ((== Just For) . snd) -nbAgainst = length . filter ((== Just Against) . snd) - --- | get only those who voted -voters :: [(PlayerNumber, Maybe ForAgainst)] -> [(PlayerNumber, ForAgainst)] -voters vs = catMaybes $ map voter vs where - voter (pn, Just fa) = Just (pn, fa) - voter (_, Nothing) = Nothing - --- | get only those who voted -getOnlyVoters :: [(PlayerNumber, Maybe ForAgainst)] -> [(PlayerNumber, Maybe ForAgainst)] -getOnlyVoters vs = map (second Just) $ voters vs +onRuleProposed :: (Rule -> Nomex (Msg [ForAgainst]) ) -> RuleFunc +onRuleProposed f = voidRule $ onEvent_ (RuleEv Proposed) $ \(RuleData rule) -> do + resp <- f rule + onMessageOnce resp $ (activateOrReject rule) . (== [For]) . messageData -- | activate or reject a rule activateOrReject :: Rule -> Bool -> Nomex () @@ -244,9 +112,3 @@ let myrs = filter ((== p) . getL rProposedBy) rs res <- mapM (suppressRule . _rNumber) myrs return $ and res - -oneDay :: NominalDiffTime -oneDay = 60 * 60 * 24 - -maybeWhen :: Maybe a -> (a -> Nomex ()) -> Nomex () -maybeWhen = forM_ 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 @@ -5,11 +5,12 @@ import Language.Nomyx.Rule import Language.Nomyx.Expression import Language.Nomyx.Evaluation -import Language.Nomyx.Definition +import Language.Nomyx.Utils +import Language.Nomyx.Vote import Control.Monad.State import Data.Typeable import Data.Lens - +import Language.Nomyx.Definition date1 = parse822Time "Tue, 02 Sep 1997 09:00:00 -0400" date2 = parse822Time "Tue, 02 Sep 1997 10:00:00 -0400" @@ -35,9 +36,9 @@ _rAssessedBy = Nothing} evalRuleFunc f = evalState (runEvalError 0 $ evalExp f 0) testGame -execRuleFuncEvent f e d = execState (runEvalError 0 $ evalExp f 0 >> (triggerEvent e d)) testGame +execRuleFuncEvent f e d = execState (runEvalError 0 $ evalExp f 0 >> (triggerEvent_ e d)) testGame execRuleFuncGame f g = execState (runEvalError 0 $ void $ evalExp f 0) g -execRuleFuncEventGame f e d g = execState (runEvalError 0 $ evalExp f 0 >> (triggerEvent e d)) g +execRuleFuncEventGame f e d g = execState (runEvalError 0 $ evalExp f 0 >> (triggerEvent_ e d)) g execRuleFunc f = execRuleFuncGame f testGame tests = [("test var 1", testVarEx1), @@ -52,7 +53,7 @@ ("test user input write", testUserInputWriteEx), ("test activate rule", testActivateRuleEx), ("test auto activate", testAutoActivateEx), - ("test meta rules vote", testApplicationMetaRuleEx), + --("test meta rules vote", testApplicationMetaRuleEx), ("test time event", testTimeEventEx), ("test time event 2", testTimeEventEx2), ("test assess on vote complete 1", testVoteAssessOnVoteComplete1), @@ -208,7 +209,7 @@ testTimeEvent2 :: Nomex () testTimeEvent2 = schedule' [date1, date2] (outputAll . show) -testTimeEventEx2 = (_outputs $ flip execState testGame (runEvalError 0 $ evalExp testTimeEvent2 0 >> gameEvs)) == [(1,show date2), (1,show date1)] where +testTimeEventEx2 = (_outputs $ flip execState testGame (runEvalError 0 $ evalExp testTimeEvent2 0 >> void gameEvs)) == [(1,show date2), (1,show date1)] where gameEvs = do evTriggerTime date1 evTriggerTime date2 @@ -221,13 +222,16 @@ mapM_ (\x -> addPlayer (PlayerInfo x $ "coco " ++ (show x))) [1..total] actions evProposeRule testRule - mapM_ (\x -> evInputChoice (InputChoice x "Vote for rule 0" [For, Against] For) For) [1..positives] - mapM_ (\x -> evInputChoice (InputChoice (x+positives) "Vote for rule 0" [For, Against] For) Against) [1..negatives] - when timeEvent $ evTriggerTime date2 + 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 + 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 = "unanimityRule", _rRuleFunc = rf, _rNumber = 1, _rStatus = Active} + let rule = testRule {_rName = "testRule", _rRuleFunc = rf, _rNumber = 1, _rStatus = Active} evAddRule rule evActivateRule (_rNumber rule) 0 return () @@ -239,34 +243,34 @@ voteGameTimed positives negatives notVoted rf = voteGame' positives negatives notVoted True rf -- Test application meta rule -unanimityRule = testRule {_rName = "unanimityRule", _rRuleFunc = return $ Meta $ voteWith unanimity $ assessWhenEverybodyVoted, _rNumber = 1, _rStatus = Active} -applicationMetaRuleRule = testRule {_rName = "onRuleProposedUseMetaRules", _rRuleFunc = onRuleProposed checkWithMetarules, _rNumber = 2, _rStatus = Active} -testApplicationMetaRuleVote :: Game -testApplicationMetaRuleVote = voteGameActions 2 0 2 False $ do - evAddRule unanimityRule - evActivateRule (_rNumber unanimityRule) 0 - evAddRule applicationMetaRuleRule - evActivateRule (_rNumber applicationMetaRuleRule) 0 - return () +--unanimityRule = testRule {_rName = "unanimityRule", _rRuleFunc = return $ Meta $ voteWith unanimity $ assessWhenEverybodyVoted, _rNumber = 1, _rStatus = Active} +--applicationMetaRuleRule = testRule {_rName = "onRuleProposedUseMetaRules", _rRuleFunc = onRuleProposed checkWithMetarules, _rNumber = 2, _rStatus = Active} +--testApplicationMetaRuleVote :: Game +--testApplicationMetaRuleVote = voteGameActions 2 0 2 False $ do +-- evAddRule unanimityRule +-- evActivateRule (_rNumber unanimityRule) 0 +-- evAddRule applicationMetaRuleRule +-- evActivateRule (_rNumber applicationMetaRuleRule) 0 +-- return () -testApplicationMetaRuleEx = (_rStatus $ head $ _rules testApplicationMetaRuleVote) == Active +--testApplicationMetaRuleEx = (_rStatus $ head $ _rules testApplicationMetaRuleVote) == Active --- vote rules -testVoteAssessOnVoteComplete1 = testVoteRule Active $ voteGame 10 0 10 $ onRuleProposed $ voteWith majority $ assessWhenEverybodyVoted -testVoteAssessOnVoteComplete2 = testVoteRule Pending $ voteGame 9 0 10 $ onRuleProposed $ voteWith majority $ assessWhenEverybodyVoted -testVoteAssessOnEveryVotes1 = testVoteRule Active $ voteGame 10 0 10 $ onRuleProposed $ voteWith unanimity $ assessOnEveryVotes -testVoteAssessOnEveryVotes2 = testVoteRule Active $ voteGame 6 0 10 $ onRuleProposed $ voteWith majority $ assessOnEveryVotes -testVoteAssessOnEveryVotes3 = testVoteRule Pending $ voteGame 5 0 10 $ onRuleProposed $ voteWith majority $ assessOnEveryVotes -testVoteAssessOnEveryVotes4 = testVoteRule Reject $ voteGame 0 5 10 $ onRuleProposed $ voteWith majority $ assessOnEveryVotes -testVoteMajorityWith = testVoteRule Active $ voteGame 6 0 10 $ onRuleProposed $ voteWith (majorityWith 50) $ assessOnEveryVotes -testVoteNumberPositiveVotes = testVoteRule Active $ voteGame 3 7 10 $ onRuleProposed $ voteWith (numberPositiveVotes 3) $ assessOnEveryVotes -testVoteWithQuorum1 = testVoteRule Active $ voteGame 7 3 10 $ onRuleProposed $ voteWith (majority `withQuorum` 7) $ assessOnEveryVotes -testVoteWithQuorum2 = testVoteRule Pending $ voteGame 6 0 10 $ onRuleProposed $ voteWith (majority `withQuorum` 7) $ assessOnEveryVotes -testVoteAssessOnTimeLimit1 = testVoteRule Active $ voteGameTimed 10 0 10 $ onRuleProposed $ voteWith unanimity $ assessOnTimeLimit date2 -testVoteAssessOnTimeLimit2 = testVoteRule Active $ voteGameTimed 1 0 10 $ onRuleProposed $ voteWith unanimity $ assessOnTimeLimit date2 -testVoteAssessOnTimeLimit3 = testVoteRule Reject $ voteGameTimed 1 0 10 $ onRuleProposed $ voteWith (unanimity `withQuorum` 5) $ assessOnTimeLimit date2 -testVoteAssessOnTimeLimit4 = testVoteRule Reject $ voteGameTimed 0 0 10 $ onRuleProposed $ voteWith (unanimity `withQuorum` 1) $ assessOnTimeLimit date2 -testVoteAssessOnTimeLimit5 = testVoteRule Pending $ voteGameTimed 10 0 10 $ onRuleProposed $ voteWith unanimity $ assessOnTimeLimit date3 +-- vote rules |Expected result |pos |neg |total |description of voting system +testVoteAssessOnVoteComplete1 = testVoteRule Active $ voteGame 10 0 10 $ onRuleProposed $ voteWith_ majority $ assessWhenEverybodyVoted +testVoteAssessOnVoteComplete2 = testVoteRule Pending $ voteGame 9 0 10 $ onRuleProposed $ voteWith_ majority $ assessWhenEverybodyVoted +testVoteAssessOnEveryVotes1 = testVoteRule Active $ voteGame 10 0 10 $ onRuleProposed $ voteWith_ unanimity $ assessOnEveryVotes +testVoteAssessOnEveryVotes2 = testVoteRule Active $ voteGame 6 0 10 $ onRuleProposed $ voteWith_ majority $ assessOnEveryVotes +testVoteAssessOnEveryVotes3 = testVoteRule Pending $ voteGame 5 0 10 $ onRuleProposed $ voteWith_ majority $ assessOnEveryVotes +testVoteAssessOnEveryVotes4 = testVoteRule Reject $ voteGame 0 5 10 $ onRuleProposed $ voteWith_ majority $ assessOnEveryVotes +testVoteMajorityWith = testVoteRule Active $ voteGame 6 0 10 $ onRuleProposed $ voteWith_ (majorityWith 50) $ assessOnEveryVotes +testVoteNumberPositiveVotes = testVoteRule Active $ voteGame 3 7 10 $ onRuleProposed $ voteWith_ (numberPositiveVotes 3) $ assessOnEveryVotes +testVoteWithQuorum1 = testVoteRule Active $ voteGame 7 3 10 $ onRuleProposed $ voteWith_ (majority `withQuorum` 7) $ assessOnEveryVotes +testVoteWithQuorum2 = testVoteRule Pending $ voteGame 6 0 10 $ onRuleProposed $ voteWith_ (majority `withQuorum` 7) $ assessOnEveryVotes +testVoteAssessOnTimeLimit1 = testVoteRule Active $ voteGameTimed 10 0 10 $ onRuleProposed $ voteWith_ unanimity $ assessOnTimeLimit date2 +testVoteAssessOnTimeLimit2 = testVoteRule Active $ voteGameTimed 1 0 10 $ onRuleProposed $ voteWith_ unanimity $ assessOnTimeLimit date2 +testVoteAssessOnTimeLimit3 = testVoteRule Reject $ voteGameTimed 1 0 10 $ onRuleProposed $ voteWith_ (unanimity `withQuorum` 5) $ assessOnTimeLimit date2 +testVoteAssessOnTimeLimit4 = testVoteRule Reject $ voteGameTimed 0 0 10 $ onRuleProposed $ voteWith_ (unanimity `withQuorum` 1) $ assessOnTimeLimit date2 +testVoteAssessOnTimeLimit5 = testVoteRule Pending $ voteGameTimed 10 0 10 $ onRuleProposed $ voteWith_ unanimity $ assessOnTimeLimit date3 testVoteRule s g = (_rStatus $ head $ _rules g) == s diff --git a/src/Language/Nomyx/Utils.hs b/src/Language/Nomyx/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Language/Nomyx/Utils.hs @@ -0,0 +1,54 @@ + + + +module Language.Nomyx.Utils where + + +import Data.Time +import Data.Typeable (cast, Typeable) +import Debug.Trace.Helpers (traceM) +import Data.Maybe (fromJust, catMaybes) +import System.Locale (rfc822DateFormat, defaultTimeLocale) +import Control.Monad.State +import Control.Monad.Identity +import Debug.Trace (trace) +import Data.List (intersperse) + +-- | durations +oneWeek, oneDay, oneHour, oneMinute :: NominalDiffTime +oneWeek = 7 * oneDay +oneDay = 24 * oneHour +oneHour = 60 * oneMinute +oneMinute = 60 + +-- | an equality that tests also the types. +(===) :: (Typeable a, Typeable b, Eq b) => a -> b -> Bool +(===) x y = cast x == Just y + +-- | Replaces all instances of a value in a list by another value. +replaceWith :: (a -> Bool) -- ^ Value to search + -> a -- ^ Value to replace it with + -> [a] -- ^ Input list + -> [a] -- ^ Output list +replaceWith f y = map (\z -> if f z then y else z) + +tracePN :: (Monad m ) => Int -> String -> m () +tracePN pn s = traceM $ "Player " ++ (show pn) ++ " " ++ s + +traceData :: (Show a) => String -> a -> a +traceData s a = trace (s ++ " " ++ (show a)) a + +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 (_, Nothing) = Nothing + +mapStateIO :: Show s => State s a -> StateT s IO a +mapStateIO = mapStateT $ return . runIdentity diff --git a/src/Language/Nomyx/Vote.hs b/src/Language/Nomyx/Vote.hs new file mode 100644 --- /dev/null +++ b/src/Language/Nomyx/Vote.hs @@ -0,0 +1,230 @@ +{-# LANGUAGE ScopedTypeVariables, FlexibleInstances, TypeFamilies, FlexibleContexts, + DeriveDataTypeable, GADTs #-} + +-- | Voting system +module Language.Nomyx.Vote where + +import Prelude hiding (foldr) +import Language.Nomyx.Expression +import Language.Nomyx.Definition +import Data.Typeable +import Control.Monad.State hiding (forM_) +import Data.Maybe +import Data.Time hiding (getCurrentTime) +import Control.Arrow +import Control.Applicative +import Data.List (sort, group) +import Language.Nomyx.Utils (oneDay) +import qualified Data.Map as M +import Control.Monad.Error (MonadError(..)) + +data VoteType a = ExclusiveVote (Maybe (Alts a)) + | NonExclusiveVote [Alts a] + +class (Eq (Alts a), Show (Alts a), Ord (Alts a), Typeable a) => Votable a where + data Alts a + alts :: [Alts a] + quota :: Alts a -> Int -> Int -> Int + name :: a -> String + exclusiveWinner :: a -> Maybe (Alts a, Alts a) + exclusiveWinner _ = Nothing + +type ForAgainst = Alts Rule +instance Votable Rule where + data Alts Rule = For | Against deriving (Typeable, Enum, Show, Eq, Bounded, Read, Ord) + alts = [For, Against] + quota For q _ = q + quota Against q vs = vs - q + 1 + name r = "rule " ++ (show $ _rNumber r) + exclusiveWinner _ = Just (For, Against) + + +type Vote a = (PlayerNumber, Maybe (Alts a)) +type VoteResult a = VoteStats a -> [Alts a] +data VoteStats a = VoteStats { voteCounts :: M.Map (Maybe (Alts a)) Int, + voteFinished :: Bool} + +data VoteData a = VoteData { msgEnd :: Msg [Alts a], -- message sent when the vote is finished with the winners + voteVar :: ArrayVar PlayerNumber (Alts a),-- variable containing the votes + inputNumbers :: [EventNumber], -- numbers of the toggle inputs of the players (to delete them at the end of vote) + assessFunction :: VoteResult a} -- function used to count the votes +type Assessor a = StateT (VoteData a) Nomex () + + + +-- | Performs 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). + -> a -- ^ toVote: the matter to be voted. + -> [Alts a] -- ^ the vote alternatives. + -> Nomex (Msg [Alts a]) -- ^ return value: a message containing the result of the vote. +voteWith countVotes assessors toVote als = do + pns <- getAllPlayerNumbers + 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 + inputs <- mapM askPlayer pns + let voteData = VoteData msgEnd voteVar inputs countVotes + evalStateT assessors voteData + cleanVote voteData + return $ msgEnd + +-- | Performs a vote, all the possible alternatives are selected. +voteWith_ :: (Votable a) => VoteResult a -> Assessor a -> a -> Nomex (Msg [Alts a]) +voteWith_ assessFunction assessors toVote = voteWith assessFunction assessors toVote alts + + +-- | assess the vote on every new vote with the assess function, and as soon as the vote has an issue (positive of negative), sends a signal +assessOnEveryVotes :: (Votable a) => Assessor a +assessOnEveryVotes = 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 + + +-- | assess the vote with the assess function when time is reached, and sends a signal with the issue (positive of negative) +assessOnTimeLimit :: (Votable a) => UTCTime -> Assessor a +assessOnTimeLimit time = do + (VoteData msgEnd voteVar _ assess) <- get + lift $ do + onEvent_ (Time time) $ \_ -> do + votes <- getArrayVarData voteVar + sendMessage msgEnd (assess $ getVoteStats votes True) + + +-- | assess the vote with the assess function when time is elapsed, and sends a signal with the issue (positive of negative) +assessOnTimeDelay :: (Votable a) => NominalDiffTime -> Assessor a +assessOnTimeDelay delay = do + t <- addUTCTime delay <$> lift getCurrentTime + assessOnTimeLimit t + +-- | assess the vote only when every body voted. An error is generated if the assessing function returns Nothing. +assessWhenEverybodyVoted :: (Votable a) => Assessor a +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 + + +-- | clean events and variables necessary for the vote +cleanVote :: (Votable a) => VoteData a -> Nomex () +cleanVote (VoteData msgEnd voteVar inputsNumber _) = onMessage msgEnd$ \_ -> do + delAllEvents msgEnd + delArrayVar voteVar + mapM_ delEvent inputsNumber + + +-- | a quorum is the neccessary number of voters for the validity of the vote +quorum :: (Votable a) => Int -> VoteStats a -> Bool +quorum q vs = (voted vs) >= q + +-- | adds a quorum to an assessing function +withQuorum :: (Votable a) => VoteResult a -> Int -> VoteResult a +withQuorum assess q vs = if (quorum q vs) then assess vs else [] + +-- | assess the vote results according to a unanimity (everybody votes for) +unanimity :: (Votable a) => VoteStats a -> [Alts a] +unanimity vs = voteQuota (nbVoters vs) vs + +-- | assess the vote results according to an absolute majority (half voters plus one, no quorum is needed) +majority :: (Votable a) => VoteStats a -> [Alts a] +majority vs = voteQuota ((nbVoters vs) `div` 2 + 1) vs + +-- | assess the vote results according to a majority of x (in %) +majorityWith :: (Votable a) => Int -> VoteStats a -> [Alts a] +majorityWith x vs = voteQuota ((nbVoters vs) * x `div` 100 + 1) vs + +-- | assess the vote results according to a necessary number of positive votes +numberPositiveVotes :: (Votable a) => Int -> VoteStats a -> [Alts a] +numberPositiveVotes i vs = voteQuota i vs + +-- | return the vote alternatives that are above threshold +voteQuota :: forall a. (Votable a) => Int -> VoteStats a -> [Alts a] +voteQuota q votes = case (exclusiveWinner (undefined :: a)) of + Nothing -> catMaybes $ M.keys $ M.filter (>= q) (voteCounts votes) + Just a -> maybeToList $ exclusiveVoteQuota q votes a + +exclusiveVoteQuota :: (Votable a) => Int -> VoteStats a -> (Alts a, Alts a) -> Maybe (Alts a) +exclusiveVoteQuota q votes (for, against) + | M.findWithDefault 0 (Just for) vs >= q = Just for + | M.findWithDefault 0 (Just against) vs > (nbVoters votes) - q = Just against + | otherwise = Nothing + where vs = voteCounts votes + + +-- | number of people that voted if the voting is finished, +-- total number of people that should vote otherwise +nbVoters :: (Votable a) => VoteStats a -> Int +nbVoters vs + | voteFinished vs = (totalVoters vs) - (notVoted vs) + | otherwise = totalVoters vs + +totalVoters, voted, notVoted :: (Votable a) => VoteStats a -> Int +totalVoters vs = M.foldr (+) 0 (voteCounts vs) +notVoted vs = fromMaybe 0 $ M.lookup Nothing (voteCounts vs) +voted vs = (totalVoters vs) - (notVoted vs) + + +getVoteStats :: (Votable a) => [Vote a] -> Bool -> VoteStats a +getVoteStats vs voteFinished = VoteStats + {voteCounts = M.fromList $ counts (snd <$> vs), + voteFinished = voteFinished} + +counts :: (Eq a, Ord a) => [a] -> [(a, Int)] +counts as = map (head &&& length) (group $ sort as) + + +-- * Referendum & elections + +data Referendum = Referendum String deriving (Typeable) +instance Votable Referendum where + data Alts Referendum = Yes | No deriving (Enum, Show, Eq, Bounded, Read, Ord) + alts = [Yes, No] + quota Yes q _ = q + quota No q vs = vs - q + 1 + name (Referendum n) = "referendum on " ++ n + +referendum :: String -> Nomex () -> RuleFunc +referendum name action = voidRule $ do + msg <- voteWith_ (majority `withQuorum` 2) (assessOnEveryVotes >> assessOnTimeDelay oneDay) (Referendum name) + onMessageOnce msg resolution where + resolution (MessageData [Yes]) = do + outputAll "Positive result of referendum" + action + resolution (MessageData [No]) = outputAll "Negative result of referendum" + resolution (MessageData []) = outputAll "No result for referendum" + resolution (MessageData _) = throwError "Impossible result for referendum" + + +data Election = Election String deriving (Typeable) +instance Votable Election where + data Alts Election = Candidate {candidate :: PlayerInfo} + alts = map (\n -> Candidate (PlayerInfo n "")) [1..] + quota _ q _ = q + name (Election n) = "elections on " ++ n + +instance Show (Alts Election) where + show (Candidate (PlayerInfo _ name)) = name + +instance Eq (Alts Election) where + (Candidate (PlayerInfo pn1 _)) == (Candidate (PlayerInfo pn2 _)) = pn1 == pn2 + +instance Ord (Alts Election) where + compare (Candidate (PlayerInfo pn1 _)) (Candidate (PlayerInfo pn2 _)) = compare pn1 pn2 + +elections :: String -> [PlayerInfo] -> (PlayerNumber -> Nomex()) -> Nomex () +elections name pns action = do + msg <- voteWith majority (assessWhenEverybodyVoted {-assessOnEveryVotes >> assessOnTimeDelay oneDay-}) (Election name) (Candidate <$> pns) + onMessageOnce msg resolution where + resolution (MessageData [Candidate pi]) = do + outputAll $ "Result of elections: player(s) " ++ (show $ _playerName pi) ++ " won!" + action $ _playerNumber pi + resolution (MessageData []) = outputAll $ "Result of elections: nobody won!" + resolution (MessageData _) = throwError "Impossible result for elections"