Iterated Prisoner Dilemma Haskell implementation

Question

A collegue and me implemented a simulator the iterated prisoner dilemma from game theory in haskell. We would appreciate any feedback on the quality of the code, how things could be worked out more efficiantly or elegantly.

The code file together with a tex file (along with the compiled PDF) in literate haskell style that explains the problem and all of the code can be found on GitHub.

I have included the code itself here too:

{-# LANGUAGE FlexibleInstances #-}
module Main where
import System.Random
import Data.List (nubBy, sortBy, intercalate) 
import Data.Bifunctor (bimap)
import Data.Function (on)
main :: IO ()
main = do
 result <- startSimulation 100 3 100
 print $ show $ stats $ snd result
data Choice = Cooperate | Defect
 deriving (Eq, Show)
type BattleResult = (Choice, Choice)
-------------------------- TYPES -------------------------- 
type PlayerID = Int
type Payment = Int
type PlayerHist = [((Choice, Payment), (PlayerID, Choice))]
data Player = Player 
 { name :: String -- strategy name 
 , playerID :: PlayerID
 , decide :: PlayerHist -> Choice 
 , getPlayerHist :: PlayerHist
 }
instance Show Player where
 show (Player n p _ o) = 
 "Player { name: '" ++ n ++ "'" ++ 
 ", playerID: " ++ (show p) ++ 
 ", getPlayerHist: " ++ (show o) ++ "'}"
instance Eq Player where
 (Player n _ _ _) == (Player n' _ _ _) = n == n'
instance Eq (Int -> Player) where
 p1 == p2 = (p1 0) == (p2 0)
instance Show (Int -> Player) where
 show p = show $ p 0
type Population = [Player]
type RandList = [Int]
type IterationResult = [Player]
-------------------------- DEFINITIONS --------------------------
payment :: BattleResult -> (Int, Int)
payment (Cooperate, Cooperate) = (3,3)
payment (Cooperate, Defect) = (1,4)
payment (Defect, Cooperate) = (4,1)
payment (Defect, Defect) = (2,2)
defector :: Int -> Player
defector n = Player 
 "Defector" 
 n
 (\_ -> Defect)
 []
cooperator :: Int -> Player
cooperator n = Player
 "Cooperator"
 n
 (\_ -> Cooperate)
 []
tftDecide :: PlayerHist -> Choice
tftDecide [] = Cooperate
tftDecide ((_,(_,c)):_) = c
tft :: Int -> Player
tft n = Player
 "TFT"
 n
 tftDecide
 []
rageDecide :: PlayerHist -> Choice
rageDecide [] = Cooperate
rageDecide l = if (elem Defect . map getOpChoice $ l) then Defect else Cooperate 
 where getOpChoice = snd . snd 
rage :: Int -> Player
rage n = Player
 "Yasha"
 n
 rageDecide
 []
playerTypes :: [Int -> Player]
playerTypes = [defector, cooperator, tft, rage]
generatePopulation :: [(Int->Player, Int)] -> Population
generatePopulation = map (\(i,p) -> p i) . 
 zip [1..] . 
 intercalate [] . 
 map (\(p,n) -> replicate n p) 
-------------------------- GAME LOGIC --------------------------
-- shuffled population iteration count
runIteration :: Population -> Int -> IterationResult 
runIteration p i = undoPairs $ play i (makePairs p)
-- counter shuffled list of battles 
play :: Int -> [(Player, Player)] -> [(Player, Player)]
play 0 h = h
play i p 
 | i < 0 = p
 | otherwise = play (i-1) $ newPlayers decisions
 where 
 dec p = decide p $ getPlayerHist p
 decisions = zip p $ map (bimap dec dec) p :: [((Player, Player), BattleResult)]
 newPlayers = 
 map (\((p1,p2),cs@(c1,c2)) -> 
 let (a1, a2) = payment cs
 in 
 (p1{getPlayerHist = ((c1, a1),(playerID p2, c2)):(getPlayerHist p1)}
 ,p2{getPlayerHist = ((c2, a2),(playerID p1, c1)):(getPlayerHist p2)}))
-- tournaments maxIterations initial Population for shuffling stats for tournaments with updated histories
runGame :: Int -> Int -> ([[(Int->Player, Int)]], Population) -> RandList -> ([[(Int->Player, Int)]], Population)
runGame _ maxIter res [] = res
runGame 0 maxIter res _ = res
runGame i maxIter res@(hist,ps) rs@(h:t) 
 | i < 0 = res
 | otherwise = runGame (i-1) maxIter (iterStats:hist, newPopulation) $
 drop (length iteration) t
 where 
 getPayments = map (snd . fst) . getPlayerHist :: Player -> [Payment]
 iteration = runIteration (shuffle rs ps) maxIter :: Population
 iterStats = map (\p -> (p, sum . 
 map (sum . getPayments) . 
 filter (==(p 0)) $ iteration)
 ) playerTypes :: [(Int->Player, Payment)]
 payments = sum . map snd $ iterStats :: Int
 newPopulationStats = map (\(p, s) -> (p, calcCount s payments (length ps))) iterStats :: [(Int->Player, Payment)]
 newPopulation = generatePopulation newPopulationStats :: [Player]
startSimulation :: Int -> Int -> Int -> IO ([[(Int->Player, Int)]], Population) 
startSimulation genSize tournaments iterations = do
 g <- getStdGen
 let gen = generatePopulation $ map (\p-> (p, genSize `div` (length playerTypes))) playerTypes
 randList = randoms g
 putStrLn "Simulating Iterated prisoner"
 putStrLn $ "Population " ++ show (stats gen) 
 return $ runGame tournaments iterations ([], gen) randList 
-------------------------- AUXILIARY --------------------------
shuffle :: RandList -> [a] -> [a] 
shuffle rands xs = let 
 ys = take (length xs) rands
 in
 map fst $ sortBy (compare `on` snd) (zip xs ys)
makePairs :: [a] -> [(a,a)]
makePairs [] = []
makePairs [_] = []
makePairs (h:h':t) = (h,h'):(makePairs t)
undoPairs :: [(a,a)] -> [a]
undoPairs [] = []
undoPairs ((a,b):t) = [a,b]++(undoPairs t)
stats :: Population -> [(String, Int)]
stats l = map (\p -> (name p, length $ filter (\e->name e == name p) l)) $
 nubBy (\p1 p2 -> name p1 == name p2) l
-- tries to preserve the calculated amount for each player as close as possible
-- player payout overall payout population size
calcCount :: Int -> Int -> Int -> Int
calcCount _ 0 _ = 0
calcCount _ _ 0 = 0
calcCount a g p = let a' = fromIntegral a
 g' = fromIntegral g
 p' = fromIntegral p
 in round $ a'/g'*p' 

Answer 1

Design

Overall I think you did a good job of separating concerns and keeping functions independent.
One issue I had is that there are too many tuples instead of record types, so sometimes it's not obvious what you're dealing with, for example in getPayments = map (snd . fst) . getPlayerHist, it would be nice if instead of snd . fst it were getPayment . getFirstTuple. To do this you could replace:

type PlayerHist = [((Choice, Payment), (PlayerID, Choice))]

with

data FirstTuple = FirstTuple
 { getChoice :: Choice
 , getPayment :: Payment
 }
data SecondTuple = SecondTuple
 { getOpponentID :: PlayerID
 , getOpponentChoice :: Choice
 }
data GameResult = GameResult
 { getFirstTuple :: FirstTuple
 , getSecondTuple :: SecondTuple
 }
type PlayerHist = [GameResult]

and ideally with more descriptive names than mine if possible.
If dealing with the nested types gets too complicated you can look at using lens for simplifying this.

---

In a couple of places you use [(Int->Player, Int)] to represent a list of players, where the second tuple item is the count of each player and the first item takes an ID and returns a player. I think you can just as easily use [Player] as your representation, and make the caller responsible for calling generatePopulation first.
This would simplify some type signitures and make it easier to read, especially because it isn't immediately clear what [(Int->Player, Int)] is.

Simplification

In your generatePopulation function, you use intercalate [] . map on a list, which is equivalent to concatMap, which should be a bit simpler to understand. Notice that the types below are equivalent:

Prelude Data.List> :t \f -> intercalate [] . map f
\f -> intercalate [] . map f :: (a1 -> [a2]) -> [a1] -> [a2]
Prelude Data.List> :t \f -> concatMap f
\f -> concatMap f :: Foldable t => (a -> [b]) -> t a -> [b]

In the same function, you also use map followed by zip, with is the same thing as zipWith.

Here's what I came up with for that:

generatePopulation :: [(Int->Player, Int)] -> Population
generatePopulation = zipWith (flip ($)) [1..] .
 concatMap (\(f, count) -> replicate count f)

---

In shuffle , you could replace ys = take (length xs) rands with ys = zipWith const rands xs. This should do the same thing in 1 traversal instead of 2.
const is defined as const a b = a, so when you zip the two together you'll only take elements from the first list, rands. zip stops when the shorter list is exhausted so the length you'll be left with is length xs.
You can see some similar examples of this here.

• Fabian Schneider: using records sounds like a good idea; i have (heard of but) never worked with lenses before; so i will definitely take a look at it now that there might be a good example for that :)
• Fabian Schneider: would it be considered bad design if i newtyped Int->Player (i kind of want to distinguish between the statistics list and the population; even though one could count on the user to call generatePopulation first
• Fabian Schneider: thanks for concatMap and showing the use of const both are awsome in that place
• Steven Fontanella: You could newtype it and it might help if you can give it a meaningful name (playerWithId?). But I think it would reduce cognitive load if you can instead deal with Players as much as possible. In my eyes [Player] is much clearer than [(Int -> Player, Int)], so you can use the latter when you're generating it but I would opt to convert that to [Player] as soon as you can and pass that around to functions instead.