Nomyx-Language 0.6.2 → 0.7.0

raw patch · 9 files changed

+345/−130 lines, 9 filesdep ~basedep ~ghcPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base, ghc

API changes (from Hackage documentation)

Files

• Nomyx-Language.cabal +5/−4
• src/Control/Shortcut.hs +43/−0
• src/Language/Nomyx/Events.hs +30/−9
• src/Language/Nomyx/Examples.hs +65/−27
• src/Language/Nomyx/Expression.hs +62/−16
• src/Language/Nomyx/Inputs.hs +44/−35
• src/Language/Nomyx/Outputs.hs +2/−2
• src/Language/Nomyx/Rules.hs +5/−6
• src/Language/Nomyx/Vote.hs +89/−31

@@ -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 

@@ -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

@@ -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

@@ -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

@@ -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] )
 

@@ -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

@@ -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) 

@@ -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 

@@ -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"