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.6.2 +version: 0.7.0 cabal-version: >=1.6 ---Warning: to use "cabal sdist", this patch is needed in cabal: https://github.com/haskell/cabal/pull/1110 ---This allows cabal to work with exported generated modules (Paths_Nomyx_Language) @@ -32,12 +32,12 @@ library build-depends: DebugTraceHelpers == 0.12.*, Boolean == 0.2.*, - base == 4.6.*, + base >= 4.6 && <= 5, containers == 0.5.*, data-lens == 2.10.*, data-lens-template == 2.1.*, data-lens-fd == 2.0.*, - ghc == 7.6.*, + ghc >= 7.6 && <= 7.10, mtl == 2.1.*, old-locale == 1.0.*, safe == 0.3.*, @@ -54,6 +54,7 @@ Language.Nomyx.Rules Language.Nomyx.Vote Paths_Nomyx_Language + Control.Shortcut exposed: True buildable: True hs-source-dirs: src @@ -61,5 +62,5 @@ source-repository head type: git - location: https://github.com/cdupont/Nomyx-Language.git + location: https://github.com/cdupont/Nomyx.git diff --git a/src/Control/Shortcut.hs b/src/Control/Shortcut.hs new file mode 100644 --- /dev/null +++ b/src/Control/Shortcut.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Control.Shortcut where + +import Control.Applicative +import Control.Monad +import Data.Either +import Data.Maybe + +-- | class of things that can be run in parallel and can be shortcuted. +-- The funtion in parameter is called everytime an intermediate result is known, as soon as it +-- returns True the intermediate results are returned (discarding those not yet available). +-- the order of the lists must be preserved +class Shortcutable s where + shortcut :: [s a] -> ([Maybe a] -> Bool) -> s [Maybe a] + +-- | version without the maybes +shortcut_ :: (Functor s, Shortcutable s) => [s a] -> ([a] -> Bool) -> s [a] +shortcut_ as f = catMaybes <$> shortcut as (f . catMaybes) + +-- | version with two different types of result +shortcut2 :: (Functor s, Monad s, Shortcutable s) => [s a] -> [s b] -> ([Maybe a] -> [Maybe b] -> Bool) -> s ([Maybe a], [Maybe b]) +shortcut2 as bs f = do + let stripEitherFst aes = map (fromLeft <$>) $ take (length as) aes + let stripEitherLst bes = map (fromRight <$>) $ drop (length as) bes + let f' abs = f (stripEitherFst abs) (stripEitherLst abs) + mabs <- shortcut ((map (Left <$>) as) ++ (map (Right <$>) bs)) f' + return (stripEitherFst mabs, stripEitherLst mabs) + +-- | version with a supplementary event which result is discarded +shortcut2b :: (Functor s, Monad s, Shortcutable s) => [s a] -> s b -> ([Maybe a] -> Bool -> Bool) -> s ([Maybe a], Bool) +shortcut2b as b f = do + let f' as bs = f as (isJust $ head bs) + (as, bs) <- shortcut2 as [b] f' + return (as, isJust $ head bs) + +fromLeft :: Either a b -> a +fromLeft (Right _) = error "Argument takes form 'Right _'" +fromLeft (Left x) = x + +fromRight :: Either a b -> b +fromRight (Left _) = error "Argument takes form 'Left _'" +fromRight (Right x) = x diff --git a/src/Language/Nomyx/Events.hs b/src/Language/Nomyx/Events.hs --- a/src/Language/Nomyx/Events.hs +++ b/src/Language/Nomyx/Events.hs @@ -3,7 +3,9 @@ -- | All the building blocks to allow rules to build events. module Language.Nomyx.Events ( onEvent, onEvent_, onEventOnce, - delEvent, + delEvent, + getEvents, getEvent, + getIntermediateResults, sendMessage, sendMessage_, onMessage, onMessageOnce, schedule, schedule_, schedule', schedule'_, @@ -11,13 +13,17 @@ oneWeek, oneDay, oneHour, oneMinute, timeEvent, messageEvent, victoryEvent, playerEvent, ruleEvent, baseEvent, baseInputEvent, - shortcutEvents + liftNomexNE ) where import Language.Nomyx.Expression import Data.Typeable import Control.Monad.State -import Data.List +import Control.Applicative +import Control.Shortcut +import Data.List +import Data.Maybe +import Data.Either import Data.Time hiding (getCurrentTime) import Data.Time.Recurrence hiding (filter) import Safe @@ -43,6 +49,23 @@ delEvent :: EventNumber -> Nomex Bool delEvent = DelEvent +getEvents :: NomexNE [EventInfo] +getEvents = GetEvents + +getEvent :: EventNumber -> NomexNE (Maybe EventInfo) +getEvent en = find (\(EventInfo en2 _ _ _ evst _) -> en == en2 && evst == SActive) <$> getEvents + +getIntermediateResults :: EventNumber -> NomexNE (Maybe [(PlayerNumber, SomeData)]) +getIntermediateResults en = do + mev <- getEvent en + case mev of + Just ev -> return $ Just $ mapMaybe getInputResult (_env ev) + Nothing -> return Nothing + +getInputResult :: FieldResult -> Maybe (PlayerNumber, SomeData) +getInputResult (FieldResult (Input pn _ _) r _) = Just (pn, SomeData r) +getInputResult _ = Nothing + -- | broadcast a message that can be catched by another rule sendMessage :: (Typeable a, Show a) => Msg a -> a -> Nomex () sendMessage = SendMessage @@ -115,7 +138,7 @@ messageEvent :: (Typeable a) => Msg a -> Event a messageEvent = BaseEvent . Message -victoryEvent :: Event VictoryCond +victoryEvent :: Event VictoryInfo victoryEvent = BaseEvent Victory playerEvent :: Player -> Event PlayerInfo @@ -125,9 +148,7 @@ ruleEvent re = BaseEvent $ RuleEv re baseInputEvent :: (Typeable a) => PlayerNumber -> String -> (InputForm a) -> Field a -baseInputEvent pn s iform = Input Nothing pn s iform - -shortcutEvents :: [Event a] -> ([a] -> Maybe b) -> Event b -shortcutEvents = ShortcutEvents - +baseInputEvent pn s iform = Input pn s iform +liftNomexNE :: NomexNE a -> Event a +liftNomexNE = LiftNomexNE 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,5 +1,6 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DoAndIfThenElse #-} -- | 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. @@ -18,12 +19,13 @@ makeKing, monarchy, revolution, - displayTime, + displayCurrentTime, + displayActivateTime, iWin, returnToDemocracy, victoryXRules, victoryXEcu, - --noGroupVictory, + noGroupVictory, banPlayer, -- referendum, -- referendumOnKickPlayer, @@ -39,8 +41,10 @@ import Data.Time.Recurrence as X hiding (filter) import Data.List as X import Data.Typeable +import Data.Maybe import Control.Arrow import Control.Monad as X +import Control.Applicative import Safe (readDef) import Language.Nomyx @@ -81,19 +85,28 @@ winXEcuOnRuleAccepted x = void $ onEvent_ (ruleEvent Activated) $ \rule -> void $ modifyValueOfPlayer (_rProposedBy rule) accounts (+x) -- | a player can transfer money to another player --- it does not accept new players or check if balance is positive, to keep the example simple moneyTransfer :: Rule moneyTransfer = do - pls <- liftEffect getAllPlayerNumbers - when (length pls >= 2) $ void $ forEachPlayer_ (selPlayer pls) where - selPlayer pls src = void $ onInputRadio_ "Transfer money to player: " (delete src $ sort pls) (selAmount src) src - selAmount src dst = void $ onInputTextOnce ("Select Amount to transfert to player: " ++ show dst) (transfer src dst) src - transfer src dst amount = do - modifyValueOfPlayer dst accounts (\a -> a + (readDef 0 amount)) - modifyValueOfPlayer src accounts (\a -> a - (readDef 0 amount)) - void $ newOutput (Just src) (return $ "You gave " ++ amount ++ " ecus to player " ++ show dst) - void $ newOutput (Just dst) (return $ "Player " ++ show src ++ " gaved you " ++ amount ++ "ecus") + let askAmount :: PlayerNumber -> Event (PlayerNumber, Int) + askAmount src = do + pls <- liftNomexNE getAllPlayerNumbers + guard (length pls >= 2) >> do + dst <- inputRadio' src "Transfer money to player: " (delete src $ sort pls) + amount <- inputText src ("Select Amount to transfert to player " ++ show dst ++ ": ") + return (dst, readDef 0 amount) + void $ forEachPlayer_ (\pn -> void $ onEvent_ (askAmount pn) (transfer pn)) +-- | helper function to transfer money from first player to second player +transfer :: PlayerNumber -> (PlayerNumber, Int) -> Nomex () +transfer src (dst, amount) = do + balance <- liftEffect $ getValueOfPlayer src accounts + if (amount > 0 && fromJust balance >= amount) then do + modifyValueOfPlayer dst accounts (\a -> a + amount) + modifyValueOfPlayer src accounts (\a -> a - amount) + void $ newOutput_ (Just src) ("You gave " ++ (show amount) ++ " ecus to player " ++ show dst) + void $ newOutput_ (Just dst) ("Player " ++ show src ++ " gave you " ++ (show amount) ++ "ecus") + else void $ newOutput_ (Just src) ("Insufficient balance or wrong amount") + -- | delete a rule delRule :: RuleNumber -> Rule delRule rn = suppressRule_ rn >> autoDelete @@ -109,20 +122,21 @@ king = msgVar "King" -- | Monarchy: only the king decides which rules to accept or reject -monarchy :: Rule -monarchy = void $ onEvent_ (ruleEvent Proposed) $ \rule -> do - k <- readMsgVar_ king - void $ onInputRadioOnce ("Your Royal Highness, do you accept rule " ++ (show $ _rNumber rule) ++ "?") [True, False] (activateOrRejectRule rule) k +monarchy :: PlayerNumber -> Rule +monarchy pn = do + makeKing pn + void $ onEvent_ (ruleEvent Proposed) $ \rule -> do + k <- readMsgVar_ king + void $ onInputRadioOnce ("Your Royal Highness, do you accept rule " ++ (show $ _rNumber rule) ++ "?") [True, False] (activateOrRejectRule rule) k -- | Revolution! Hail to the king! -- This rule suppresses the democracy (usually rules 1 and 2), installs the king and activates monarchy. revolution :: PlayerNumber -> Rule -revolution player = do +revolution pn = do suppressRule 1 - makeKing player - rNum <- addRuleParams "Monarchy" monarchy "monarchy" "Monarchy: only the king can vote on new rules" + rNum <- addRule' "Monarchy" (monarchy pn) ("monarchy " ++ (show pn)) "Monarchy: only the king can vote on new rules" activateRule_ rNum - --autoDelete + autoDelete -- | set the victory for players having more than X accepted rules victoryXRules :: Int -> Rule @@ -139,17 +153,27 @@ let victorious as = map fst $ filter ((>= x) . snd) as return $ maybe [] victorious as --- | will display the time to all players in 5 seconds -displayTime :: Rule -displayTime = void $ outputAll $ do +-- | will display the current time (when refreshing the screen) +displayCurrentTime :: Rule +displayCurrentTime = void $ outputAll $ do t <- getCurrentTime - return $ show t + return $ "The current time is: " ++ (show t) +-- | will display the time at which the rule as been activated +displayActivateTime :: Nomex () +displayActivateTime = do + time <- liftEffect getCurrentTime + outputAll_ $ "This rule was activated at: " ++ (show time) + -- | Only one player can achieve victory: No group victory. -- Forbidding group victory usually becomes necessary when lowering the voting quorum: -- a coalition of players could simply force a "victory" rule and win the game. ---noGroupVictory :: RuleFunc ---noGroupVictory = ruleFunc $ onEvent_ Victory $ \(VictoryData ps) -> when (length ps >1) $ setVictory [] +noGroupVictory :: Rule +noGroupVictory = do + let testVictory (VictoryInfo _ cond) = do + vics <- liftEffect cond + when (length vics >1) $ setVictory (return []) --unset victory condition + void $ onEvent_ victoryEvent testVictory -- | Rule that state that you win. Good luck on having this accepted by other players ;) iWin :: Rule @@ -167,7 +191,7 @@ returnToDemocracy :: [RuleNumber] -> Rule returnToDemocracy rs = do mapM_ suppressRule rs - rNum <- addRuleParams "vote with majority" voteWithMajority "voteWithMajority" "majority with a quorum of 2" + rNum <- addRule' "vote with majority" voteWithMajority "voteWithMajority" "majority with a quorum of 2" activateRule_ rNum autoDelete @@ -200,6 +224,20 @@ -- | display a button and greets you when pressed (for player 1) bravoButton :: Rule bravoButton = void $ onInputButton_ "Click here:" (const $ outputAll_ "Bravo!") 1 + +-- | display a button to greet other players +helloButton :: Rule +helloButton = + do + --get your own player number + me <- getProposerNumber_ + --create an output for me only + let displayMsg a = void $ newOutput_ Nothing ("Msg: " ++ a) + --create a button for me, which will display the output when clicked + let button = do + all <- liftNomexNE getPlayers + guard (length all >= 2) >> inputText me "send a message" + void $ onEvent_ button displayMsg enterHaiku :: Rule enterHaiku = void $ 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 @@ -8,15 +8,20 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} -- | This module containt the type definitions necessary to build a Nomic rule. module Language.Nomyx.Expression where import Data.Typeable -import Data.Time +import Data.Time +import GHC.Generics import Control.Applicative hiding (Const) import Data.Lens.Template import Control.Monad.Error +import Control.Shortcut type PlayerNumber = Int type PlayerName = String @@ -34,7 +39,8 @@ -- * Nomyx Expression -data Eff = Effect | NoEffect +data Eff = Effect | NoEffect deriving (Typeable) + type Effect = 'Effect type NoEffect = 'NoEffect @@ -85,11 +91,18 @@ LiftEffect :: NomexNE a -> Nomex a Simu :: Nomex a -> NomexNE Bool -> NomexNE Bool + +#if __GLASGOW_HASKELL__ >= 708 +deriving instance Typeable Exp +deriving instance Typeable 'Effect +deriving instance Typeable 'NoEffect +#else instance Typeable1 (Exp NoEffect) where typeOf1 _ = mkTyConApp (mkTyCon3 "main" "Language.Nomyx.Expression" "Exp NoEffect") [] instance Typeable1 (Exp Effect) where typeOf1 _ = mkTyConApp (mkTyCon3 "main" "Language.Nomyx.Expression" "Exp Effect") [] +#endif liftEffect :: NomexNE a -> Nomex a liftEffect = LiftEffect @@ -113,10 +126,18 @@ catchError = CatchError instance Typeable a => Show (Exp NoEffect a) where +#if __GLASGOW_HASKELL__ < 708 show e = "<" ++ (show $ typeOf e) ++ ">" +#else + show e = "<" ++ (show $ typeRep (Proxy :: Proxy a)) ++ ">" +#endif instance Typeable a => Show (Exp Effect a) where - show e = "<" ++ (show $ typeOf e) ++ ">" +#if __GLASGOW_HASKELL__ < 708 + show e = "<" ++ (show $ typeOf e) ++ ">" +#else + show e = "<" ++ (show $ typeRep (Proxy :: Proxy a)) ++ ">" +#endif instance (Typeable a, Typeable b) => Show (a -> b) where show e = '<' : (show . typeOf) e ++ ">" @@ -130,27 +151,33 @@ -- | Composable events data Event a where - SumEvent :: Event a -> Event a -> Event a -- The first event to fire will be returned - AppEvent :: Event (a -> b) -> Event a -> Event b -- Both events should fire, and then the result is returned - PureEvent :: a -> Event a -- Create a fake event. The result is useable with no delay. - EmptyEvent :: Event a -- An event that is never fired. - ShortcutEvents :: [Event a] -> ([a] -> Maybe b) -> Event b -- a result is returned as soon as it can be computed, dismissing the events that hasn't fired yet - BaseEvent :: (Typeable a) => Field a -> Event a -- Embed a base event + SumEvent :: Event a -> Event a -> Event a -- The first event to fire will be returned + AppEvent :: Event (a -> b) -> Event a -> Event b -- Both events should fire, and then the result is returned + PureEvent :: a -> Event a -- Create a fake event. The result is useable with no delay. + EmptyEvent :: Event a -- An event that is never fired. + BindEvent :: Event a -> (a -> Event b) -> Event b -- A First event should fire, then a second event is constructed + ShortcutEvents :: [Event a] -> ([Maybe a] -> Bool) -> Event [Maybe a] -- Return the intermediate results as soon as the function evaluates to True, dismissing the events that hasn't fired yet + BaseEvent :: (Typeable a) => Field a -> Event a -- Embed a base event + LiftNomexNE :: NomexNE a -> Event a -- create an event containing the result of the NomexNE. deriving Typeable -- | Base events data Field a where - Input :: Maybe InputNumber -> PlayerNumber -> String -> (InputForm a) -> Field a + Input :: PlayerNumber -> String -> (InputForm a) -> Field a Player :: Player -> Field PlayerInfo RuleEv :: RuleEvent -> Field RuleInfo Time :: UTCTime -> Field UTCTime Message :: Msg a -> Field a - Victory :: Field VictoryCond + Victory :: Field VictoryInfo deriving Typeable -- | Type agnostic base event data SomeField = forall a. (Typeable a) => SomeField (Field a) +-- | Type agnostic result data +data SomeData = forall e. (Typeable e, Show e) => SomeData e +deriving instance Show SomeData + -- | Events parameters data Player = Arrive | Leave deriving (Typeable, Show, Eq) data RuleEvent = Proposed | Activated | Rejected | Added | Modified | Deleted deriving (Typeable, Show, Eq) @@ -183,6 +210,17 @@ (<|>) = SumEvent empty = EmptyEvent +instance Monad Event where + (>>=) = BindEvent + return = PureEvent + +instance MonadPlus Event where + mplus = SumEvent + mzero = EmptyEvent + +instance Shortcutable Event where + shortcut = ShortcutEvents + -- EventInfo data EventInfo = forall e. (Typeable e, Show e) => @@ -191,13 +229,19 @@ event :: Event e, handler :: EventHandler e, _evStatus :: Status, - _env :: [EventEnv]} + _env :: [FieldResult]} -data EventEnv = forall e. (Typeable e, Show e) => EventEnv (Field e) e +data FieldAddressElem = SumR | SumL | AppR | AppL | BindR | BindL | Index Int deriving (Show, Read, Ord, Eq, Generic) +type FieldAddress = [FieldAddressElem] +data FieldResult = forall e. (Typeable e, Show e) => + FieldResult {field :: Field e, + fieldResult :: e, + _fieldAddress :: Maybe FieldAddress} + type EventHandler e = (EventNumber, e) -> Nomex () -deriving instance Show EventEnv +deriving instance Show FieldResult data Status = SActive | SDeleted deriving (Eq, Show) @@ -249,7 +293,9 @@ -- * Victory -data VictoryCond = VictoryCond RuleNumber (NomexNE [PlayerNumber]) deriving (Show, Typeable) +data VictoryInfo = VictoryInfo { _vRuleNumber :: RuleNumber, + _vCond :: NomexNE [PlayerNumber]} + deriving (Show, Typeable) partial :: String -> Nomex (Maybe a) -> Nomex a partial s nm = do @@ -261,5 +307,5 @@ concatMapM :: (Monad m) => (a -> m [b]) -> [a] -> m [b] concatMapM f xs = liftM concat (mapM f xs) -$( makeLenses [''RuleInfo, ''PlayerInfo, ''EventInfo] ) +$( makeLenses [''RuleInfo, ''PlayerInfo, ''EventInfo, ''FieldResult] ) diff --git a/src/Language/Nomyx/Inputs.hs b/src/Language/Nomyx/Inputs.hs --- a/src/Language/Nomyx/Inputs.hs +++ b/src/Language/Nomyx/Inputs.hs @@ -7,14 +7,12 @@ module Language.Nomyx.Inputs ( InputForm(..), - onInputRadio, onInputRadio_, onInputRadioOnce, + inputRadio, inputText, inputCheckbox, inputButton, inputTextarea, + onInputRadio, onInputRadio_, onInputRadioOnce, inputRadio', onInputText, onInputText_, onInputTextOnce, onInputCheckbox, onInputCheckbox_, onInputCheckboxOnce, onInputButton, onInputButton_, onInputButtonOnce, onInputTextarea, onInputTextarea_, onInputTextareaOnce, - -- Internals - baseInputRadio, baseInputText, baseInputCheckbox, baseInputButton, baseInputTextarea, - inputRadio, inputText, inputCheckbox, inputButton, inputTextarea ) where import Language.Nomyx.Expression @@ -25,6 +23,13 @@ -- * Inputs -- ** Radio inputs + +-- | event based on a radio input choice +inputRadio :: (Eq c, Show c, Typeable c) => PlayerNumber -> String -> [(c, String)] -> Event c +inputRadio pn title cs = baseEvent $ baseInputRadio pn title cs + +inputRadio' :: (Eq c, Show c, Typeable c) => PlayerNumber -> String -> [c] -> Event c +inputRadio' pn title cs = inputRadio pn title (zip cs (show <$> cs)) -- | triggers a choice input to the user. The result will be sent to the callback onInputRadio :: (Typeable a, Eq a, Show a) => String -> [a] -> (EventNumber -> a -> Nomex ()) -> PlayerNumber -> Nomex EventNumber @@ -37,17 +42,12 @@ -- | the same, suppress the event after first trigger onInputRadioOnce :: (Typeable a, Eq a, Show a) => String -> [a] -> (a -> Nomex ()) -> PlayerNumber -> Nomex EventNumber onInputRadioOnce title choices handler pn = onEventOnce (inputRadio' pn title choices) handler - -inputRadio :: (Eq c, Show c, Typeable c) => PlayerNumber -> String -> [(c, String)] -> Event c -inputRadio pn title cs = baseEvent $ baseInputRadio pn title cs - -inputRadio' :: (Eq c, Show c, Typeable c) => PlayerNumber -> String -> [c] -> Event c -inputRadio' pn title cs = inputRadio pn title (zip cs (show <$> cs)) - -baseInputRadio :: (Eq c, Show c, Typeable c) => PlayerNumber -> String -> [(c, String)] -> Field c -baseInputRadio pn title cs = baseInputEvent pn title (Radio cs) -- ** Text inputs + +-- | event based on a text input +inputText :: PlayerNumber -> String -> Event String +inputText pn title = baseEvent $ baseInputText pn title -- | triggers a string input to the user. The result will be sent to the callback onInputText :: String -> (EventNumber -> String -> Nomex ()) -> PlayerNumber -> Nomex EventNumber @@ -60,15 +60,14 @@ -- | asks the player pn to answer a question, and feed the callback with this data. onInputTextOnce :: String -> (String -> Nomex ()) -> PlayerNumber -> Nomex EventNumber onInputTextOnce title handler pn = onEventOnce (inputText pn title) handler - -inputText :: PlayerNumber -> String -> Event String -inputText pn title = baseEvent $ baseInputText pn title - -baseInputText :: PlayerNumber -> String -> Field String -baseInputText pn title = baseInputEvent pn title Text --- ** Checkbox inputs +-- ** Checkbox inputs + +-- | event based on a checkbox input +inputCheckbox :: (Eq c, Show c, Typeable c) => PlayerNumber -> String -> [(c, String)] -> Event [c] +inputCheckbox pn title cs = baseEvent $ baseInputCheckbox pn title 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, a) -> handler en a) @@ -77,14 +76,12 @@ onInputCheckboxOnce :: (Typeable a, Eq a, Show a) => String -> [(a, String)] -> ([a] -> Nomex ()) -> PlayerNumber -> Nomex EventNumber onInputCheckboxOnce title choices handler pn = onEventOnce (inputCheckbox pn title choices) handler - -inputCheckbox :: (Eq c, Show c, Typeable c) => PlayerNumber -> String -> [(c, String)] -> Event [c] -inputCheckbox pn title cs = baseEvent $ baseInputCheckbox pn title cs - -baseInputCheckbox :: (Eq c, Show c, Typeable c) => PlayerNumber -> String -> [(c, String)] -> Field [c] -baseInputCheckbox pn title cs = baseInputEvent pn title (Checkbox cs) -- ** Button inputs + +-- | event based on a button +inputButton :: PlayerNumber -> String -> Event () +inputButton pn title = baseEvent $ baseInputButton pn title onInputButton :: String -> (EventNumber -> () -> Nomex ()) -> PlayerNumber -> Nomex EventNumber onInputButton title handler pn = onEvent (inputButton pn title) (\(en, ()) -> handler en ()) @@ -95,13 +92,12 @@ onInputButtonOnce :: String -> (() -> Nomex ()) -> PlayerNumber -> Nomex EventNumber onInputButtonOnce title handler pn = onEventOnce (inputButton pn title) handler -inputButton :: PlayerNumber -> String -> Event () -inputButton pn title = baseEvent $ baseInputButton pn title - -baseInputButton :: PlayerNumber -> String -> Field () -baseInputButton pn title = baseInputEvent pn title Button -- ** Textarea inputs + +-- | event based on a text area +inputTextarea :: PlayerNumber -> String -> Event String +inputTextarea pn title = baseEvent $ baseInputTextarea pn title onInputTextarea :: String -> (EventNumber -> String -> Nomex ()) -> PlayerNumber -> Nomex EventNumber onInputTextarea title handler pn = onEvent (inputTextarea pn title) (\(en, a) -> handler en a) @@ -111,9 +107,22 @@ onInputTextareaOnce :: String -> (String -> Nomex ()) -> PlayerNumber -> Nomex EventNumber onInputTextareaOnce title handler pn = onEventOnce (inputTextarea pn title) handler - -inputTextarea :: PlayerNumber -> String -> Event String -inputTextarea pn title = baseEvent $ baseInputTextarea pn title - + + + +-- ** Internals + +baseInputRadio :: (Eq c, Show c, Typeable c) => PlayerNumber -> String -> [(c, String)] -> Field c +baseInputRadio pn title cs = baseInputEvent pn title (Radio cs) + +baseInputText :: PlayerNumber -> String -> Field String +baseInputText pn title = baseInputEvent pn title Text + +baseInputCheckbox :: (Eq c, Show c, Typeable c) => PlayerNumber -> String -> [(c, String)] -> Field [c] +baseInputCheckbox pn title cs = baseInputEvent pn title (Checkbox cs) + +baseInputButton :: PlayerNumber -> String -> Field () +baseInputButton pn title = baseInputEvent pn title Button + baseInputTextarea :: PlayerNumber -> String -> Field String baseInputTextarea pn title = baseInputEvent pn title TextArea diff --git a/src/Language/Nomyx/Outputs.hs b/src/Language/Nomyx/Outputs.hs --- a/src/Language/Nomyx/Outputs.hs +++ b/src/Language/Nomyx/Outputs.hs @@ -25,11 +25,11 @@ -- * Outputs --- | outputs a message to one player +-- | outputs a message to one player, dynamic version newOutput :: Maybe PlayerNumber -> NomexNE String -> Nomex OutputNumber newOutput = NewOutput --- | outputs a message to one player +-- | outputs a message to one player, static version newOutput_ :: Maybe PlayerNumber -> String -> Nomex OutputNumber newOutput_ ns mpn = NewOutput ns (return mpn) diff --git a/src/Language/Nomyx/Rules.hs b/src/Language/Nomyx/Rules.hs --- a/src/Language/Nomyx/Rules.hs +++ b/src/Language/Nomyx/Rules.hs @@ -16,7 +16,7 @@ getRules, getActiveRules, getRule, getRulesByNumbers, getRuleFuncs, - addRule, addRule_, addRuleParams, + addRule, addRule_, addRule', getFreeRuleNumber, suppressRule, suppressRule_, suppressAllRules, modifyRule, @@ -84,12 +84,12 @@ addRule_ :: RuleInfo -> Nomex () addRule_ r = void $ AddRule r ---TODO: too permissive. Should use SubmitRule instead. -addRuleParams :: RuleName -> Rule -> RuleCode -> String -> Nomex RuleNumber -addRuleParams name rule code desc = do +-- | add a rule to the game as described by the parameters +addRule' :: RuleName -> Rule -> RuleCode -> String -> Nomex RuleNumber +addRule' name rule code desc = do number <- liftEffect getFreeRuleNumber res <- addRule $ defaultRule {_rName = name, _rRule = rule, _rRuleCode = code, _rNumber = number, _rDescription = desc} - return $ if res then number else error "addRuleParams: cannot add rule" + return $ if res then number else error "addRule': cannot add rule" getFreeRuleNumber :: NomexNE RuleNumber @@ -98,7 +98,6 @@ getFreeNumber :: (Eq a, Num a, Enum a) => [a] -> a getFreeNumber l = head [a| a <- [1..], not $ a `elem` l] ---suppresses completly a rule and its environment from the system suppressRule :: RuleNumber -> Nomex Bool suppressRule rn = RejectRule rn 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 @@ -12,25 +12,29 @@ import Language.Nomyx.Expression import Language.Nomyx.Events import Language.Nomyx.Inputs +import Language.Nomyx.Outputs import Language.Nomyx.Players import Language.Nomyx.Rules import Control.Monad.State hiding (forM_) import Data.Maybe +import Data.Typeable import Data.Time hiding (getCurrentTime) import Control.Arrow -import Control.Applicative +import Control.Applicative +import Control.Shortcut import Data.List import qualified Data.Map as M +import Debug.Trace -- | a vote assessing function (such as unanimity, majority...) type AssessFunction = VoteStats -> Maybe Bool --- | the vote statistics, including the number of votes per choice (Nothing means abstention), --- the number of persons called to vote, and if the vote if finished (timeout or everybody voted) -data VoteStats = VoteStats { voteCounts :: M.Map (Maybe Bool) Int, +-- | the vote statistics, including the number of votes per choice, +-- the number of persons called to vote, and if the vote is finished (timeout or everybody voted) +data VoteStats = VoteStats { voteCounts :: M.Map Bool Int, nbParticipants :: Int, voteFinished :: Bool} - deriving (Show) + deriving (Show, Typeable) -- | vote at unanimity every incoming rule unanimityVote :: Nomex () @@ -45,27 +49,38 @@ callVoteRule' :: AssessFunction -> UTCTime -> RuleInfo -> Nomex () callVoteRule' assess endTime ri = do let title = "Vote for rule: \"" ++ (_rName ri) ++ "\" (#" ++ (show $ _rNumber ri) ++ "):" - callVote assess endTime title (activateOrRejectRule ri) + callVote assess endTime title (finishVote assess ri) +-- | actions to do when the vote is finished +finishVote :: AssessFunction -> RuleInfo -> [(PlayerNumber, Maybe Bool)] -> Nomex () +finishVote assess ri vs = do + let passed = fromJust $ assess $ getVoteStats (map snd vs) True + activateOrRejectRule ri passed + void $ outputAll $ showFinishedVote (_rNumber ri) passed vs + + -- | call a vote for every players, with an assessing function, a delay and a function to run on the result -callVote :: AssessFunction -> UTCTime -> String -> (Bool -> Nomex ()) -> Nomex () +callVote :: AssessFunction -> UTCTime -> String -> ([(PlayerNumber, Maybe Bool)] -> Nomex ()) -> Nomex () callVote assess endTime title payload = do - pns <- liftEffect getAllPlayerNumbers - void $ onEventOnce (voteWith endTime pns assess title) payload + en <- onEventOnce (voteWith endTime assess title) payload + displayVote en --- vote with a function able to assess the ongoing votes. --- the vote can be concluded as soon as the result is known. -voteWith :: UTCTime -> [PlayerNumber] -> AssessFunction -> String -> Event Bool -voteWith timeLimit pns assess title = shortcutEvents (voteEvents timeLimit title pns) (assess . getVoteStats (length pns)) +-- | vote with a function able to assess the ongoing votes. +-- | the vote can be concluded as soon as the result is known. +voteWith :: UTCTime -> AssessFunction -> String -> Event [(PlayerNumber, Maybe Bool)] +voteWith timeLimit assess title = do + pns <- liftNomexNE getAllPlayerNumbers + let voteEvents = map (singleVote title) pns + let timerEvent = timeEvent timeLimit + let isFinished votes timer = isJust $ assess $ getVoteStats votes timer + (vs, _)<- shortcut2b voteEvents timerEvent isFinished + return $ zip pns vs --- list of vote events -voteEvents :: UTCTime -> String -> [PlayerNumber] -> [Event (Maybe Bool)] -voteEvents time title pns = map (singleVote time title) pns --- trigger the display of a radio button choice on the player screen, yelding either Just True or Just False. +-- trigger the display of a radio button choice on the player screen, yelding either True or False. -- after the time limit, the value sent back is Nothing. -singleVote :: UTCTime -> String -> PlayerNumber -> Event (Maybe Bool) -singleVote timeLimit title pn = (Just <$> inputRadio pn title [(True, "For"), (False, "Against")]) <|> (Nothing <$ timeEvent timeLimit) +singleVote :: String -> PlayerNumber -> Event Bool +singleVote title pn = inputRadio pn title [(True, "For"), (False, "Against")] -- | assess the vote results according to a unanimity unanimity :: AssessFunction @@ -89,11 +104,11 @@ then f voteStats else if voteFinished voteStats then Just False else Nothing -getVoteStats :: Int -> [Maybe Bool] -> VoteStats -getVoteStats npPlayers votes = VoteStats - {voteCounts = M.fromList $ counts votes, - nbParticipants = npPlayers, - voteFinished = length votes == npPlayers} +getVoteStats :: [Maybe Bool] -> Bool -> VoteStats +getVoteStats votes finished = VoteStats + {voteCounts = M.fromList $ counts (catMaybes votes), + nbParticipants = length votes, + voteFinished = finished} counts :: (Eq a, Ord a) => [a] -> [(a, Int)] counts as = map (head &&& length) (group $ sort as) @@ -102,8 +117,8 @@ -- the result can be positive if the quota if reached, negative if the quota cannot be reached anymore at that point, or still pending. voteQuota :: Int -> VoteStats -> Maybe Bool voteQuota q voteStats - | M.findWithDefault 0 (Just True) vs >= q = Just True - | M.findWithDefault 0 (Just False) vs > (nbVoters voteStats) - q = Just False + | M.findWithDefault 0 True vs >= q = Just True + | M.findWithDefault 0 False vs > (nbVoters voteStats) - q = Just False | otherwise = Nothing where vs = voteCounts voteStats @@ -112,10 +127,53 @@ -- total number of people that should vote otherwise nbVoters :: VoteStats -> Int nbVoters vs - | voteFinished vs = (nbParticipants vs) - (notVoted vs) + | voteFinished vs = voted vs | otherwise = nbParticipants vs -totalVoters, voted, notVoted :: VoteStats -> Int -totalVoters vs = M.foldr (+) 0 (voteCounts vs) -notVoted vs = fromMaybe 0 $ M.lookup Nothing (voteCounts vs) -voted vs = (totalVoters vs) - (notVoted vs) +voted, notVoted :: VoteStats -> Int +notVoted vs = (nbParticipants vs) - (voted vs) +voted vs = M.findWithDefault 0 True (voteCounts vs) + M.findWithDefault 0 False (voteCounts vs) + +displayVote :: EventNumber -> Nomex () +displayVote en = void $ outputAll $ do + mds <- getIntermediateResults en + let mbs = map getBooleanResult <$> mds + pns <- getAllPlayerNumbers + case mbs of + Just bs -> showOnGoingVote $ getVotes pns bs + Nothing -> return "" + +getVotes :: [PlayerNumber] -> [(PlayerNumber, Bool)] -> [(PlayerNumber, Maybe Bool)] +getVotes pns rs = map (findVote rs) pns where + findVote :: [(PlayerNumber, Bool)] -> PlayerNumber -> (PlayerNumber, Maybe Bool) + findVote rs pn = case (find (\(pn1, _) -> pn == pn1) rs) of + Just (pn, b) -> (pn, Just b) + Nothing -> (pn, Nothing) + +getBooleanResult :: (PlayerNumber, SomeData) -> (PlayerNumber, Bool) +getBooleanResult (pn, SomeData sd) = case (cast sd) of + Just a -> (pn, a) + Nothing -> error "incorrect vote field" + + +showOnGoingVote :: [(PlayerNumber, Maybe Bool)] -> NomexNE String +showOnGoingVote [] = return "Nobody voted yet" +showOnGoingVote listVotes = do + list <- mapM showVote listVotes + return $ "Votes:" ++ "\n" ++ concatMap (\(name, vote) -> name ++ "\t" ++ vote ++ "\n") list + +showFinishedVote :: RuleNumber -> Bool -> [(PlayerNumber, Maybe Bool)] -> NomexNE String +showFinishedVote rn passed l = do + let title = "Vote finished for rule #" ++ (show rn) ++ ", passed: " ++ (show passed) + let voted = filter (\(_, r) -> isJust r) l + votes <- mapM showVote voted + return $ title ++ " (" ++ (intercalate ", " $ map (\(name, vote) -> name ++ ": " ++ vote) votes) ++ ")" + +showVote :: (PlayerNumber, Maybe Bool) -> NomexNE (String, String) +showVote (pn, v) = do + name <- showPlayer pn + return (name, showChoice v) + +showChoice :: Maybe Bool -> String +showChoice (Just a) = show a +showChoice Nothing = "Not voted"