diff --git a/AUTHORS b/AUTHORS new file mode 100644 --- /dev/null +++ b/AUTHORS @@ -0,0 +1,1 @@ +Corentin Dupont diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright 2012, Corentin Dupont. All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +3. Neither the name of the author nor the names of its contributors may be + used to endorse or promote products derived from this software without + specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,39 @@ + +Introduction +============ + +Nomyx is a game where you can change the rules: http://www.nomyx.net + +This package defines a set of rule examples to be played in Nomyx, that you can modify. +Just fork this package to create your own rule and play them in Nomyx! +To push your rules to Nomyx, use [nomyx-client](https://github.com/cdupont/nomyx-client). + + +Usage +===== + +Fork this package: +``` +git clone git@github.com:cdupont/nomyx-library.git +``` + +Get Haskell Stack: +``` +curl -sSL https://get.haskellstack.org/ | sh +``` + +You can now compile it: +``` +cd nomyx-library +stack install +``` + +Feel free to modify existing rules, or create new ones! +The rule list is in [templates.yaml](src/templates.yaml). + +Once done, you can push your rules to Nomyx with [nomyx-client](https://github.com/cdupont/nomyx-client). + +Contact +======= + +Bug-reports, questions, suggestions and patches are all welcome. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,6 @@ +#!/usr/bin/runhaskell +> module Main where +> import Distribution.Simple +> main :: IO () +> main = defaultMain + diff --git a/nomyx-library.cabal b/nomyx-library.cabal new file mode 100644 --- /dev/null +++ b/nomyx-library.cabal @@ -0,0 +1,56 @@ +name: nomyx-library +version: 1.0.0 +cabal-version: >=1.8 +build-type: Simple +license: BSD3 +license-file: LICENSE +copyright: 2012 Corentin Dupont +maintainer: Corentin Dupont +stability: Experimental +synopsis: Library of rules for Nomyx +description: Many example of rules ready to be played +category: Language +Homepage: http://www.nomyx.net +author: Corentin Dupont +--data-files: static/pictures/*.png +data-files: Nomyx/Library/Examples.hs + Nomyx/Library/Democracy.hs + Nomyx/Library/Monarchy.hs + Nomyx/Library/PlayerManagement.hs + Nomyx/Library/Victory.hs + Nomyx/Library/Vote.hs + Nomyx/Library/Elections.hs + Nomyx/Library/Bank.hs + templates.yaml +data-dir: src +extra-source-files: AUTHORS README.md + +library + build-depends: nomyx-language == 1.0.*, + base >= 4.6 && < 5, + containers == 0.5.*, + ghc >= 7.6 && < 8.1, + lens >= 4.7 && < 4.15, + mtl >= 2.1 && < 2.3, + old-locale == 1.0.*, + safe == 0.3.*, + shortcut == 0.1.*, + time >= 1.4 && < 1.7, + time-recurrence == 0.9.* + exposed-modules: Nomyx.Library.Examples + Nomyx.Library.Democracy + Nomyx.Library.Monarchy + Nomyx.Library.PlayerManagement + Nomyx.Library.Victory + Nomyx.Library.Vote + Nomyx.Library.Elections + Nomyx.Library.Bank + Paths_nomyx_library + exposed: True + buildable: True + hs-source-dirs: src + ghc-options: -W + +source-repository head + type: git + location: https://github.com/cdupont/Nomyx.git diff --git a/src/Nomyx/Library/Bank.hs b/src/Nomyx/Library/Bank.hs new file mode 100644 --- /dev/null +++ b/src/Nomyx/Library/Bank.hs @@ -0,0 +1,104 @@ + {-# LANGUAGE DoAndIfThenElse #-} + +-- | This file gives a list of example rules that the players can submit. +module Nomyx.Library.Bank where + +import Prelude +import Data.Time.Recurrence as X hiding (filter) +import Data.List as X +import Data.Maybe +import Control.Monad as X +import Safe (readDef) +import Nomyx.Language + + +-- | account variable name and type +accounts :: V [(PlayerNumber, Int)] +accounts = V "Accounts" + +-- | Create a bank account for each players +createBankAccounts :: Rule +createBankAccounts = void $ createValueForEachPlayer_ accounts + +-- | Declare an API to deposit money for a player +-- The return value shows if the transaction was successful. +depositAPI :: APICall (PlayerNumber, Int) Bool +depositAPI = APICall "deposit" + +-- | Declare an API to withdraw money for a player. +-- The return value shows if the transaction was successful. +withdrawAPI :: APICall (PlayerNumber, Int) Bool +withdrawAPI = APICall "withdraw" + +-- | Declare an API to get the balance of a player. +balanceAPI :: APICall PlayerNumber (Maybe Int) +balanceAPI = APICall "getBalance" + +bankServices :: Nomex () +bankServices = do + void $ onAPICall depositAPI deposit + void $ onAPICall withdrawAPI withdraw + void $ onAPICall balanceAPI getBalance + +deposit :: (PlayerNumber, Int) -> Nomex Bool +deposit (pn, amount) = do + if amount > 0 then modifyValueOfPlayer pn accounts (+ amount) + else return False + +withdraw :: (PlayerNumber, Int) -> Nomex Bool +withdraw (pn, amount) = do + balance <- getValueOfPlayer pn accounts + if (amount > 0 && fromJust balance >= amount) then modifyValueOfPlayer pn accounts (\a -> a - amount) + else return False + +getBalance :: PlayerNumber -> Nomex (Maybe Int) +getBalance pn = getValueOfPlayer pn accounts + +-- | Permanently display the bank accounts +displayBankAccounts :: Rule +displayBankAccounts = 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 + +-- | each player wins X Ecu each day +-- you can also try with "minutly" or "monthly" instead of "daily" and everything in the "time-recurrence" package +winXEcuPerDay :: Int -> Rule +winXEcuPerDay x = schedule_ (recur daily) $ modifyAllValues accounts (+x) + +-- | a player wins X Ecu if a rule proposed is accepted +winXEcuOnRuleAccepted :: Int -> Rule +winXEcuOnRuleAccepted x = void $ onEvent_ (ruleEvent Activated) $ \rule -> void $ modifyValueOfPlayer (_rProposedBy rule) accounts (+x) + +-- | a player can transfer money to another player +moneyTransfer :: Rule +moneyTransfer = do + let askAmount :: PlayerNumber -> Event (PlayerNumber, Int) + askAmount src = do + pls <- liftEvent getAllPlayerNumbers + guard (length pls >= 2) >> do + let pnames = map (\a -> (a, show a)) (delete src $ sort pls) + dst <- inputRadio src "Transfer money to player: " pnames + 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 + withdrawOK <- callAPIBlocking withdrawAPI (src, amount) + if withdrawOK then do + depositOK <- callAPIBlocking depositAPI (dst, amount) + if depositOK then do + void $ newOutput_ (Just src) ("You transfered " ++ (show amount) ++ " ecu(s) to player " ++ (show dst)) + void $ newOutput_ (Just dst) ("You received " ++ (show amount) ++ " ecu(s) from player " ++ (show src)) + else do + --If transaction failed, deposit back the money + callAPIBlocking depositAPI (src, amount) + void $ newOutput_ (Just src) ("Transaction failed") + else do + void $ newOutput_ (Just src) ("Insufficient balance or wrong amount") diff --git a/src/Nomyx/Library/Democracy.hs b/src/Nomyx/Library/Democracy.hs new file mode 100644 --- /dev/null +++ b/src/Nomyx/Library/Democracy.hs @@ -0,0 +1,24 @@ + +-- | This file gives a list of example rules that the players can submit. +module Nomyx.Library.Democracy where + +import Prelude +import Nomyx.Language +import Nomyx.Library.Vote + + +-- | a majority vote, with the folowing parameters: +-- a quorum of 2 voters is necessary for the validity of the vote +-- the vote is assessed after every vote in case the winner is already known +-- the vote will finish anyway after one day +voteWithMajority :: Rule +voteWithMajority = onRuleProposed $ callVoteRule (majority `withQuorum` 2) oneDay + +-- | Change current system (the rules passed in parameter) to absolute majority (half participants plus one) +democracy :: [RuleNumber] -> Rule +democracy rs = do + mapM_ suppressRule rs + rNum <- addRule' "vote with majority" voteWithMajority "voteWithMajority" "majority with a quorum of 2" + activateRule_ rNum + autoDelete + diff --git a/src/Nomyx/Library/Elections.hs b/src/Nomyx/Library/Elections.hs new file mode 100644 --- /dev/null +++ b/src/Nomyx/Library/Elections.hs @@ -0,0 +1,18 @@ + +-- | This file gives a list of example rules that the players can submit. +module Nomyx.Library.Elections where + +import Data.List +import Control.Monad +import Nomyx.Language + + +tournamentMasterCandidates :: Rule +tournamentMasterCandidates = do + let tournamentMasterCandidates = V "tournamentMasterCandidates" :: V [PlayerNumber] + let candidate pn = void $ modifyVar tournamentMasterCandidates (pn : ) + let displayCandidates pns = return $ "Candidates for the election of Tournament Master: Players #" ++ intercalate ", " (map show pns) + newVar_ (varName tournamentMasterCandidates) ([] :: [PlayerNumber]) + forEachPlayer_ (\pn -> void $ onInputButtonOnce "I am candidate for the next Tournament Master elections " (const $ candidate pn) pn) + void $ displayVar' Nothing tournamentMasterCandidates displayCandidates + diff --git a/src/Nomyx/Library/Examples.hs b/src/Nomyx/Library/Examples.hs new file mode 100644 --- /dev/null +++ b/src/Nomyx/Library/Examples.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DoAndIfThenElse #-} + +-- | This file gives a list of example rules that the players can submit. +module Nomyx.Library.Examples where + +import Prelude +import Control.Monad as X +import Nomyx.Language +import qualified Data.Time as DT +import Control.Applicative + +-- | A rule that does nothing +nothing :: Rule +nothing = return () + +-- | A rule that says hello to all players +helloWorld :: Rule +helloWorld = outputAll_ "hello, world!" + +-- | delete a rule +delRule :: RuleNumber -> Rule +delRule rn = suppressRule_ rn >> autoDelete + +-- | will display the current time (when refreshing the screen) +displayCurrentTime :: Rule +displayCurrentTime = void $ outputAll $ do + t <- getCurrentTime + return $ "The current time is: " ++ (show t) + +-- | will display the time at which the rule as been activated +displayActivateTime :: Nomex () +displayActivateTime = do + t <- getCurrentTime + outputAll_ $ "This rule was activated at: " ++ (show t) + +-- | 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 <- 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 + +testTime :: Rule +testTime = do + t <- getCurrentTime + void $ onEvent_ (True <$ inputButton 1 "click here before 5 seconds:" <|> False <$ (timeEvent $ DT.addUTCTime 5 t)) f where + f a = outputAll_ $ show a diff --git a/src/Nomyx/Library/Monarchy.hs b/src/Nomyx/Library/Monarchy.hs new file mode 100644 --- /dev/null +++ b/src/Nomyx/Library/Monarchy.hs @@ -0,0 +1,35 @@ + +-- | This file gives a list of example rules that the players can submit. +module Nomyx.Library.Monarchy where + +import Control.Monad +import Nomyx.Language + +-- | Variable holding the player number of the King +king :: V PlayerNumber +king = V "King" + +-- | player pn is the king: we create a variable King to identify him, +-- and we prefix his name with "King" +makeKing :: PlayerNumber -> Rule +makeKing pn = do + newVar_ "King" pn + void $ modifyPlayerName pn ("King " ++) + +-- | Monarchy: only the king decides which rules to accept or reject +monarchy :: PlayerNumber -> Rule +monarchy pn = do + makeKing pn + void $ onEvent_ (ruleEvent Proposed) $ \rule -> do + k <- readVar_ king + void $ onInputRadioOnce ("Your Royal Highness, do you accept rule " ++ (show $ _rNumber rule) ++ "?") [(True, "Yes"), (False, "No")] (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 pn = do + suppressRule 1 + rNum <- addRule' "Monarchy" (monarchy pn) ("monarchy " ++ (show pn)) "Monarchy: only the king can vote on new rules" + activateRule_ rNum + autoDelete + diff --git a/src/Nomyx/Library/PlayerManagement.hs b/src/Nomyx/Library/PlayerManagement.hs new file mode 100644 --- /dev/null +++ b/src/Nomyx/Library/PlayerManagement.hs @@ -0,0 +1,13 @@ + +-- | This file gives a list of example rules that the players can submit. +module Nomyx.Library.PlayerManagement where + +import Control.Monad +import Nomyx.Language + +-- | kick a player and prevent him from returning +banPlayer :: PlayerNumber -> Rule +banPlayer pn = do + delPlayer pn + void $ onEvent_ (playerEvent Arrive) $ const $ void $ delPlayer pn--- | kick a player and prevent him from returning + diff --git a/src/Nomyx/Library/Victory.hs b/src/Nomyx/Library/Victory.hs new file mode 100644 --- /dev/null +++ b/src/Nomyx/Library/Victory.hs @@ -0,0 +1,48 @@ +{-# 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. +--You can copy either the name of the function (i.e. "helloWorld") or its body (i.e. "outputAll_ "hello, world!""), but NOT both. +--Don't hesitate to get inspiration from there and create your own rules! +module Nomyx.Library.Victory where + +import Data.Function +import Data.List +import Control.Arrow +import Control.Monad +import Nomyx.Language +import Nomyx.Library.Bank + + +-- | set the victory for players having more than X accepted rules +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 <- readVar accounts + let victorious as = map fst $ filter ((>= x) . snd) as + return $ maybe [] victorious as + +-- | 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 :: Rule +noGroupVictory = do + let testVictory (VictoryInfo _ cond) = do + vics <- 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 +iWin = getProposerNumber >>= giveVictory + + diff --git a/src/Nomyx/Library/Vote.hs b/src/Nomyx/Library/Vote.hs new file mode 100644 --- /dev/null +++ b/src/Nomyx/Library/Vote.hs @@ -0,0 +1,207 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Voting system +module Nomyx.Library.Vote where + +import Control.Applicative +import Control.Arrow +import Control.Monad.State hiding (forM_) +import Control.Shortcut +import Data.List +import qualified Data.Map as M +import Data.Maybe +import Data.Time hiding (getCurrentTime) +import Data.Typeable +import Nomyx.Language +import Prelude hiding (foldr) + +-- | a vote assessing function (such as unanimity, majority...) +type AssessFunction = VoteStats -> Maybe Bool + +-- | 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, Typeable) + +-- | information broadcasted when a vote begins +data VoteBegin = VoteBegin { vbRule :: RuleInfo, + vbEndAt :: UTCTime, + vbEventNumber :: EventNumber } + deriving (Show, Eq, Ord, Typeable) + +-- | information broadcasted when a vote ends +data VoteEnd = VoteEnd { veRule :: RuleInfo, + veVotes :: [(PlayerNumber, Maybe Bool)], + vePassed :: Bool, + veFinishedAt :: UTCTime} + deriving (Show, Eq, Ord, Typeable) + +voteBegin :: Msg VoteBegin +voteBegin = Signal "VoteBegin" + +voteEnd :: Msg VoteEnd +voteEnd = Signal "VoteEnd" + +-- | vote at unanimity every incoming rule +unanimityVote :: Nomex () +unanimityVote = do + onRuleProposed $ callVoteRule unanimity oneDay + displayVotes + +-- | call a vote on a rule for every players, with an assessing function and a delay +callVoteRule :: AssessFunction -> NominalDiffTime -> RuleInfo -> Nomex () +callVoteRule assess delay ri = do + endTime <- addUTCTime delay <$> getCurrentTime + callVoteRule' assess endTime ri + +callVoteRule' :: AssessFunction -> UTCTime -> RuleInfo -> Nomex () +callVoteRule' assess endTime ri = do + en <- callVote assess endTime (_rName $ _rRuleTemplate ri) (_rNumber ri) (finishVote assess ri) + sendMessage voteBegin (VoteBegin ri endTime en) + +-- | 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 + end <- getCurrentTime + sendMessage voteEnd (VoteEnd ri vs passed end) + +-- | call a vote for every players, with an assessing function, a delay and a function to run on the result +callVote :: AssessFunction -> UTCTime -> String -> RuleNumber -> ([(PlayerNumber, Maybe Bool)] -> Nomex ()) -> Nomex EventNumber +callVote assess endTime name rn payload = do + let title = "Vote for rule: \"" ++ name ++ "\" (#" ++ (show rn) ++ "):" + onEventOnce (voteWith endTime assess title) payload + + +-- | 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 <- liftEvent 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 + +-- | display the votes (ongoing and finished) +displayVotes :: Nomex () +displayVotes = do + void $ onMessage voteEnd displayFinishedVote + void $ onMessage voteBegin displayOnGoingVote + +-- 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 :: String -> PlayerNumber -> Event Bool +singleVote title pn = inputRadio pn title [(True, "For"), (False, "Against")] + +-- | assess the vote results according to a unanimity +unanimity :: AssessFunction +unanimity voteStats = voteQuota (nbVoters voteStats) voteStats + +-- | assess the vote results according to an absolute majority (half voters plus one) +majority :: AssessFunction +majority voteStats = voteQuota ((nbVoters voteStats) `div` 2 + 1) voteStats + +-- | assess the vote results according to a majority of x (in %) +majorityWith :: Int -> AssessFunction +majorityWith x voteStats = voteQuota ((nbVoters voteStats) * x `div` 100 + 1) voteStats + +-- | assess the vote results according to a fixed number of positive votes +numberVotes :: Int -> AssessFunction +numberVotes x voteStats = voteQuota x voteStats + +-- | adds a quorum to an assessing function +withQuorum :: AssessFunction -> Int -> AssessFunction +withQuorum f minNbVotes = \voteStats -> if (voted voteStats) >= minNbVotes + then f voteStats + else if voteFinished voteStats then Just False else Nothing + +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) + +-- | Compute a result based on a quota of positive votes. +-- 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 True vs >= q = Just True + | M.findWithDefault 0 False vs > (nbVoters voteStats) - q = Just False + | otherwise = Nothing + where vs = voteCounts voteStats + + +-- | number of people that voted if the voting is finished, +-- total number of people that should vote otherwise +nbVoters :: VoteStats -> Int +nbVoters vs + | voteFinished vs = voted vs + | otherwise = nbParticipants 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) + +-- | display an on going vote +displayOnGoingVote :: VoteBegin -> Nomex () +displayOnGoingVote (VoteBegin ri endTime en) = void $ outputAll $ do + mds <- getIntermediateResults en + let mbs = map getBooleanResult <$> mds + pns <- getAllPlayerNumbers + case mbs of + Just bs -> showOnGoingVote (getVotes pns bs) (_rNumber ri) endTime + 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)] -> RuleNumber -> UTCTime -> Nomex String +showOnGoingVote [] rn _ = return $ "Nobody voted yet for rule #" ++ (show rn) ++ "." +showOnGoingVote listVotes rn endTime = do + list <- mapM showVote listVotes + let timeString = formatTime defaultTimeLocale "on %d/%m at %H:%M UTC" endTime + return $ "Votes for rule #" ++ (show rn) ++ ", finishing " ++ timeString ++ "\n" ++ + concatMap (\(name, vote) -> name ++ "\t" ++ vote ++ "\n") list + +-- | display a finished vote +displayFinishedVote :: VoteEnd -> Nomex () +displayFinishedVote (VoteEnd ri vs passed end) = void $ outputAll $ showFinishedVote (_rNumber ri) passed vs end + +showFinishedVote :: RuleNumber -> Bool -> [(PlayerNumber, Maybe Bool)] -> UTCTime -> Nomex 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) -> Nomex (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" diff --git a/src/templates.yaml b/src/templates.yaml new file mode 100644 --- /dev/null +++ b/src/templates.yaml @@ -0,0 +1,225 @@ + +# Democracy + +- name: Majority vote + author: Kau + desc: "A majority vote is cast for new rules. Vote will pass with more than 50% of \"yes\", + with minimum 2 voters to be valid, + finishing after maximum one day." + rule: onRuleProposed $ callVoteRule (majority `withQuorum` 2) oneDay + category: [Democracy] + decls: + - Nomyx/Library/Vote.hs + - Nomyx/Library/Democracy.hs + picture: null + +- name: Unanimity vote + author: Kau + desc: "A unanimity vote: all players need to vote \"yes\" for a new rule to be accepted." + rule: onRuleProposed $ callVoteRule unanimity oneDay + category: [Democracy] + decls: + - Nomyx/Library/Vote.hs + - Nomyx/Library/Democracy.hs + picture: null + +# Monarchy + +- name: make King + author: Kau + desc: "Make a player King (change the 1 with the player number that becomes King)" + rule: makeKing 1 + category: [Monarchy] + decls: + - Nomyx/Library/Monarchy.hs + picture: null + +- name: Monarchy + author: Kau + desc: "Monarchy: only the king decides which rules to accept or reject (change the 1 with the player number)" + rule: monarchy 1 + category: [Monarchy] + decls: + - Nomyx/Library/Monarchy.hs + picture: null + +- name: revolution + author: Kau + desc: "Revolution! Hail to the king! + This rule suppresses the democracy (usually rules 1 or 2), installs the king and activates monarchy. + (change the 1 with the player number that you want for King)" + rule: revolution 1 + category: [Monarchy] + decls: + - Nomyx/Library/Monarchy.hs + picture: null + + +# Victories + +- name: 5 rules victory + author: Kau + desc: "You win if you have 5 rules accepted." + rule: victoryXRules 5 + category: [Victory] + decls: + - Nomyx/Library/Victory.hs + picture: null + +- name: 100 ECU wins + author: Kau + desc: "You win if you have 1000 ECU on your bank account." + rule: victoryXEcu 1000 + category: [Victory] + decls: + - Nomyx/Library/Victory.hs + picture: null + +- name: I win + author: Kau + desc: "You win. That's it, if this rule is accepted you win the game. + Good luck on having this accepted by other players ;)" + rule: iWin + category: [Victory] + decls: + - Nomyx/Library/Victory.hs + picture: null + +- name: No group victory + author: Kau + desc: "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." + rule: noGroupVictory + category: [Victory] + decls: + - Nomyx/Library/Victory.hs + picture: null + +# Bank accounts + +- name: Bank accounts + author: Kau + desc: Create a bank account for each players + rule: createBankAccounts + category: [Bank] + decls: [Nomyx/Library/Bank.hs] + picture: null + +- name: Bank services + author: Kau + desc: Activate bank services + rule: bankServices + category: [Bank] + decls: [Nomyx/Library/Bank.hs] + picture: null + +- name: Display accounts + author: Kau + desc: Display all bank accounts + rule: displayBankAccounts + category: [Bank] + decls: [Nomyx/Library/Bank.hs] + picture: null + +- name: Daily salaries + author: Kau + desc: each player wins 10 Ecu each days + rule: winXEcuPerDay 10 + category: [Bank] + decls: [Nomyx/Library/Bank.hs] + picture: null + +- name: Bonus rule accepted + author: Kau + desc: a player wins 100 Ecu if a rule proposed is accepted + rule: winXEcuOnRuleAccepted 100 + category: [Bank] + decls: [Nomyx/Library/Bank.hs] + picture: null + +- name: Money transfer + author: Kau + desc: a player can transfer money to another player + rule: moneyTransfer + category: [Bank] + decls: [Nomyx/Library/Bank.hs] + picture: null + +# Players + +- name: Ban player + author: Kau + desc: "Kick a player and prevent him from returning." + rule: banPlayer X + category: [Players] + decls: + - Nomyx/Library/PlayerManagement.hs + picture: null + +# Examples + +- name: Nothing + author: Kau + desc: A rule that does nothing + rule: return () + category: [Examples] + decls: [Nomyx/Library/Examples.hs] + picture: null + +- name: Hello World + author: Kau + desc: A rule that says hello to all players + rule: outputAll_ "hello, world!" + category: [Examples] + decls: [Nomyx/Library/Examples.hs] + picture: null + +- name: Display current time + author: Kau + desc: Will display the current time (when refreshing the screen) + rule: displayCurrentTime + category: [Examples] + decls: [Nomyx/Library/Examples.hs] + picture: null + +- name: Display activation time + author: Kau + desc: will display the time at which the rule as been activate + rule: displayActivateTime + category: [Examples] + decls: [Nomyx/Library/Examples.hs] + picture: null + +- name: Delete rule + author: Kau + desc: Delete rule number one and then deletes itself + rule: suppressRule_ 1 >> autoDelete + category: [Examples] + decls: [Nomyx/Library/Examples.hs] + picture: null + +- name: Bravo button + author: Kau + desc: display a button and greets you when pressed (for player 1) + rule: void $ onInputButton_ "Click here:" (const $ outputAll_ "Bravo!") 1 + category: [Examples] + decls: [Nomyx/Library/Examples.hs] + picture: null + +- name: Hello button + author: Kau + desc: display a button to greet other players + rule: helloButton + category: [Examples] + decls: [Nomyx/Library/Examples.hs] + picture: null + +- name: Enter Haiku + author: Kau + desc: display a field where you can enter a poem + rule: void $ onInputTextarea_ "Enter a haiku:" outputAll_ 1 + category: [Examples] + decls: [Nomyx/Library/Examples.hs] + picture: null +