{-# 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,
                             vbPlayers     :: [PlayerNumber]}
                             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)
   pns <- getAllPlayerNumbers
   sendMessage voteBegin (VoteBegin ri endTime en pns)

-- | 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
   onEventOnce (voteWith endTime assess name rn) 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 -> RuleNumber-> Event [(PlayerNumber, Maybe Bool)]
voteWith timeLimit assess name rn = do
   pns <- liftEvent getAllPlayerNumbers
   let voteEvents = map (singleVote name rn) 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 -> RuleNumber -> PlayerNumber -> Event Bool
singleVote name rn pn = inputRadio pn title [(True, "For"), (False, "Against")] where
   title = "Vote for rule: \"" ++ name ++ "\" (#" ++ (show rn) ++ "):"

-- | 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 (RuleInfo rn _ _ _ _ _ (RuleTemplate name _ _ _ _ _ _)) endTime en pns) = void $ outputAll $ do
   isa <- isEventActive en
   if isa
     then do
        ers <- mapM (\pn -> getEventResult en (singleVote name rn pn)) pns
        showOnGoingVote (zip pns ers) rn endTime
     else return ""

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

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

{-# 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


 {-# 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")
-- | 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

{-# 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