{-
This is the implementation accompanying the paper 'Backward induction for repeated games' by Jules Hedges
That paper should be considered the documentation of this code
Copyright 2018 Jules Hedges
MIT license: https://opensource.org/licenses/MIT
I am releasing this as a single file because I haven't been able to make Stack initialise a new project for at least several weeks.
I can compile it with GHC 8.0.1 and Stack 1.0.4 with no dependencies.
-}
{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}
module RepeatedGames where
import Data.Functor.Identity
import Data.List
-- T-algebras
class Algebra t a where
structure :: t a -> a
instance Algebra Identity a where
structure = runIdentity
instance (Functor t, Algebra t a, Algebra t b) => Algebra t (a, b) where
structure x = (structure (fmap fst x), structure (fmap snd x))
-- Selection functions
newtype SelT r t x = SelT {runSelT :: (x -> r) -> t x}
instance (Functor t) => Functor (SelT r t) where
fmap f (SelT e) = SelT (\k -> fmap f (e (k . f)))
reindex :: (s -> r) -> SelT r t x -> SelT s t x
reindex f (SelT e) = SelT (\k -> e (f . k))
instance (Monad t, Algebra t r) => Monad (SelT r t) where
return = SelT . const . return
SelT e >>= f = SelT (\k -> let g x = runSelT (f x) k
h x = structure (fmap k (g x))
in e h >>= g)
instance (Monad t, Algebra t r) => Applicative (SelT r t) where
pure = return
e <*> d = do {f <- e; x <- d; return (f x)}
-- Finite sets
class (Eq a) => Finite a where
exhaust :: [a]
instance (Finite a, Finite b) => Finite (a, b) where
exhaust = [(x, y) | x <- exhaust, y <- exhaust]
argmax :: (Finite x, Ord r) => SelT r [] x
argmax = SelT (\k -> [x | x <- exhaust, all (\x' -> k x >= k x') exhaust])
-- Monoidal product of a monad
otimes :: (Monad t) => t a -> t b -> t (a, b)
otimes e d = do {x <- e; y <- d; return (x, y)}
-- The sum of selection functions
oplus :: (Finite x, Finite y) => SelT r [] x -> SelT r [] y -> SelT r [] (x, y)
oplus (SelT e) (SelT d) = SelT (\k -> [(x, y) | (x, y) <- exhaust,
x `elem` e (\x' -> k (x', y)),
y `elem` d (\y' -> k (x, y'))])
-- Computable reals
data Quit = Zero | One | Two | Three deriving (Show, Eq, Ord)
quit2Double :: Quit -> Double
quit2Double x = case x of {Zero -> 0.0; One -> 1.0; Two -> 2.0; Three -> 3.0}
type R = [Quit]
precision :: Int
precision = 4
real2Double :: R -> Double
real2Double xs = sum (zipWith f xs [1 .. precision])
where f x n = quit2Double x * 0.25^n
greater :: R -> R -> Bool
greater xs ys = real2Double xs > real2Double ys - 0.25^(precision - 1)
eargmax :: (Finite a) => SelT R [] a
eargmax = SelT (\k -> [x | x <- exhaust, all (\x' -> k x `greater` k x') exhaust])
-- Prisoner's dilemma
data Move = C | D deriving (Show, Eq)
instance Finite Move where
exhaust = [C, D]
pd :: (Move, Move) -> (Quit, Quit)
pd (C, C) = (Two, Two)
pd (C, D) = (Zero, Three)
pd (D, C) = (Three, Zero)
pd (D, D) = (One, One)
-- Searchable sets
type Searchable = SelT Bool Identity
searchable :: ((x -> Bool) -> x) -> Searchable x
searchable e = SelT (Identity . e)
search :: Searchable x -> (x -> Bool) -> x
search (SelT e) = runIdentity . e
searchList :: [x] -> Searchable x
searchList [] = error "searchList: Empty list"
searchList xs = searchable (\p -> case find p xs of Nothing -> head xs
Just x -> x)
promote :: SelT r [] x -> SelT r Searchable x
promote (SelT e) = SelT (searchList . e)
exists :: Searchable x -> (x -> Bool) -> Bool
exists e p = p (search e p)
forall :: Searchable x -> (x -> Bool) -> Bool
forall e p = not (exists e (not . p))
instance Algebra Searchable R where
structure e = search e (\x -> forall e (\y -> x `greater` y))
-- Iterated prisoner's dilemma
ipd :: [(Move, Move)] -> (R, R)
ipd xs = (map (fst . pd) xs, map (snd . pd) xs)
stage :: SelT (R, R) [] (Move, Move)
stage = reindex fst eargmax `oplus` reindex snd eargmax
plays :: Searchable [(Move, Move)]
plays = runSelT (sequence (repeat (promote stage))) ipd