4
\$\begingroup\$

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' 
\$\endgroup\$
3
\$\begingroup\$

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.

| improve this answer | |
\$\endgroup\$
  • \$\begingroup\$ 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 :) \$\endgroup\$ – Fabian Schneider Dec 15 '19 at 17:30
  • 1
    \$\begingroup\$ 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 \$\endgroup\$ – Fabian Schneider Dec 15 '19 at 17:31
  • \$\begingroup\$ thanks for concatMap and showing the use of const both are awsome in that place; \$\endgroup\$ – Fabian Schneider Dec 15 '19 at 17:31
  • 1
    \$\begingroup\$ 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. \$\endgroup\$ – Steven Fontanella Dec 15 '19 at 19:21

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.