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