(* ==================================================================
The use of this Package is described in "Economic and Financial
Modeling with Mathematica", Hal Varian, editor, TELOS/Springer-Verlag,
1993, ISBN 0-387-97882-8.  $44.95 (Includes 1.44 MS-DOS disk.)  To
place order call 1-800-777-4643 or fax 1-201-348-4505.
=====================================================================*)

BeginPackage["Nash`"]

Nash::usage ="Nash[game_] finds the Nash Equilibria of game, a game in 
normal form. Example input: Nash[{{{2,1},{0,0}},{{0,0},{1,2}}}]. Nash 
returns the probability weights on the different pure strategies."

IsNash::usage ="IsNash[game_,strategies_] returns True if strategies is 
a Nash Equilibrium of game and False otherwise.
Example input: IsNash[game,{{2/3,1/3},{1/3,2/3}}]."


Brgraph::usage="Brgraph[game_,step_:.01] plots the best response graph of a 2 by 2 by 2 
game. It plots the best response of player 1 on the x-axis given the action 
of player 2 on the y-axis. It then plots the best response of player 2 on the
y-axis given the action of player 1 on the x-axis. The intersection points
of the two are the equilibria. Step is the interval size for plotting. 
 (Note that this doesn't show the shaded area in the best response
correspondence when it exists in a continuum of equilibria .)"
 
Convex::usage="Convex[solns_] takes the solutions of Normal Form game 
generated by Nash.m and generates the convex combinations that are
also Nash equilibria. Convex will output the entire set of Nash equilibria
of the original game; however, the output won't be in the simplest form.";
ReduceSoln::usage ="ReduceSoln[solns_,highestt_] eliminates redundant representations
of Nash equilibria from the output of Convex (solns). highestt is the highest
numbered t in the output of Convex. For example, t4 is valued 4."


Begin["`Private`"]

Convex[solns_]:=Block[{t1,i,x,t2,t3,t4,t5,t6,doit,conv1,convex,make,representation},
 

 representation[{z_, s_},i_] := ToExpression[StringJoin["t",ToString[i]]] z + (1 -  ToExpression[StringJoin["t",ToString[i]]] ) s;


  make[{a_, b_}] := Function[x, x[[2]] == b || x[[1]] == a];

  convex[solutionset_] :=
    Table[Select[solutionset, make[solutionset[[i]]]],
    {i, 1, Length[solutionset]}];
           conv1[a_,b_,ii_]:=Table[Map[Function[x,representation[{a[[i]],x},ii]],
   b[[i]] ],{i,1,Length[a]}];

  conversion[solnns_,ii_]:=Union[Simplify[Flatten[conv1[solnns,
     convex[solnns],ii],1]]];


  doit[solnns_,0]:=solnns;
  doit[solnns_,x_]:=doit[conversion[solnns,x],x-1];


  doit[solns, Length[solns[[1,1]]]+Length[solns[[1,2]]]-2] ];

ReduceSoln[solns_,hightestt_]:=Block[{x,i,j,k,z1,endlist,expand},  
  expand[x_,j_]:= Union[Table[x/.Table[   ToExpression[StringJoin["t",ToString[i]]]->Mod[Floor[k/2^(i-1)],2],
  {i,1,j}],{k,0,2^j-1}]];
endlist=Map[Function[x,expand[x,hightestt]],solns]; 
uendlist=Union[endlist];
Table[solns[[Position[endlist,uendlist[[z1]] ][[1]]]],{z1,1,Length[uendlist]}]
  ];


Brgraph[game_,step_:.01]:=Block[{V,BR,l1,l2,pl1,pl2},
  If[Length[Dimensions[game]]!=3 || Dimensions[game][[1]]!=2 || 
    Dimensions[game][[2]]!=2, Return["The game is not a 2 by 2 by 2 list"]];

  V[i_,{p1_,p2_}]:={p1,1-p1}.Transpose[game,{2,3,1}][[i]].{p2,1-p2};


  BR[1,p2_]:=ConstrainedMax[V[1,{p1,p2}],{p1<=1},{p1}];
  BR[2,p1_]:=ConstrainedMax[V[2,{p1,p2}],{p2<=1},{p2}];

  l1=Table[{p1/.BR[1,p2][[2]],p2},{p2,0,1,step}];
  l2=Table[{p1,p2/.BR[2,p1][[2]]},{p1,0,1,step}];

  SetOptions[ListPlot,DisplayFunction->Identity];
  pl1= ListPlot[l1,PlotJoined->True];
  pl2= ListPlot[l2,PlotJoined->True];
  SetOptions[ListPlot,DisplayFunction->$DisplayFunction];

  Show[pl1,pl2,DisplayFunction->$DisplayFunction]
];


IsNash[a_,S_]:=Block[{l}, 
  l=Dimensions[a][[1]];
  Isnash[a,S]
];

Isnash[a_,S_]:=Block[{m1,m2,Eu,br1,br2,t},
   Eu[2,st_]:=N[S[[1]].a[[Range[1,l],st,2]]];
   Eu[1,st_]:=N[S[[2]].a[[st,Range[1,l],1]]];
   m1=Max[Table[Eu[1,t],{t,1,l}]];
   m2=Max[Table[Eu[2,t],{t,1,l}]];
   br1=Table[If[Eu[1,t]==m1,0,1],{t,1,l}];
   br2=Table[If[Eu[2,t]==m2,0,1],{t,1,l}];
   If[br1.S[[1]]+br2.S[[2]]==0,True,False]
];

Square[a_]:=Block[{n,l},
 n[i_]:=Dimensions[a][[i]];
 l=Max[n[1],n[2]];
Table[ If[i<=n[1] && j<=n[2],a[[i,j]],{Min[a]-1,Min[a]-1}],{i,1,l},{j,1,l}]]

Nash[a_]:=Block[{n,l,anew,MapD,Dropd,solns},

   If[Length[Dimensions[a]]!=3,Return["Not a two-player game!"]];  
   n[i_]:=Dimensions[a][[i]];
   l=Max[n[1],n[2]];
   If[2!=Dimensions[a][[3]],Return["Payoffs aren't defined for two players"]];
   If[n[1]!=n[2],anew=Square[a];
      solns=Nash[anew];
      Dropd[i_][x_]:=Drop[x,n[i]-l];
      MapD[x_]:=MapAt[Dropd[1],MapAt[Dropd[2],x,{{2}}],{{1}}];
      Return[Map[MapD,solns]]
   ,Return[NashSq[a]]];
   
]
NashSq[a_]:=Block[{t1,t2,t3,l,p,pp,a1list,a2list,blist,f,pos,nq,pn,nlist,
   eqn1,eqn2,eqns1,eqns2,ans1,ans2,i,j,NashE},
   l=Dimensions[a][[1]];
   pp=Table[p[i],{i,1,l}]; a1list={}; a2list={};
   blist=Table[Mod[Floor[j/2^i],2],{j,1,2^l-1},{i,0,l-1}];   
   For[t1=1,t1<=Length[blist],t1++,
   { num=Apply[Plus,blist[[t1]]];
     f[x_]:=If[Apply[Plus,x]==num,True,False];
     slist=Select[blist,f];
     For[t2=1,t2<=Length[slist],t2++,
     { pos=Flatten[Position[slist[[t2]],1]];
       eqn1=Table[(pp*blist[[t1]]).a[[Range[1,l],pos[[t3]],2]],{t3,1,num}];
       eqn2=Table[(pp*blist[[t1]]).a[[pos[[t3]],Range[1,l],1]],{t3,1,num}];
       eqns1=Table[eqn1[[i]]==eqn1[[i+1]],{i,1,num-1}];
       eqns2=Table[eqn2[[i]]==eqn2[[i+1]],{i,1,num-1}];
       ans1=Solve[Join[eqns1,{Apply[Plus,pp*blist[[t1]]]==1}],pp];
       ans2=Solve[Join[eqns2,{Apply[Plus,pp*blist[[t1]]]==1}],pp];
       AppendTo[a1list,Flatten[(pp*blist[[t1]])/.ans1]];
       AppendTo[a2list,Flatten[(pp*blist[[t1]])/.ans2]];
   }]}];
   nq[x_]:=Apply[And,Table[NumberQ[N[x[[i]]]],{i,1,Length[x]}]];
   pn[x_]:=Apply[And,Table[N[x[[i]]]>=0 && N[x[[i]]]<=1,{i,1,Length[x]}]];
   a1list=Union[Select[Select[a1list,nq],pn]];
   a2list=Union[Select[Select[a2list,nq],pn]];
   nlist=Flatten[Table[{a1list[[i]],a2list[[j]]},{i,1,Length[a1list]},
     {j,1,Length[a2list]}],1];
   INash[S_]:=Isnash[a,S];
   NashE=Select[nlist,INash]
];
End[]

EndPackage[]