-- Accompanying Haskell code for paper:
-- 
-- Title: Selection Equilibria of Higher-Order Games
-- Authors: Jules Hedges
--          Paulo Oliva
--          Evguenia Shprits
--          Viktor Winschel
--          Philipp Zahn
--
-- Tested on GHC 7.10
-- Submitted to PADL 2017

import Prelude hiding (max)
import Data.List (nub, maximumBy)

-- List the elements of an enum
-- We assume that x is finite, so this list is finite
elements :: (Enum x) => [x]
elements = enumFrom (toEnum 0)

-- Quantifiers and selection functions
-- The returned lists must be nonempty and finite

type Q r x = (x -> r) -> [r]
type S r x = (x -> r) -> [x]

-- Higher-order games
-- Invariant: If (n, es, q) is a game, then es has length n, and q xs is meaningful only when xs has length n.

type Game r x = (Int, [S r x], [x] -> r)

-- Enumeration of all possible strategies with n players
-- (sequence is n-fold cartesian product for the list monad)
strategies :: (Enum x) => Int -> [[x]]
strategies n = sequence (replicate n elements)

-- Examples of quantifiers and selection functions

max :: (Enum x) => (r -> r -> Ordering) -> Q r x
max order p = [maximumBy order (map p elements)]

argmax :: (Enum x, Eq r) => (r -> r -> Ordering) -> S r x
argmax order p = [x | x <- elements, p x == maximum]
  where maximum = maximumBy order (map p elements)

fix :: (Eq x, Enum x) => S x x
fix p = if null fixpoints then elements else fixpoints
  where fixpoints = [x | x <- elements, x == p x]

-- Overline operators

overlineS :: (Eq r) => S r x -> Q r x
overlineS e p = nub [p x | x <- e p]

overlineQ :: (Enum x, Eq r) => Q r x -> S r x
overlineQ phi p = [x | x <- elements, p x `elem` phi p]

-- Unilateral maps

unilateral :: Int -> ([x] -> r) -> [x] -> x -> r
unilateral i q xs x' = q [xs' j | j <- [0 .. n-1]]
  where xs' j | (j == i)    = x'
              | (otherwise) = xs!!j
        n = length xs

-- Testing deviation of individual players

deviatesQ :: (Eq r) => Game r x -> [x] -> Int -> Bool
deviatesQ (_, es, q) xs i = not (q xs `elem` overlineS (es!!i) (unilateral i q xs))

deviatesS :: (Eq x) => Game r x -> [x] -> Int -> Bool
deviatesS (_, es, q) xs i = not (xs!!i `elem` (es!!i) (unilateral i q xs))

-- Equilibrium testing
-- Return either Right () indicating equilibrium, or a nonempty list of players who prefer to deviate

equilibriumQ :: (Eq r) => Game r x -> [x] -> Either [Int] ()
equilibriumQ g@(n, _, _) xs = if null deviates then Right () else Left deviates
  where deviates = [i | i <- [0 .. n-1], deviatesQ g xs i]

equilibriumS :: (Eq x) => Game r x -> [x] -> Either [Int] ()
equilibriumS g@(n, _, _) xs = if null deviates then Right () else Left deviates
  where deviates = [i | i <- [0 .. n-1], deviatesS g xs i]

-- The voting game

data X = A | B deriving (Eq, Ord, Enum, Show)

maj :: [X] -> X
maj [A,A,_] = A
maj [A,_,A] = A
maj [_,A,A] = A
maj [_,_,_] = B

-- Orderings with A > B, B > A respectively
order1, order2 :: X -> X -> Ordering
order1 = flip compare
order2 = compare

-- Two examples from selection 3.1
game1, game2 :: Game X X
game1 = (3, [argmax order1, argmax order1, argmax order2], maj)
game2 = (3, [argmax order1, fix, fix], maj)

-- Coordination game
game3 :: Game X X
game3 = (3, [fix, fix, fix], maj)

{-
Example usage, to verify tables from the paper:

1. Calculating deviating players in game1 with respect
   to quantifier equilibrium, for each of the 9 possible strategies
   Rigth () indicates an equilibrium, i.e. no players wish to deviate
   We can see that there are three equilibrium strategies, namely
   [A,A,A], [A,A,B] and [B,B,B]

*Games Games> mapM_ print $ (zip ((strategies 3) :: [[X]]) $ map (equilibriumQ game1) (strategies 3))
([A,A,A],Right ())
([A,A,B],Right ())
([A,B,A],Left [2])
([A,B,B],Left [1])
([B,A,A],Left [2])
([B,A,B],Left [0])
([B,B,A],Left [0,1])
([B,B,B],Right ())

2. Calculating deviating player in game2 with respect
   to selection equilibrium. In this case there are four
   equilibrium strategy profiles.

*Games Games> mapM_ print $ (zip ((strategies 3) :: [[X]]) $ map (equilibriumS game2) (strategies 3))
([A,A,A],Right ())
([A,A,B],Left [2])
([A,B,A],Left [1])
([A,B,B],Right ())
([B,A,A],Right ())
([B,A,B],Left [0,1])
([B,B,A],Left [0,2])
([B,B,B],Right ())

3. In the full coordination game3 one can see that there are only 
   two selection equilibrium, but all 9 strategies are in quantifier
   equilibrium.

*Games Games> mapM_ print $ (zip ((strategies 3) :: [[X]]) $ map (equilibriumS game3) (strategies 3))
([A,A,A],Right ())
([A,A,B],Left [2])
([A,B,A],Left [1])
([A,B,B],Left [0])
([B,A,A],Left [0])
([B,A,B],Left [1])
([B,B,A],Left [2])
([B,B,B],Right ())

*Games Games> mapM_ print $ (zip ((strategies 3) :: [[X]]) $ map (equilibriumQ game3) (strategies 3))
([A,A,A],Right ())
([A,A,B],Right ())
([A,B,A],Right ())
([A,B,B],Right ())
([B,A,A],Right ())
([B,A,B],Right ())
([B,B,A],Right ())
([B,B,B],Right ())

-}