Interactive replicator dynamics

Definitions

Here are 2 functions whose sole purpose is to make the differential equations in the definition of ReplicatorDynamics easier to read.

Fitness[i_,s_?VectorQ,pm_,corr_]:=Sum[
If[i==j,
pm[[i,j]]*(s[[j]]+corr*(1.0-s[[j]])),
pm[[i,j]]*(s[[j]]-corr*s[[j]])
],
{j,1,Length[s]}
];
PopulationFitness[s_,pm_,corr_]:=(∑_(j=1)^(Length[s]))s[[j]]*Fitness[j,s,pm,corr];

Protect[ReplicatorDynamics,Generations,Correlation]

Unprotect[ReplicatorDynamics]

Options[ReplicatorDynamics]={
Generations->30,
Correlation->0.0
};

ToListOfPoints[f_,stepsize_]:=Module[{m},
m=f[[1,1,2]];
Return[
Table[f[t],{t,0,m,stepsize}]
]
]

GenerateEquations[pm_,ic_,corr_]:=Module[{n,l},
n=Length[pm];
Return[
Join[
Map[
(Subscript[x, #])'[t]==(Subscript[x, #])[t]*(Fitness[#,Map[(Subscript[x, #])[t]&,Range[n]],pm,corr]-PopulationFitness[Map[(Subscript[x, #])[t]&,Range[n]],pm,corr])&,
Range[n]
],
Map[
(Subscript[x, #])[0]==ic[[#]]&,
Range[n]
]
]
]
]

ContinuousReplicatorDynamics[pm_,ic_,opts___]:=Module[{gens,corr,eqs},
gens=Generations/.{opts}/.Options[ReplicatorDynamics];
corr=Correlation/.{opts}/.Options[ReplicatorDynamics];
eqs=GenerateEquations[pm,ic,corr];
Return[
NDSolve[
eqs,Map[(Subscript[x, #])&,Range[Length[pm]]],{t,0,gens}
]
]
]

ExtractSolution[{{(Subscript[x, 1])->f1_,(Subscript[x, 2])->f2_,(Subscript[x, 3])->f3_}}]:={f1,f2,f3}

intersectionPoint[{{x1_,y1_},{x2_,y2_}},{{x3_,y3_},{x4_,y4_}}]:={x,y}/.Solve[{
Det[{{x,y,1},{x1,y1,1},{x2,y2,1}}]==0,
Det[{{x,y,1},{x3,y3,1},{x4,y4,1}}]==0},
{x,y}]//First

toSimplexPt[{x_,y_,z_}]:={((x Sin[(π/6)]+y)/(Tan[(π/3)]))+x Cos[(π/6)],y}

toInitialCondition[pt_]:=Module[{a={0,0},b={(1/(Sqrt[3])),1},c={(2/(Sqrt[3])),0},pA,pB,pC},
pA=intersectionPoint[{pt,pt+{Cos[(π/6)],Sin[(π/6)]}},{b,c}];
pB=intersectionPoint[{pt,pt+{0,-1}},{a,c}];
pC=intersectionPoint[{pt,pt+{Cos[((5π)/6)],Sin[((5π)/6)]}},{a,b}];
{Norm[pt-pA],Norm[pt-pB],Norm[pt-pC]}
];

generateTrajectory[pt_]:=Module[{initialConditions,solutions,pointList},
initialConditions=toInitialCondition[pt];
solutions=ExtractSolution[
ContinuousReplicatorDynamics[payoffMatrix,initialConditions,Correlation->correlation]
];
pointList=MapThread[List,
{
ToListOfPoints[solutions[[3]],stepSize],
ToListOfPoints[solutions[[2]],stepSize],
ToListOfPoints[solutions[[1]],stepSize]
}
];
Return[
{
Arrowheads[{0,.02,0}],
Arrow[toSimplexPt/@pointList]
}
]
];

onClick[pt_]:=Module[
{a={0,0},b={(1/(Sqrt[3])),1},c={(2/(Sqrt[3])),0},pA,pB,pC,initialConditions,solutions,pointList},
pA=intersectionPoint[{pt,pt+{Cos[(π/6)],Sin[(π/6)]}},{b,c}];
pB=intersectionPoint[{pt,pt+{0,-1}},{a,c}];
pC=intersectionPoint[{pt,pt+{Cos[((5π)/6)],Sin[((5π)/6)]}},{a,b}];
initialConditions={Norm[pt-pA],Norm[pt-pB],Norm[pt-pC]};
solutions=ExtractSolution[
ContinuousReplicatorDynamics[payoffMatrix,initialConditions,Correlation->correlation]
];
pointList=MapThread[List,
{
ToListOfPoints[solutions[[3]],stepSize],
ToListOfPoints[solutions[[2]],stepSize],
ToListOfPoints[solutions[[1]],stepSize]
}
];
Return[
{
Arrowheads[{0,.02,0}],
Arrow[toSimplexPt/@pointList]
}
]
];

validatePoint[{x_,y_}]:=If[ArcTan[x,y]≤(π/3)&&y≤-(Sqrt[3])x+2,True,False]

payoffMatrix=(({{4, 4, 4}, {5, 5, 0}, {6, 0, 0}}));
stepSize=0.01;

saveGraphicFile[]:=
Module[{filename},
filename=SystemDialogInput["FileSave"];
If[filename≠$Canceled,
Export[filename,
Graphics[
{LightGray,EdgeForm[Thickness[0.003]],Polygon[{a,b,c}],Black,
linesToDraw,{PointSize[0.015],Black,pointsToDraw,PointSize[0.01],White,pointsToDraw},
Text[Style[s1,Medium],a,{-1,1.3}],
Text[Style[s2,Medium],b,{0,-1}],
Text[Style[s3,Medium],c,{1,1.3}]
},ImageSize->450,AspectRatio->Automatic]
]
]
]

Code for the interactive panel

Panel[
Row[{
Column[{
ClickPane[
Dynamic[
Graphics[
{LightGray,EdgeForm[Thickness[0.003]],Polygon[{a,b,c}],Black,
linesToDraw,{PointSize[0.015],Black,pointsToDraw,PointSize[0.01],White,pointsToDraw},
Text[Style[s1,Medium],a,{-1,1.3}],
Text[Style[s2,Medium],b,{0,-1}],
Text[Style[s3,Medium],c,{1,1.3}]
},ImageSize->450,AspectRatio->Automatic],
Initialization:>{a={0,0};b={(1/(Sqrt[3])),1};c={(2/(Sqrt[3])),0};s1="s1";s2="s2";s3="s3";linesToDraw={};pointsToDraw={};payoffMatrix=(({{4, 4, 4}, {5, 5, 0}, {6, 0, 0}}))}
],
(pt=#;
If[validatePoint[pt]==True,
AppendTo[pointsToDraw,Point[pt]];
AppendTo[linesToDraw,onClick[pt]]
];
)&]
}],
Column[{
Row[{
Panel[
Column[
{
Row[{Text[Style["Label 1: ", Medium]],
InputField[Dynamic[s1],String,FieldSize->{10,1.25}]}],
Row[{Text[Style["Label 2: ", Medium]],
InputField[Dynamic[s2],String,FieldSize->{10,1.25}]}],
Row[{Text[Style["Label 3: ", Medium]],
InputField[Dynamic[s3],String,FieldSize->{10,1.25}]}]
}
],"Strategy labels"
],
Panel[
Grid[
{
{Null,Text[Dynamic[s1]],Text[Dynamic[s2]],Text[Dynamic[s3]]},
{
Text[Dynamic[s1]],
InputField[Dynamic[payoffMatrix[[1,1]]],FieldSize->{4,1.25}],
InputField[Dynamic[payoffMatrix[[1,2]]],FieldSize->{4,1.25}],
InputField[Dynamic[payoffMatrix[[1,3]]],FieldSize->{4,1.25}]},
{
Text[Dynamic[s2]],
InputField[Dynamic[payoffMatrix[[2,1]]],FieldSize->{4,1.25}],
InputField[Dynamic[payoffMatrix[[2,2]]],FieldSize->{4,1.25}],
InputField[Dynamic[payoffMatrix[[2,3]]],FieldSize->{4,1.25}]},
{
Text[Dynamic[s3]],
InputField[Dynamic[payoffMatrix[[3,1]]],FieldSize->{4,1.25}],
InputField[Dynamic[payoffMatrix[[3,2]]],FieldSize->{4,1.25}],
InputField[Dynamic[payoffMatrix[[3,3]]],FieldSize->{4,1.25}]}
}
],"Payoff Matrix (for row)"
]
}],
Row[
{Text[Style["Correlation:", Medium]],
Slider[Dynamic[correlation,{(correlation=#)&,(linesToDraw=Apply[generateTrajectory,pointsToDraw,1])&}]],
Dynamic[PaddedForm[correlation,{3,3}]]
},"    "],
Button["Clear simplex",(linesToDraw={};pointsToDraw={})&],
Button["Export graphic",saveGraphicFile[]]
},Center,3]
}],Style["Simplex Diagram for the Replicator Dynamics",Medium]
]

Code for exporting a PDF

Export["~/tmp/foo.pdf",
Graphics[
{LightGray,EdgeForm[Thickness[0.003]],Polygon[{a,b,c}],Black,
linesToDraw,{PointSize[0.015],Black,pointsToDraw,PointSize[0.01],White,pointsToDraw},
Text[Style[s1,Medium],a,{-1,1.3}],
Text[Style[s2,Medium],b,{0,-1}],
Text[Style[s3,Medium],c,{1,1.3}]
},ImageSize->450,AspectRatio->Automatic]
]