module Language.Nomyx.Examples(
nothing,
helloWorld,
accounts,
createBankAccount,
winXEcuPerDay,
winXEcuOnRuleAccepted,
moneyTransfer,
delRule,
voteWithMajority,
king,
makeKing,
monarchy,
revolution,
displayCurrentTime,
displayActivateTime,
iWin,
returnToDemocracy,
victoryXRules,
victoryXEcu,
noGroupVictory,
banPlayer,
gameMaster,
bravoButton,
enterHaiku,
displayBankAccount,
helloButton,
module X) where
import Data.Function
import Data.Time.Clock as X hiding (getCurrentTime)
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 Safe (readDef)
import Language.Nomyx
nothing :: Rule
nothing = return ()
helloWorld :: Rule
helloWorld = outputAll_ "hello, world!"
accounts :: MsgVar [(PlayerNumber, Int)]
accounts = msgVar "Accounts"
createBankAccount :: Rule
createBankAccount = void $ createValueForEachPlayer_ accounts
displayBankAccount :: Rule
displayBankAccount = do
let displayOneAccount (account_pn, a) = do
name <- showPlayer account_pn
return $ name ++ "\t" ++ show a ++ "\n"
let displayAccounts l = do
d <- concatMapM displayOneAccount l
return $ "Accounts:\n" ++ d
void $ displayVar' Nothing accounts displayAccounts
winXEcuPerDay :: Int -> Rule
winXEcuPerDay x = schedule_ (recur daily) $ modifyAllValues accounts (+x)
winXEcuOnRuleAccepted :: Int -> Rule
winXEcuOnRuleAccepted x = void $ onEvent_ (ruleEvent Activated) $ \rule -> void $ modifyValueOfPlayer (_rProposedBy rule) accounts (+x)
moneyTransfer :: Rule
moneyTransfer = do
let askAmount :: PlayerNumber -> Event (PlayerNumber, Int)
askAmount src = do
pls <- liftEvent 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))
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) ++ " ecu(s) to player " ++ show dst)
void $ newOutput_ (Just dst) ("Player " ++ show src ++ " gave you " ++ (show amount) ++ " ecu(s)")
else void $ newOutput_ (Just src) ("Insufficient balance or wrong amount")
delRule :: RuleNumber -> Rule
delRule rn = suppressRule_ rn >> autoDelete
makeKing :: PlayerNumber -> Rule
makeKing pn = do
newMsgVar_ "King" pn
void $ modifyPlayerName pn ("King " ++)
king :: MsgVar PlayerNumber
king = msgVar "King"
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 :: PlayerNumber -> Rule
revolution pn = do
suppressRule 1
rNum <- addRule' "Monarchy" (monarchy pn) ("monarchy " ++ (show pn)) "Monarchy: only the king can vote on new rules"
activateRule_ rNum
autoDelete
victoryXRules :: Int -> Rule
victoryXRules x = setVictory $ do
rs <- getRules
let counts :: [(PlayerNumber,Int)]
counts = map (_rProposedBy . head &&& length) $ groupBy ((==) `on` _rProposedBy) rs
let victorious = map fst $ filter ((>= x) . snd) counts
return victorious
victoryXEcu :: Int -> Rule
victoryXEcu x = setVictory $ do
as <- readMsgVar accounts
let victorious as = map fst $ filter ((>= x) . snd) as
return $ maybe [] victorious as
displayCurrentTime :: Rule
displayCurrentTime = void $ outputAll $ do
t <- getCurrentTime
return $ "The current time is: " ++ (show t)
displayActivateTime :: Nomex ()
displayActivateTime = do
time <- liftEffect getCurrentTime
outputAll_ $ "This rule was activated at: " ++ (show time)
noGroupVictory :: Rule
noGroupVictory = do
let testVictory (VictoryInfo _ cond) = do
vics <- liftEffect cond
when (length vics >1) $ setVictory (return [])
void $ onEvent_ victoryEvent testVictory
iWin :: Rule
iWin = liftEffect getProposerNumber >>= giveVictory
voteWithMajority :: Rule
voteWithMajority = onRuleProposed $ callVoteRule (majority `withQuorum` 2) oneDay
returnToDemocracy :: [RuleNumber] -> Rule
returnToDemocracy rs = do
mapM_ suppressRule rs
rNum <- addRule' "vote with majority" voteWithMajority "voteWithMajority" "majority with a quorum of 2"
activateRule_ rNum
autoDelete
banPlayer :: PlayerNumber -> Rule
banPlayer pn = do
delPlayer pn
void $ onEvent_ (playerEvent Arrive) $ const $ void $ delPlayer pn
bravoButton :: Rule
bravoButton = void $ onInputButton_ "Click here:" (const $ outputAll_ "Bravo!") 1
helloButton :: Rule
helloButton = do
me <- getProposerNumber_
let displayMsg a = void $ newOutput_ Nothing ("Msg: " ++ a)
let button = do
all <- liftEvent getPlayers
guard (length all >= 2) >> inputText me "send a message"
void $ onEvent_ button displayMsg
enterHaiku :: Rule
enterHaiku = void $ onInputTextarea_ "Enter a haiku:" outputAll_ 1
makeGM :: PlayerNumber -> Nomex ()
makeGM pn = do
newMsgVar "GameMaster" pn
void $ modifyPlayerName pn ("GameMaster " ++)
gameMaster :: MsgVar PlayerNumber
gameMaster = msgVar "GameMaster"
tournamentMasterCandidates :: Rule
tournamentMasterCandidates = do
let tournamentMasterCandidates = msgVar "tournamentMasterCandidates" :: MsgVar [PlayerNumber]
let candidate pn = void $ modifyMsgVar tournamentMasterCandidates (pn : )
let displayCandidates pns = return $ "Candidates for the election of Tournament Master: Players #" ++ intercalate ", " (map show pns)
newMsgVar_ (getMsgVarName tournamentMasterCandidates) ([] :: [PlayerNumber])
forEachPlayer_ (\pn -> void $ onInputButtonOnce "I am candidate for the next Tournament Master elections " (const $ candidate pn) pn)
void $ displayVar' Nothing tournamentMasterCandidates displayCandidates
data Castle = Castle { towers :: Int, dungeon :: Bool }
deriving (Typeable, Show, Eq)
castles :: MsgVar [(PlayerNumber, Castle)]
castles = msgVar "Castles"