The Evolutionary Foundation of Probability Weighting and Hyperbolic Discounting

And Their Intimate Connection

Laurens Bogaardt - 29-05-2012
Master’s Thesis in Economics at Lunds Universitet

Introduction

This notebook is used to do the calculation for my Master’s Thesis in Economics at Lunds Universitet, 2012. It examines the cause of hyperbolic discounting by taking the position that the hyperbolic discount function is a version of an exponential function on which probability weighting is applied. As such, this notebook first explores the evolutionary foundation of Prospect Theory probability weighting. Some of the functions used in this notebook were based on a previous notebook by Elliott Wagner, who wrote the paper ‘The Dynamics of Costly Signaling’.

Initiation

This section defines all the functions of this notebook. In particular, it starts with the objective functions and moves on to the subjective functions afterwards. In short, there is a function to solve for the position of the mixed equilibrium. There is a function which sets up the replicator equation. This can be used to make a vector plot or stream plot. There is also a function which creates the borders of the phase space. There is also a function for the labels and one to show the equilibria of the model, both as points and in terms of there utility value. Finally, these things are put together in a plot, where lines and arrows show the dynamics of the phase space.

Initiation Objective

mySolveMixedA:=Solve[(myB.{α,1-α})[[1]]==(myB.{α,1-α})[[2]],α]
mySolveMixedB:=Solve[(myA.{β,1-β})[[1]]==(myA.{β,1-β})[[2]],β]

myFitnessA[α_,β_]:=Sum[{α,1-α}[[i]]{β,1-β}[[j]]myA[[i,j]],{i,1,2},{j,1,2}]
myFitnessB[α_,β_]:=Sum[{α,1-α}[[i]]{β,1-β}[[j]]Transpose[myB][[i,j]],{i,1,2},{j,1,2}]

myReplicatorX:=α(myFitnessA[1,β]-myFitnessA[α,β])
myReplicatorY:=β(myFitnessB[α,1]-myFitnessB[α,β])

myBorders2={{u,0},{0,u},{1,u},{u,1}};
myBorders=ParametricPlot[myBorders2,{u,0,1},Frame->False,PlotStyle->Directive[Black,Thick],Axes->None,PlotRange->{{-.1,1.1},{-.1,1.1}},ImageSize->{Automatic,500},Background->White];

myLabels:=Graphics[{Text[Style["A2",18],{.5,-.06}],Text[Style["A1",18],{.5,1.06}],Text[Style["B2",18],{1.08,.5}],Text[Style["B1",18],{-.13,.5}]}]

myEquilibria:=Solve[myReplicatorX==myReplicatorY==0]

myEquilibriaList:={{1-β,α}/.Cases[myEquilibria,{_,_}]}[[1]]

myPoints:=Graphics[{PointSize[.065],Gray,Point[myEquilibriaList]}]

myFitnessA2[n_]:=N[{myEquilibriaList[[n,2]],1-myEquilibriaList[[n,2]]}.myA.{1-myEquilibriaList[[n,1]],myEquilibriaList[[n,1]]}]
myFitnessB2[n_]:=N[{myEquilibriaList[[n,2]],1-myEquilibriaList[[n,2]]}.Transpose[myB].{1-myEquilibriaList[[n,1]],myEquilibriaList[[n,1]]}]

myFitnessList:=Table[{myFitnessA2[n],myFitnessB2[n]},{n,1,Length[myEquilibriaList]}]

myFitnessPoints:=Graphics[Table[Text[Style[myFitnessList[[n]],10],myEquilibriaList[[n]]],{n,1,Length[myEquilibriaList]}]]

myPlot:=Show[myBorders,myLabels,myPoints,myFitnessPoints,VectorPlot[{-myReplicatorY/.{α->y,β->1-x},myReplicatorX/.{α->y,β->1-x}}//Flatten,{x,0,1},{y,0,1},VectorStyle->Black]]

Initiation Subjective - Probability Weighting

myWeighted[p_,γ_]:=p^(γ)/(p^(γ)+(1-p)^(γ))^(1/γ)
myWeighted2[p_,γ_,λ_,ν_,μ_]:=p^(γ)/(p^(λ)+(1-p)^(ν))^(1/μ)

myProspectSolveMixedA[γ_]:=Solve[(myB.myWeighted[{α,1-α},γ])[[1]]==(myB.myWeighted[{α,1-α},γ])[[2]],α]
myProspectSolveMixedB[γ_]:=Solve[(myA.myWeighted[{β,1-β},γ])[[1]]==(myA.myWeighted[{β,1-β},γ])[[2]],β]

myUtilityA[α_,β_,γ_]:=Sum[{α,1-α}[[i]]myWeighted[{β,1-β},γ][[j]]myA[[i,j]],{i,1,2},{j,1,2}]
myUtilityB[α_,β_,γ_]:=Sum[myWeighted[{α,1-α},γ][[i]]{β,1-β}[[j]]Transpose[myB][[i,j]],{i,1,2},{j,1,2}]

myProspectReplicatorX[γ_]:=α(myUtilityA[1,β,γ]-myUtilityA[α,β,γ])
myProspectReplicatorY[γ_]:=β(myUtilityB[α,1,γ]-myUtilityB[α,β,γ])

myProspectEquilibria[γ_,δ_]:=Solve[myProspectReplicatorX[γ]==myProspectReplicatorY[δ]==0]

myProspectEquilibriaList[γ_,δ_]:={{1-β,α}/.Cases[myProspectEquilibria[γ,δ],{_,_}]}[[1]]

myProspectPoints[γ_,δ_]:=Graphics[{PointSize[.065],Gray,Point[myProspectEquilibriaList[γ,δ]]}]

myProspectFitnessA2[n_,γ_,δ_]:=N[{myProspectEquilibriaList[γ,δ][[n,2]],1-myProspectEquilibriaList[γ,δ][[n,2]]}.myA.{1-myProspectEquilibriaList[γ,δ][[n,1]],myProspectEquilibriaList[γ,δ][[n,1]]}]
myProspectFitnessB2[n_,γ_,δ_]:=N[{myProspectEquilibriaList[γ,δ][[n,2]],1-myProspectEquilibriaList[γ,δ][[n,2]]}.Transpose[myB].{1-myProspectEquilibriaList[γ,δ][[n,1]],myProspectEquilibriaList[γ,δ][[n,1]]}]

myProspectFitnessList[γ_,δ_]:=Table[{myProspectFitnessA2[n,γ,δ],myProspectFitnessB2[n,γ,δ]},{n,1,Length[myProspectEquilibriaList[γ,δ]]}]

myProspectFitnessPoints[γ_,δ_]:=Graphics[Table[Text[Style[myProspectFitnessList[γ,δ][[n]],10],myProspectEquilibriaList[γ,δ][[n]]],{n,1,Length[myProspectEquilibriaList[γ,δ]]}]]

myProspectPlot[γ_,δ_]:=Show[myBorders,myLabels,myProspectPoints[γ,δ],myProspectFitnessPoints[γ,δ],VectorPlot[{-myProspectReplicatorY[δ]/.{α->y,β->1-x},myProspectReplicatorX[γ]/.{α->y,β->1-x}}//Flatten,{x,0,1},{y,0,1},VectorStyle->Black,Background->White]]

Initiation Subjective - Probability Weighting - Combination

myFitnessFromGame1[γ_]:=Simplify[1/2 myFitnessA[α/.myProspectSolveMixedA[γ],β/.myProspectSolveMixedB[γ]][[1]]+1/2 myFitnessB[α/.myProspectSolveMixedA[γ],β/.myProspectSolveMixedB[γ]][[1]]]

myWeightedSeries[p_,γ_,s_]:=Normal[Series[myWeighted[r,g],{r,1/2,s}]]/.{r->p,g->γ}

myWeightedSeries2[p_,γ_,λ_,μ_,s_]:=Normal[Series[myWeighted2[r,g,l,l,m],{r,1/2,s}]]/.{r->p,g->γ,l->λ,m->μ}

myDensity[p_]:=1

myFitnessFromGame2[γ_,s_]:=Integrate[myDensity[p](3-3(p-Simplify[myWeightedSeries[p,γ,s]])^2),{p,0,1}]

myFitness2FromGame2[γ_,λ_,μ_,s_]:=Integrate[myDensity[p](3-3(p-Simplify[myWeightedSeries2[p,γ,λ,μ,s]])^2),{p,0,1}]

myFitnessTotal[γ_,s_,q_]:=q myFitnessFromGame1[γ]+(1-q) myFitnessFromGame2[γ,s]

myFitnessTotal2[γ_,λ_,μ_,s_,q_]:=q myFitnessFromGame1[γ]+(1-q) myFitness2FromGame2[γ,λ,μ,s]

myEvaluate[γ_,λ_,μ_,s_,q_]:={myEvaluatedFitnessFromGame1=myFitnessFromGame1[γ];myFitnessEvaluatedFromGame2=myFitnessFromGame2[γ,s];myEvaluatedFitness2FromGame2=myFitness2FromGame2[γ,λ,μ,s];myEvaluatedFitnessTotal=myFitnessTotal[γ,s,q];myEvaluatedFitnessTotal2=myFitnessTotal2[γ,λ,μ,s,q];}

myFindMaximum:={FindMaximum[myEvaluatedFitnessTotal,{γ,1/2}],FindMaximum[myEvaluatedFitnessTotal2,{{γ,1/2},{λ,1/2},{μ,1/2}}]}

myPlotFitness[l_,m_]:=MatrixForm[{Show[Plot[{myEvaluatedFitnessFromGame1,myFitnessEvaluatedFromGame2,myEvaluatedFitnessTotal},{γ,0.004,1},PlotRange->{2,25/8},PlotStyle->Black,AxesLabel->{γ,f},ImageSize->400,Background->White],Graphics[{{PointSize[.02],Gray,Point[{(γ/.myFindMaximum[[1,2]]),myFindMaximum[[1,1]]}]},Text[Style[{(γ/.myFindMaximum[[1,2]]),myFindMaximum[[1,1]]},10],{(γ/.myFindMaximum[[1,2]]),1/10+myFindMaximum[[1,1]]}]}]],Plot[{myEvaluatedFitnessFromGame1,myEvaluatedFitness2FromGame2/.{λ->l,μ->m},myEvaluatedFitnessTotal2/.{λ->l,μ->m}},{γ,0.004,1},PlotRange->{2,25/8},PlotStyle->Black,AxesLabel->{γ,f},ImageSize->400,Background->White]}]

Probability Weighting

In this part, we start by replicating the model by Rieger. We, then, combine this game with a ‘rational’ game, to find a quantative solution for the level of probability weighting.

Replication

myA={{4,-2},{3,0}};
myB=Transpose[{{2,3},{2,0}}];

MatrixForm[myA]
MatrixForm[Transpose[myB]]

mySolveMixedA
mySolveMixedB
myProspectSolveMixedA[1/2]
myProspectSolveMixedB[1]

myEquilibriaList
myFitnessList
myProspectEquilibriaList[1/2,1]
myProspectFitnessList[1/2,1]

myPlot
myProspectPlot[1/2,1]

Extension

myA={{4,-2},{3,0}};
myB=Transpose[{{2,3},{2,0}}];

myProspectSolveMixedA[γ]
myProspectSolveMixedB[γ]
myFitnessA[α/.myProspectSolveMixedA[γ],β/.myProspectSolveMixedB[γ]][[1]]//Simplify
myFitnessB[α/.myProspectSolveMixedA[γ],β/.myProspectSolveMixedB[γ]][[1]]//Simplify

myEvaluate[γ,λ,μ,5,1/2];

myFindMaximum

myPlotFitness[γ,γ]

Hyperbolic Discounting

In this part, we reinterpret the game by Rieger and the combination from abovee, to one of future discounting. Following a direct interpretation, we find a hyperbolic discount function. However, this interpretation seems not to be valid, so we also try an indirect interpretation.

Direct

myA={{4,-2},{3,0}};
myB=Transpose[{{2,3},{2,0}}];

MatrixForm[myA]
MatrixForm[Transpose[myB]]

mySolveMixedA
mySolveMixedB
myProspectSolveMixedA[1/2]
myProspectSolveMixedB[1]

myEquilibriaList
myFitnessList
myProspectEquilibriaList[1/2,1]
myProspectFitnessList[1/2,1]

Show[ParametricPlot[myBorders2,{u,0,1},Frame->False,PlotStyle->Directive[Black,Thick],Axes->None,PlotRange->{{-.2,1.1},{-.1,1.2}},ImageSize->{Automatic,500},Background->White],myPoints,myFitnessPoints,VectorPlot[{-myReplicatorY/.{α->y,β->1-x},myReplicatorX/.{α->y,β->1-x}}//Flatten,{x,0,1},{y,0,1},VectorStyle->Black],Graphics[{Text[Style["Time A",18],{-.14,1/2},Automatic,{0,1}],Text[Style["Time B",18],{1/2,1.14}],Text[Style["Present",12],{.12,1.1}],Text[Style["Future",12],{.92,1.1}],Text[Style["Present",12],{-.1,0.88}],Text[Style["Future",12],{-.1,0.12}],Arrow[{{.22,1.1},{.82,1.1}}],Arrow[{{-.1,0.8},{-.1,0.2}}]}]]

Indirect

myExponential=0.9^t

myHyperbolic=myWeighted[myExponential,3/5]

Integrate[myExponential,{t,0,τ}]

Integrate[myExponential,{t,0,∞}]

Integrate[myExponential/4,{t,0,∞}]

myHyperbolic2=Normal[Series[myHyperbolic,{t,0,10}]]

myHyperbolicIntegrated=Integrate[myHyperbolic2,{t,0,τ}]

Plot[{myHyperbolicIntegrated,9.49122-9.49122 0.9^τ},{τ,0,4}]

Solve[9.49122-9.49122 0.9^τ==2.372805395257476`,τ]
Solve[9.49122 0.9^τ==2.372805395257476`,τ]

Solve[myHyperbolicIntegrated==2.372805395257476`,τ,Reals]

Others

This section includes various other calculations, indirectly related to the model above.

Graphs

Plot[{myWeighted[p,1/2],myWeighted2[p,1/2,1/2,1/2,1]},{p,0,1},PlotStyle->{Black,Black},AxesLabel->{p,π},ImageSize->250,Background->White]
Plot[{myWeighted2[p,3/5,3/5,3/5,3/5],myWeighted[p,1]},{p,0,1},PlotStyle->{Black,{Dashed,Black}},AxesLabel->{p,π},ImageSize->250,Background->White]
Plot[{myWeighted2[p,1/2,1/2,1/2,1],myWeighted2[p,1/2,1,1,1],myWeighted2[p,2,1,1,1],myWeighted2[p,2,2,2,1],myWeighted[p,1]},{p,0,1},PlotStyle->{{Black},{Black},{Black},{Black},{Dashed,Black}},AxesLabel->{p,π},ImageSize->250,Background->White]
Plot[{myWeighted2[p,1/2,1/2,1/2,1],myWeighted2[p,1/2,2,2,4],myWeighted2[p,2,2,2,1],myWeighted2[p,2,1/2,1/2,1]},{p,0,1},PlotStyle->{{Black},{Black},{Black},{Black}},AxesLabel->{p,π},ImageSize->250,Background->White]

Plot[{b^(1/β)/(1+b^(1/β))/.b->.2,b^(1/β)/(1+b^(1/β))/.b->.8,b^(1/β)/(1+b^(1/β))/.b->1.2,b^(1/β)/(1+b^(1/β))/.b->1.8},{β,0,1},PlotRange->{0,1},PlotStyle->{{Black},{Black},{Black},{Black}}]

TableForm[Table[TableForm[{{" ",Transpose[myB][[n,m]]},{myA[[n,m]]," "}}],{n,1,2},{m,1,2}],TableHeadings->{{"A1","A2"},{"B1","B2"}},TableSpacing->{3,5},TableDepth->2,TableAlignments->Right]

Show[Graphics[{Line[{{0,0},{-3,-3}}],Line[{{0,0},{3,-3}}],Line[{{-3,-3},{-9/2,-5}}],Line[{{-3,-3},{-3/2,-5}}],Line[{{-9/2,-5},{-11/2,-7}}],Line[{{-9/2,-5},{-7/2,-7}}],Line[{{-3/2,-5},{-5/2,-7}}],Line[{{-3/2,-5},{-1/2,-7}}],Line[{{3,-3},{2,1/Sin[Pi/8]-5-Cos[Pi/8]/Sin[Pi/8]}}],Line[{{3,-3},{4,1/Sin[Pi/8]-5-Cos[Pi/8]/Sin[Pi/8]}}],Line[{{3,-5},{2,1/Sin[Pi/8]-7-Cos[Pi/8]/Sin[Pi/8]}}],Line[{{3,-5},{4,1/Sin[Pi/8]-7-Cos[Pi/8]/Sin[Pi/8]}}],{Dashed,Line[{{-9/2,-5},{-3/2,-5}}]},{PointSize[.03],Point[{0,0}],Point[{-3,-3}],Point[{3,-3}],Point[{-9/2,-5}],Point[{-3/2,-5}],Point[{3,-5}]},{PointSize[.02],White,{Point[{0,0}],Point[{3,-3}]}},Text[Style["N",Large],{0,1/2}],Text[Style["B",Large],{-3,-5/2}],Text[Style["N",Large],{3,-5/2}],Text[Style["A",Large],{-9/2,-9/2}],Text[Style["A",Large],{-3/2,-9/2}],Text[Style["A",Large],{3,-9/2}],Text[Style["B1",20],{-4,-15/4}],Text[Style["B2",20],{-2,-15/4}],Text[Style["A1",20],{-11/2,-6}],Text[Style["A2",20],{-7/2,-6}],Text[Style["A1",20],{-5/2,-6}],Text[Style["A2",20],{-1/2,-6}],Text[Style["(Subscript[P, 0])",20],{2,-6}],Text[Style["(Subscript[P, 1])",20],{4,-6}],Text[Style["[(Subscript[R, 0])]",Italic,20],{2,-15/4}],Text[Style["[(Subscript[R, 1])]",Italic,20],{4,-15/4}],Text[Style["[(Subscript[G, 1])]",Italic,20],{-7/4,-1}],Text[Style["[(Subscript[G, 2])]",Italic,20],{7/4,-1}],Text[Style["4",Italic,20],{-11/2,-15/2}],Text[Style["2",Italic,20],{-11/2,-8}],Text[Style["3",Italic,20],{-7/2,-15/2}],Text[Style["2",Italic,20],{-7/2,-8}],Text[Style["-2",Italic,20],{-5/2,-15/2}],Text[Style["3",Italic,20],{-5/2,-8}],Text[Style["0",Italic,20],{-1/2,-15/2}],Text[Style["0",Italic,20],{-1/2,-8}],Text[Style["3-3(R-P)^2",Italic,18],{3,-61/8}]}],ParametricPlot[{3-Sin[u]/Sin[Pi/8],1/Sin[Pi/8]-5-Cos[u]/Sin[Pi/8]},{u,-Pi/8,Pi/8},PlotStyle->Black],ParametricPlot[{3-Sin[u]/Sin[Pi/8],1/Sin[Pi/8]-7-Cos[u]/Sin[Pi/8]},{u,-Pi/8,Pi/8},PlotStyle->Black],ImageSize->{Automatic,500},Background->White]

Graphics[{{EdgeForm[Thick],White,Rectangle[{-1/2,-1/2},{1/2,1/2}],Rectangle[{2,1/2},{3,3/2}],Rectangle[{2,-1/2},{3,-3/2}]},Arrow[{{1/2,0},{2,1}}],Arrow[{{1/2,0},{2,-1}}],Arrow[{{5/2,-1/2},{5/2,1/2}}],Arrow[{{5/2,1/2},{5/2,-1/2}}],Text[Style["UC",Italic,20],{0,0}],Text[Style["PW",Italic,20],{5/2,1}],Text[Style["HD",Italic,20],{5/2,-1}]},ImageSize->{200,Automatic},Background->White]

Graphics[{{EdgeForm[Thick],White,Rectangle[{-1/2,-4/2},{1/2,-2/2}],Rectangle[{-1/2,-1/2},{1/2,1/2}],Rectangle[{-1/2,2/2},{1/2,4/2}],Rectangle[{2,1/2},{3,3/2}],Rectangle[{2,-1/2},{3,-3/2}]},Arrow[{{1/2,-3/2},{1.99,.93}}],Arrow[{{1/2,0},{2,1}}],Arrow[{{1/2,2},{2,1}}],Arrow[{{1/2,-3/2},{2,-1}}],Arrow[{{5/2,-1/2},{5/2,1/2}}],Arrow[{{5/2,1/2},{5/2,-1/2}}],Text[Style["UC",Italic,20],{0,-3/2}],Text[Style["UC",Italic,20],{0,0}],Text[Style["UC",Italic,20],{0,3/2}],Text[Style["PW",Italic,20],{5/2,1}],Text[Style["HD",Italic,20],{5/2,-1}]},ImageSize->{200,Automatic},Background->White]

Graphics[{{EdgeForm[Thick],White,Rectangle[{-1/2,-3/2},{1/2,-1/2}],Rectangle[{-1/2,1/2},{1/2,3/2}],Rectangle[{7/2,1/2},{9/2,3/2}],Rectangle[{7/2,-1/2},{9/2,-3/2}],Rectangle[{3/2,-3/2},{5/2,3/2}]},Arrow[{{1/2,1},{7/2,1}}],Arrow[{{1/2,-1},{7/2,-1}}],Arrow[{{4,-1/2},{4,1/2}}],Arrow[{{4,1/2},{4,-1/2}}],Text[Style["UC",Italic,20],{0,-1}],Text[Style["UC",Italic,20],{0,1}],Text[Style["PW",Italic,20],{4,1}],Text[Style["HD",Italic,20],{4,-1}],Text[Style["PC",Italic,20],{2,0}]},ImageSize->{280,Automatic},Background->White]

Show[Graphics[{Line[{{3,-3},{2,1/Sin[Pi/8]-5-Cos[Pi/8]/Sin[Pi/8]}}],Line[{{3,-3},{4,1/Sin[Pi/8]-5-Cos[Pi/8]/Sin[Pi/8]}}],Line[{{3,-5},{2,-7}}],Line[{{3,-5},{4,-7}}],{PointSize[.12],Point[{3,-3}],Point[{3,-5}]},Text[Style["B",Large],{3,-5/2}],Text[Style["A",Large],{3,-9/2}],Text[Style["R",20],{2,-6}],Text[Style["A",20],{4,-6}],Text[Style["(Subscript[t, 0])",Italic,20],{2,-15/4}],Text[Style["(Subscript[t, 1])",Italic,20],{4,-15/4}],Text[Style["(1/4)(∫_0^∞)(δ^τ)\[DifferentialD]τ",Italic,16],{2,-15/2}],Text[Style["(1/4)(∫_0^∞)(δ^τ)\[DifferentialD]τ",Italic,16],{2,-17/2}],Text[Style["(∫_0^t)(δ^τ)\[DifferentialD]τ",Italic,16],{4,-15/2}],Text[Style["(∫_t^∞)(δ^τ)\[DifferentialD]τ",Italic,16],{4,-17/2}]}],ParametricPlot[{3-Sin[u]/Sin[Pi/8],1/Sin[Pi/8]-5-Cos[u]/Sin[Pi/8]},{u,-Pi/8,Pi/8},PlotStyle->Black],ImageSize->{Automatic,350},Background->White]

Show[Plot[{myExponential,myWeighted[myExponential,3/5]},{t,0,20},PlotRange->{0,1},PlotStyle->Black,AxesLabel->{t,"f(t), u(t)"},ImageSize->250,Background->White],Graphics[{Text[Style["f(t) = (δ^t)",9],{12,.8}],Text[Style["u(t) = π((δ^t))",9],{14.5,.65}],Arrow[BezierCurve[{{18,.23},{17.5,.4},{15,.58}}]],Arrow[BezierCurve[{{5,.6},{7,.75},{10,.8}}]]}]]

Matrix of Games

myTableOfPermutationsA=Permutations[{Aa,Ab,Ac,Ad}];
myTableOfPermutationsB=Permutations[{Ba,Bb,Bc,Bd}];

myTableOfPermutatedA=Table[{{Aa,Ab},{Ac,Ad}}/.{myTableOfPermutationsA[[i,1]]->1,myTableOfPermutationsA[[i,2]]->2,myTableOfPermutationsA[[i,3]]->3,myTableOfPermutationsA[[i,4]]->4},{i,1,24}];
myTableOfPermutatedB=Table[{{Ba,Bb},{Bc,Bd}}/.{myTableOfPermutationsB[[j,1]]->1,myTableOfPermutationsB[[j,2]]->2,myTableOfPermutationsB[[j,3]]->3,myTableOfPermutationsB[[j,4]]->4},{j,1,24}];

myTableOfEquilibria=Table[myA=myTableOfPermutatedA[[i]];myB=myTableOfPermutatedB[[j]];{mySolveMixedA,mySolveMixedB},{i,1,24},{j,1,24}];
myTableOfProspectEquilibria=Table[myA=myTableOfPermutatedA[[i]];myB=myTableOfPermutatedB[[j]];{myProspectSolveMixedA[1/2],myProspectSolveMixedB[1]},{i,1,24},{j,1,24}];

MatrixForm[myTableOfProspectEquilibriaSub=Table[If[Length[myTableOfProspectEquilibria[[i,j]][[1]]]==1,If[Length[myTableOfProspectEquilibria[[i,j]][[2]]]==1,If[0<=(α/.Flatten[myTableOfEquilibria[[i,j]]])<=1,If[0<=(β/.Flatten[myTableOfEquilibria[[i,j]]])<=1,1,0],0],0],0],{i,1,24},{j,1,24}]]

myTableOfProspectEquilibriaSubAddedA=Table[Sum[myTableOfProspectEquilibriaSub[[i,j]],{j,1,24}],{i,1,24}];
myTableOfProspectEquilibriaSubAddedB=Table[Sum[myTableOfProspectEquilibriaSub[[i,j]],{i,1,24}],{j,1,24}];

myTableOfProspectEquilibriaSubAddedWhichA=DeleteCases[Table[If[myTableOfProspectEquilibriaSubAddedA[[n]]>0,{n}],{n,1,24}],Null]//Flatten;
myTableOfProspectEquilibriaSubAddedWhichB=DeleteCases[Table[If[myTableOfProspectEquilibriaSubAddedB[[n]]>0,{n}],{n,1,24}],Null]//Flatten;

myTableOfProspectEquilibriaSubAddedWhichNotA=DeleteCases[Table[If[myTableOfProspectEquilibriaSubAddedA[[n]]==0,{n}],{n,1,24}],Null];
myTableOfProspectEquilibriaSubAddedWhichNotB=DeleteCases[Table[If[myTableOfProspectEquilibriaSubAddedB[[n]]==0,{n}],{n,1,24}],Null];

myTableOfProspectEquilibria2=Table[myTableOfProspectEquilibria[[i]],{i,myTableOfProspectEquilibriaSubAddedWhichA}];
myTableOfProspectEquilibria3=Transpose[Table[Transpose[myTableOfProspectEquilibria2][[i]],{i,myTableOfProspectEquilibriaSubAddedWhichB}]];

myTableOfEquilibria2=Table[myTableOfEquilibria[[i]],{i,myTableOfProspectEquilibriaSubAddedWhichA}];
myTableOfEquilibria3=Transpose[Table[Transpose[myTableOfEquilibria2][[i]],{i,myTableOfProspectEquilibriaSubAddedWhichB}]];

myTableOfPermuatedA2=Delete[myTableOfPermutatedA,myTableOfProspectEquilibriaSubAddedWhichNotA];
myTableOfPermuatedB2=Delete[myTableOfPermutatedB,myTableOfProspectEquilibriaSubAddedWhichNotB];

MatrixForm[myTableOfFitness=Table[myA=myTableOfPermuatedA2[[i]];myB=myTableOfPermuatedB2[[j]];{N[myFitnessA[α/.Flatten[myTableOfEquilibria3[[i,j]]],β/.Flatten[myTableOfEquilibria3[[i,j]]]]],N[myFitnessB[α/.Flatten[myTableOfEquilibria3[[i,j]]],β/.Flatten[myTableOfEquilibria3[[i,j]]]]]},{i,1,Length[myTableOfProspectEquilibriaSubAddedWhichA]},{j,1,Length[myTableOfProspectEquilibriaSubAddedWhichB]}]]

"MatrixForm[myTableOfPlots=Table[myA=myTableOfPermuatedA2[[i]];myB=myTableOfPermuatedB2[[j]];myPlot,{i,1,Length[myTableOfProspectEquilibriaSubAddedWhichA]},{j,1,Length[myTableOfProspectEquilibriaSubAddedWhichB]}]]"

MatrixForm[myTableOfProspectFitness=Table[myA=myTableOfPermuatedA2[[i]];myB=myTableOfPermuatedB2[[j]];{N[myFitnessA[α/.Flatten[myTableOfProspectEquilibria3[[i,j]]],β/.Flatten[myTableOfProspectEquilibria3[[i,j]]]]],N[myFitnessB[α/.Flatten[myTableOfProspectEquilibria3[[i,j]]],β/.Flatten[myTableOfProspectEquilibria3[[i,j]]]]]},{i,1,Length[myTableOfProspectEquilibriaSubAddedWhichA]},{j,1,Length[myTableOfProspectEquilibriaSubAddedWhichB]}]]

MatrixForm[myTableOfProspectFitness=Table[myA=myTableOfPermuatedA2[[i]];myB=myTableOfPermuatedB2[[j]];{N[myFitnessA[α/.Flatten[myTableOfProspectEquilibria3[[i,j]]],β/.Flatten[myTableOfProspectEquilibria3[[i,j]]]]],N[myFitnessB[α/.Flatten[myTableOfProspectEquilibria3[[i,j]]],β/.Flatten[myTableOfProspectEquilibria3[[i,j]]]]]},{i,1,Length[myTableOfProspectEquilibriaSubAddedWhichA]},{j,1,Length[myTableOfProspectEquilibriaSubAddedWhichB]}]]

MatrixForm[myTableOfProspectFitness=Table[myA=myTableOfPermuatedA2[[i]];myB=myTableOfPermuatedB2[[j]];{N[myFitnessA[α/.Flatten[myTableOfProspectEquilibria3[[i,j]]],β/.Flatten[myTableOfProspectEquilibria3[[i,j]]]]],N[myFitnessB[α/.Flatten[myTableOfProspectEquilibria3[[i,j]]],β/.Flatten[myTableOfProspectEquilibria3[[i,j]]]]]},{i,1,Length[myTableOfProspectEquilibriaSubAddedWhichA]},{j,1,Length[myTableOfProspectEquilibriaSubAddedWhichB]}]]

Various Discount Functions

myDelta[α_,β_,t_]:=α+β*t

myFunction[α_,β_,t_]:=myDelta[α,β,t]^t wrong

myFunctionTable=Table[1,{t,0,100}];
Table[myFunctionTable[[t+1]]=myFunctionTable[[t]]*myDelta[.9,.001,t],{t,1,100,1}];

ListPlot[myFunctionTable]

myExponential2[δ_,t_]:=δ^t

myMapping[p_]:=1/2p+1/2(1/2+4(p-1/2)^3)

Plot[{myMapping[p],myWeighted[p,1],myWeighted[p,3/5]},{p,0,1}]

myHyperbolic3[k_,t_]:=1/(1+k t)

ParametricPlot[{{myExponential2[.9,t],myHyperbolic3[.2,t]},{t,t}},{t,0,1000},PlotRange->{0,1}]

myf=Piecewise[{{2-4x,x<1/2},{4x-2,x>=1/2}}];
myFF=Piecewise[{{2 x-2 x^2,x<1/2},{1-2 x+2 x^2,x>=1/2}}];
myFFF=1/2x+1/2(1/2+4(x-1/2)^3);
Plot[{myf,myFF,myFFF},{x,0,1},PlotRange->{0,1},Filling->Bottom]

Conclusion

In conclusion, we have used this notebook to create a model for Prospect Theory probability weighting and for hyperbolic discounting which are used in my thesis ‘The Evolutionary Foundation of Probability Weighting and Hyperbolic Discounting’. Some of the functions used were based on a previous notebook by Elliott Wagner, who wrote the paper ‘The Dynamics of Costly Signaling’.