💡💡💡 DYNAMO 3 💡💡💡
Phase Diagrams for Evolutionary Dynamics

User-defined Parameters

When you have finished specifying parameters, click on the rightmost vertical bar and press Enter (or Shift-Enter) to run the program.

Off[General::spell1];

Choice of game

Choose a normal form game here.  To use one of the built-in payoff matrices, select the matrix on the right hand side of "A = ." (including the parentheses but not the semicolon); then the press the button corresponding to the game you desire.

({{RPS , Good RPS , Bad RPS , Pure Coordination , 123 Coordination , ZH}})

Zeeman's normal form games

Listed by name

({{1 , (Subscript[5, 1]) , (Subscript[6, 1]) , (Subscript[7, 1]) }, {(Subscript[10, 1]) , (Subscript[4, 1]) , (Subscript[6, 2]) , (Subscript[7, 2]) }, {(Subscript[9, 1]) , 2 , 3 , (Subscript[5, 2]) }, {8 , -(Subscript[4, 2]) , -(Subscript[6, 3]) , -(Subscript[6, 4]) }, { (Subscript[7, 3]), -(Subscript[9, 2]) , -(Subscript[10, 2]) , .}})

Listed by payoff matrix

({{(({{0, 2, -1}, {-1, 0, 2}, {2, -1, 0}})), (({{0, 3, -1}, {1, 0, 1}, {3, -1, 0}})), (({{0, 1, 1}, {-1, 0, 3}, {1, 1, 0}})), (({{0, 6, -4}, {-3, 0, 5}, {-1, 3, 0}})), (({{0, 1, 1}, {1, 0, 1}, {1, 1, 0}}))}, {(({{0, 3, -1}, {3, 0, -1}, {1, 1, 0}})), (({{0, 1, 3}, {-1, 0, 5}, {1, 3, 0}})), (({{0, 1, -1}, {-1, 0, 1}, {-1, 1, 0}})), (({{0, -1, 3}, {-1, 0, 3}, {1, 1, 0}})), (({{0, 1, 1}, {-1, 0, 1}, {-1, -1, 0}}))}, {(({{0, 1, 1}, {1, 0, 1}, {-1, -1, 0}})), (({{0, 1, -1}, {1, 0, 1}, {1, -1, 0}})), (({{0, -1, -1}, {1, 0, 1}, {-1, 1, 0}})), (({{0, -1, 1}, {-1, 0, 1}, {-1, -1, 0}})), (({{0, -1, -1}, {1, 0, -1}, {-1, -1, 0}}))}, {(({{0, -1, -1}, {1, 0, -3}, {-1, -3, 0}})), (({{0, 1, -1}, {-3, 0, 1}, {-1, 1, 0}})), (({{0, 1, -3}, {1, 0, -1}, {-3, -1, 0}})), (({{0, -3, -1}, {-3, 0, -1}, {-1, -1, 0}})), Empty}})

A=(({{1, 0, 0}, {0, 2, 0}, {0, 0, 3}})) ;

Nonlinear population games

To choose a nonlinear game, set nonlineargame = 1 and define F[x_] as you like.  In doing so, the components of x should be entered as x[[1]], x[[2]], and x[[3]].   To choose a congestion game, select A.x and hit the congestion game button; specify the congestion game in the section above the box.  The default value of F[x_] is A.x, the payoff vector field for the normal form game A.

Definition of the congestion game

Cost functions for facilities as functions of utilization levels.

cost[1][u_] := 4 + 20 u  ; 
cost[2][u_] := 2 + 30 u^2 ;
cost[3][u_] := 2 + 30 u^2 ; 
cost[4][u_] :=  4 + 20 u ; 
cost[5][u_] := 1 + 20 u ;
cost[6][u_] := 0  ; 
cost[7][u_] :=  0  ;

Which strategies use which facilities.

Clear[Φ] ;

    
Φ[1] = {1, 2} ; 
Φ[2] = {3, 4} ;
Φ[3] = {2, 3, 5} ;
ρ[ϕ_] := 
        DeleteCases[
          Table[If[MemberQ[Φ[i], ϕ], i], {i, 3}] , 
          Null];

    
u[ϕ_, 
          x_] := (∑_(i = 1)^(Dimensions[ρ[ϕ]][[1]]))x[[ρ[ϕ][[i]]]] ;

({{Congestion game}})

nonlineargame  = 0 ;
F[x_]  := A . x  ;

If the game you consider has a nontrivial component of Nash equilibria, the program will find a random subset of this component.  If you'd prefer not to compute the Nash equilibria, set findnashequilibria to 0.

findnashequilibria = 1 ;

Give the strategies one-character names to be printed on the phase diagram.  Vertices are ordered counterclockwise.

strategy[1] = "1" ; 
strategy[2] = "2" ; 
strategy[3] = "3" ;

Payoff-related definitions

Clear[Fbar] ;  Clear[Fhat] ;   Clear[Fhatplus] ;

The population's average payoff

Fbar[x_, 
          F_] := (∑_(i = 1)^3) x[[
              i]] F[x][[
              i]] ;

Excess payoff vector

Fhat[x_, F_] := F[x]  -  Fbar[x, F] ;

Vector of positive parts of excess payoffs

Fhatplus[x_, 
          F_] :=  {Max[
            0, Fhat[x, F][[1]]], 
          Max[0, Fhat[x, F][[2]]], 
          Max[0, Fhat[x, 
                F][[3]]]} ;

Projected payoff vector

PhiF[x_, F_] := 
        F[x] - {1/3, 1/3, 
              1/3} (∑_(i = 1)^3) F[x][[i]] ;

Choice of dynamic

To specify a dynamic, select the rhs of "Dynamic = (.)" (excluding the semicolon), and then press the button corresponding to the dynamic you desire.  Definitions of the dynamics can be found in the closed group at the end of this section.
Details:  If you use Logit[η] or ILogit[η], be sure to enter a value for the noise parameter η in the closed group below.  Making  η very small generates close approximations of the best response dynamic.  Similarly, if you use SelMut[MM], enter the mutation matrix MM in its closed group.  If you use Projection and if you are not using Mathematica version 5 or above, do not take initial condtions on the boundary. EP (excess payoff dynamic), PC (pairwise comparison dynamic), ConvexComb, and Other must be specified in greater detail below.

Noise level for the logit and i-logit dynamics

η  =   .2 ;

Matrix of mutation rates for the selection-mutation dynamic

Entry ij of the matrix MM is the probability of a mutation from i to j ≠ i; entry ii is the probability of no mutation from i.  The rows of MM must sum to one.  Note that the selection-mutation dynamic is only well defined for nonnegative payoffs, and that it is not invariant to the addition of a constant to all matrix entries.

MM=(({{1, 0, 0}, {0, 1, 0}, {0, 0, 1}})) ;

({{Replicator, Logit[η], BNN, PD, Projection, Combined}, {MSReplicator, ILogit[η], EP, PC, SelMut[MM], Other}})

Dynamic = Replicator ;

If the dynamic you consider has a nontrivial component of rest points, the program will compute and plot a random subset of this component.  If you set findrestpoints equal to 0, the computation and plotting is skipped.

findrestpoints = 1 ;

Definition of combination of two dynamics

To define a combination of two dynamics, specify the two dynamics to be combined, the weights  on the dynamics, and the characterization of the rest points of combined dynamic.  Nash is the default setting for the set or rest points.  This is correct, for example, with combinations of the replicator dynamic and an excess payoff dynamic like the BNN dynamic.  If the rest points aren't identical to the Nash equilibria for the dynamics you have specified, you can replace Nash with Automatic if the combined dynamic is smooth.  (If the combined dynamic isn't smooth, you're on your own!)  The last line of code formally defines the combined dynamic according to your specificcations.

dyn[1] = Replicator ;
dyn[2] = BNN ;
weight[1] =  .9 ;
weight[2] =  .1 ;
RPCharacterization[Combined] = Nash ;

    
Combined[x_, F_] := 
        weight[1]  dyn[1][x, F] +  
          weight[2] dyn[2][x, F] ;

Definitions of dynamics

Clear[Replicator] ;  
Clear[BNN]  ;
Clear[Logit] ;
Clear[rho] ;
Clear[PD] ; 
Clear[rho1] ;
Clear[SelMut] ;

Replicator Dynamic

Replicator[x_, 
          F_] := {x[[1]]  Fhat[x, 
                F][[1]], 
          x[[2]]  Fhat[x, 
                F][[2]], 
          x[[3]]  Fhat[x, 
                F][[3]]} ;

RPCharacterization[Replicator] = 
        Automatic ;

Maynard Smith Replicator Dynamic

MSReplicator[x_, 
          F_] := (1/Fbar)[x, 
                F] {x[[1]]  Fhat[
                  x, F][[1]], 
            x[[2]]  Fhat[x, 
                  F][[2]], 
            x[[3]]  Fhat[x, 
                  F][[3]]} ;

RPCharacterization[MSReplicator] = 
        Automatic ;

Logit Dynamic

Logit[η_][x_, 
          F_] := {((E^(F[x][[1]]/η))/((∑_(i = 1)^3) (E^(F[x][[i]]/η)))) - x[[1]], ((E^(F[x][[2]]/η))/((∑_(i = 1)^3) (E^(F[x][[i]]/η)))) - 
            x[[2]], ((E^(F[x][[3]]/η))/((∑_(i = 1)^3) (E^(F[x][[i]]/η)))) - 
            x[[3]]} ;

RPCharacterization[Logit[_]] = 
        Automatic ;

I-Logit Dynamic

ILogit[η_][x_, 
          F_] := {((x[[1]] (E^(F[x][[1]]/η)))/((∑_(i = 1)^3) x[[i]] (E^(F[x][[i]]/η))))  - x[[1]], ((x[[2]] (E^(F[x][[2]]/η)))/((∑_(i = 1)^3) x[[i]] (E^(F[x][[i]]/η)))) - x[[2]], ((x[[3]] (E^(F[x][[3]]/η)))/((∑_(i = 1)^3) x[[i]] (E^(F[x][[i]]/η)))) - 
            x[[3]]} ;

RPCharacterization[ILogit[_]] = 
        Automatic ;

BNN dynamic

BNN[x_, 
          F_] := {Fhatplus[x, 
                F][[1]] - 
            x[[1]] (∑_(i = 1)^3) Fhatplus[x, F][[
                  i]], Fhatplus[x, 
                F][[2]] - 
            x[[2]] (∑_(i = 1)^3) Fhatplus[x, F][[
                  i]], Fhatplus[x, 
                F][[3]] - 
            x[[3]] (∑_(i = 1)^3) Fhatplus[x, F][[
                  i]]} ;

RPCharacterization[BNN] = Nash ;

Excess payoff dynamic

Here one specifies the vector field sigmatilde that defines an excess payoff dynamic.  This definition should be stated in terms of the excess payoff vector Fhat[x,F], which is defined as Fhat[x,F] = F[x] - Fbar[x,F].  (Mathematica subtracts the scalar from the vector correctly.)  When computing rest points, the program assumes that sigmatilde is acute, so that the rest points of the dynamic are the Nash equilibria of the underlying game.

sigmatilde[x_, 
          F_] :=  {(Max[
                0, Fhat[x, 
                    F][[1]]])^2, 
(Max[
                0, Fhat[x, 
                    F][[2]]])^2, (Max[0, Fhat[x, 
                    F][[3]]])^2};

EP[x_, 
          F_] := {sigmatilde[x, 
                F][[1]] - 
            x[[1]] (∑_(i = 1)^3) sigmatilde[x, F][[
                  i]], sigmatilde[x, 
                F][[2]] - 
            x[[2]] (∑_(i = 1)^3) sigmatilde[x, F][[
                  i]], sigmatilde[x, 
                F][[3]] - 
            x[[3]] (∑_(i = 1)^3) sigmatilde[x, F][[
                  i]]} ;

RPCharacterization[EP] = Nash  ;

Pairwise Difference Dynamic

rho[x_, 
          F_] := {{0, 
            Max[F[x][[2]] - F[
                    x][[1]], 0], 
            Max[F[x][[3]] - F[
                    x][[1]], 
              0]}, {Max[F[
                    x][[1]] - F[
                    x][[2]], 0], 0, 
            Max[F[x][[3]] - F[
                    x][[2]], 
              0]}, {Max[F[
                    x][[1]] - F[
                    x][[3]], 0], 
            Max[F[x][[2]] - F[
                    x][[3]], 0], 
            0}};

PD[x_, F_] := 
        Transpose[rho[x, F]] .  
            x - {{x[[1]], 0, 0}, {0, 
                x[[2]], 0}, {0, 0, 
                x[[3]]}} . 
            rho[x, F] . {1, 1, 1} ;

RPCharacterization[PD] = Nash ;

Pairwise Comparison Dynamic

Here one specifies the vector field rho that defines an excess payoff dynamic.  When computing rest points, the program assumes that rho is separable and sign-preserving, so that the rest points of the dynamic are the Nash equilibria of the underlying game.

rho1[x_, 
          F_] := {{0, 
            Max[F[x][[2]] - F[
                    x][[1]], 0], 
            Max[F[x][[3]] - F[
                    x][[1]], 
              0]}, {Max[F[
                    x][[1]] - F[
                    x][[2]], 0], 0, 
            Max[F[x][[3]] - F[
                    x][[2]], 
              0]}, {Max[F[
                    x][[1]] - F[
                    x][[3]], 0], 
            Max[F[x][[2]] - F[
                    x][[3]], 0], 
            0}};

PC[x_, F_] := 
        Transpose[rho1[x, F]] .  
            x - {{x[[1]], 0, 0}, {0, 
                x[[2]], 0}, {0, 0, 
                x[[3]]}} . 
            rho1[x, F] . {1, 1, 1} ;

RPCharacterization[PC] = Nash ;

Projection Dynamic

closetozero = 10^(-8) ;

πbir[{aa_, bb_, cc_}, F_] := 
        Evaluate[
          Which[aa > closetozero && bb > closetozero  &&  
              cc > closetozero ,  F[{aa, bb, cc}],  
            aa > closetozero  &&  bb > closetozero  &&  
              cc ≤  
                closetozero ,  {F[{aa, bb, 
                    cc}][[1]], F[{aa, bb, cc}][[2]], F[{aa, bb, 
                    cc}][[3]]}, 
            aa > closetozero  &&  bb ≤ closetozero  &&  
              cc >  closetozero, {F[{aa, bb, 
                    cc}][[1]], F[{aa, bb, cc}][[3]], F[{aa, bb, 
                    cc}][[2]]}, 
            aa ≤  closetozero  && bb > closetozero  &&  
              cc >  closetozero, {F[{aa, bb, 
                    cc}][[2]], F[{aa, bb, cc}][[3]], F[{aa, bb, 
                    cc}][[1]]}, 
            aa > closetozero  && bb ≤  closetozero  &&  
              cc ≤  
                closetozero   &&  F[{aa, bb, 
                      cc}][[2]] ≥  F[{aa, bb, 
                      cc}][[3]], {F[{aa, bb, cc}][[1]], F[{aa, bb, 
                    cc}][[2]], F[{aa, bb, cc}][[3]]}, 
            aa > closetozero  && bb ≤  closetozero  &&  
              cc ≤  
                closetozero  &&  F[{aa, bb, 
                      cc}][[2]] <  F[{aa, bb, cc}][[3]], {F[{aa, bb, 
                    cc}][[1]], F[{aa, bb, cc}][[3]], F[{aa, bb, 
                    cc}][[2]]}, 
            aa ≤  closetozero  && 
              bb ≤  closetozero  &&  
              cc  > 
                closetozero   &&  F[{aa, bb, 
                      cc}][[1]] ≥  F[{aa, bb, 
                      cc}][[2]], {F[{aa, bb, cc}][[3]], F[{aa, bb, 
                    cc}][[1]], F[{aa, bb, cc}][[2]]}, 
            aa ≤  closetozero  && 
              bb ≤  closetozero  &&  
              cc >  closetozero   &&  F[{aa, bb, 
                      cc}][[1]] <  F[{aa, bb, cc}][[2]], {F[{aa, bb, 
                    cc}][[3]], F[{aa, bb, cc}][[2]], F[{aa, bb, 
                    cc}][[1]]}, 
            aa ≤  closetozero  && bb >  closetozero  &&  
              cc  ≤ 
                closetozero  &&   F[{aa, bb, 
                      cc}][[3]] ≥  F[{aa, bb, 
                      cc}][[1]], {F[{aa, bb, cc}][[2]], F[{aa, bb, 
                    cc}][[3]], F[{aa, bb, cc}][[1]]}, 
            aa ≤  closetozero  && bb >  closetozero  &&  
              cc  ≤ 
                closetozero  &&   F[{aa, bb, 
                      cc}][[3]] <  F[{aa, bb, cc}][[1]], {F[{aa, bb, 
                    cc}][[2]], F[{aa, bb, cc}][[1]], F[{aa, bb, 
                    cc}][[3]]}] ] ;

    
InUse[{aa_, bb_, cc_}] :=  
        Evaluate[
          If[aa > closetozero, 1, 0] + If[bb > closetozero, 1, 0] + 
            If[cc > closetozero, 1, 0]] ;

    
sstar[{aa_, bb_, cc_}, F_] :=  ( s = InUse[{aa, bb, cc}] ;  
          Do[ Evaluate[If[s ≥ 3, s = 3;  Break[], s = s]]; 
            Evaluate[
              If[(1/s) (∑_(j = 1)^s) πbir[{aa, bb, cc}, 
                          F][[
                        j]]  ≤ πbir[{aa, bb, cc}, F][[s + 
                      1]] , s = s + 1]],  {i, 3}]; 
          Return[s]) ;

    
Projection[{aa_, bb_, cc_}, 
          F_] := {Evaluate[
            If[(aa > 
                    closetozero  ||  (F[{aa, bb, 
                            cc}][[1]] ≥ ((1/sstar)[{aa, bb, cc}, 
                                F] ((∑_(j = 1)^(sstar[{aa, bb, cc}, F]))πbir[{aa, bb, cc}, 
                                  F][[j]])))), F[{aa, bb, 
                      cc}][[1]] - ((1/sstar)[{aa, bb, cc}, 
                          F] ((∑_(j = 1)^(sstar[{aa, bb, cc}, F]))πbir[{aa, bb, cc}, 
                            F][[j]])), 0]], Evaluate[
            If[(bb > 
                    closetozero  ||  (F[{aa, bb, 
                            cc}][[2]] ≥  ((1/sstar)[{aa, bb, cc}, 
                                F] ((∑_(j = 1)^(sstar[{aa, bb, cc}, F]))πbir[{aa, bb, cc}, 
                                  F][[j]])))), F[{aa, bb, 
                      cc}][[2]] - ((1/sstar)[{aa, bb, cc}, 
                          F] ((∑_(j = 1)^(sstar[{aa, bb, cc}, F]))πbir[{aa, bb, cc}, 
                            F][[j]])), 0]], Evaluate[
            If[(cc > 
                    closetozero  ||  (F[{aa, bb, 
                            cc}][[3]] ≥  ((1/sstar)[{aa, bb, cc}, 
                                F] ((∑_(j = 1)^(sstar[{aa, bb, cc}, F]))πbir[{aa, bb, cc}, 
                                  F][[j]])))), F[{aa, bb, 
                      cc}][[3]] - ((1/sstar)[{aa, bb, cc}, 
                          F] ((∑_(j = 1)^(sstar[{aa, bb, cc}, F]))πbir[{aa, bb, cc}, F][[
                          j]])), 
              0]] } ;

RPCharacterization[Projection] = Nash ;

Selection-mutation

SelMut[MM_][x_, F_] :=  
        Transpose[
              MM]  .  {{x[[1]], 0, 0}, {0, x[[2]], 0}, {0, 0, 
                x[[3]]}} . F[x] - (x . F[x]) x ;

RPCharacterization[SelMut[___]] = 
        Automatic ;

Other

Define any other dynamic you want to use. When defining be sure you follow same style with previously defined dynamics. Otherwise, you may need to do major changes in the program.

Other[x_, 
          F_] := {x[[1]]  Fhat[x, 
                F][[1]], 
          x[[2]]  Fhat[x, 
                F][[2]], 
          x[[3]]  Fhat[x, 
                F][[3]]};

RPCharacterization[Other] = Automatic  ;

Choice of contour function

Choose a contour function here.  To use one of the built-in contour functions,  select the rhs of "SimplexContourFunction = xxx" (excluding the semicolon) and then press the button corresponding to the contour function you desire.  If you choose StableGameLyapunov[Dynamic], the program will use the Lyapunov function that is appropriate for the dynamic you selected in the previous section.  SphereContourFunction is used for phase diagrams drawn on the surface of the sphere (see the next section).

({{Speed}, {L1Speed}, {RSSpeed}}) ({{NormalFormPotential}, {CongestionPotential}, {NormalFormLogitPotential}, {CongestionLogitPotential}}) ({{StableGameLyapunov[Dynamic]}})

SimplexContourFunction = Speed ;

SphereContourFunction = Speed ;

Definitions of contour functions

Speed functions

Speed is the standard (Euclidean) speed on the simplex.  L1Speed is self-explanatory.   RSSpeed is the speed of the replicator dynamic after solution trajectories have been moved to the sphere.

Speed[{x_, y_, z_}] :=   If[ Dynamic ===  Projection, 
          Sqrt[(PhiF[{x, y, z}, F][[1]]^2 + PhiF[{x, y, z}, F][[2]]^2 + PhiF[{x, y, z}, F][[3]]^2) ], 
          Sqrt[(Dynamic[{x, y, z}, F][[1]]^2 + Dynamic[{x, y, z}, F][[2]]^2 + Dynamic[{x, y, z}, F][[3]]^2) ]  ] ;

RSSpeed[{x_, y_, z_}] := 
        Sqrt[x (((F[{x, y, z}][[1]] - Fbar[{x, y, z}, F]))^2) + 
            y (((F[{x, y, z}][[2]] - Fbar[{x, y, z}, F]))^2) + 
            z (((F[{x, y, z}][[3]] - Fbar[{x, y, z}, F]))^2)];

L1Speed[{x_, y_, z_}] := 
        Abs[Dynamic[{x, y, z}, F][[1]]] + 
          Abs[Dynamic[{x, y, z}, F][[2]]] + 
          Abs[Dynamic[{x, y, z}, F][[3]]] ;

Potential functions

NormalFormPotential[
          x_] :=  .5 (x . (A . x )) ;

NormalFormLogitPotential[
          x_] :=  .5 (x . (A . x )) - η (∑_(i = 1)^3) 
                  x[[i]] 
                Log[Max[
                    x[[
                      i]],  .0000000001]] ;

CongestionLogitPotential[
          x_] := -(∑_(i = 1)^(Dimensions[Φ[1]][[1]]))(∫_0^(u[Φ[1][[i]], x]))cost[Φ[1][[i]]][
                    z] \[DifferentialD]z - (∑_(i = 1)^(Dimensions[Φ[2]][[1]]))(∫_0^(u[Φ[2][[i]], x]))cost[Φ[
                        2][[i]]][
                  z] \[DifferentialD]z - (∑_(i = 1)^(Dimensions[Φ[3]][[1]]))(∫_0^(u[Φ[3][[i]], x]))cost[Φ[3][[i]]][
                  z] \[DifferentialD]z  - η (∑_(i = 1)^3) 
                  x[[i]] 
                Log[Max[
                    x[[
                      i]],  .0000000001]] ;

CongestionPotential[
          x_] := -(∑_(i = 1)^(Dimensions[Φ[1]][[1]]))(∫_0^(u[Φ[1][[i]], x]))cost[Φ[1][[i]]][
                    z] \[DifferentialD]z - (∑_(i = 1)^(Dimensions[Φ[2]][[1]]))(∫_0^(u[Φ[2][[i]], x]))cost[Φ[
                        2][[i]]][
                  z] \[DifferentialD]z - (∑_(i = 1)^(Dimensions[Φ[3]][[1]]))(∫_0^(u[Φ[3][[i]], x]))cost[Φ[3][[i]]][
                  z] \[DifferentialD]z ;

Lyapunov functions

NEQ = If[findnashequilibria == 1, NashEq[F]] ;

StableGameLyapunov[Replicator][
          x_] := - (∏_(i = 1)^3) x[[i]]^NEQ[[1, i]]   ;

StableGameLyapunov[Logit[η]][
          x_] :=  η Log[(∑_(i = 1)^3) (E^(F[x][[i]]/η))] - (x . 
                F[x] - η (∑_(i = 1)^3) x[[
                      i]] 
                    Log[Max[x[[i]], 
                        10^(-7)]]) ;

StableGameLyapunov[BNN][
          x_] := (∑_(i = 1)^3) Fhatplus[x, F][[i]]^2  ;

StableGameLyapunov[PD][
          x_] := (∑_(i = 1)^3) x[[
              i]] (∑_(j = 1)^3)(((Max[F[x][[j]] - F[x][[i]], 0]))^2)  ;

StableGameLyapunov[Projection][
          x_] := (Sqrt[(x - NEQ[[1]]) . (x - NEQ[[1]]) ]) ;

Other contour functions

Define your own contour function here.

Other[{x_, y_, z_}] := 0 ;

Specification of graphical output

Shared parameters for contour function output

These parameters are used for contour function output in all of the types of diagrams described below.  If you do not include contour functions in your output, these parameters are not used.
color = 1 generates color output; color = 0 generates black and white.  The scales used are drawn below.
colorbar = 1 to create a color scale (alternatively, a black and white scale) along with your contour plot.
plotprecision specifies the number of points sampled in each dimension when drawing the contour plots.  Typicaly, this option is the main determinant of the program's running time.  Settings between 50 and 200 are accurate enough for most purposes.  For fast drafts a setting of 20 is adequate.
numberofcontours specifies the number of contour levels shown in the contour plots.
showcontourformula = 1 displays the formula for the contour function in the output notebook.

color = 1 ; 
colorbar = 0 ;
plotprecision = 70 ;
numberofcontours = 200 ;
showcontourformula = 1 ;

Vector field diagram

vectorfielddiagram = 1 draws a vector field diagram on the simplex.  The vector fields should take values in the tangent space of the simplex (i.e., values whose components sum to zero).  
drawoncontour = 1 draws the vector field on top of a contour plot.

vectorfielddiagram = 1 ;
drawoncontour = 0 ;

Instructions for specification of vector fields

Either one or two vector fields is drawn, according to whether drawvectorfield1, drawvectorfield2, or both are set to 1.
vectorfield? specifies the vector field to be drawn.  (Here and below, "?" equals 1 or 2.)  Common specifications for this are Dynamic (the dynamic specified in the "Choice of dynamic" section) and PhiF (the projection of the payoff vector field onto the tangent space of the simplex - see "Payoff-related definitions" in the "Choice of game"section).
scale? rescales the vectors, as is often needed to prevent the vector field arrows from being too long.  The program calibrates the output so that setting scale1 = scale2 makes the longest vector in each vector field have the same length.
vf?thickness is the thickness of the "shafts" of the arrows.
arrowheadlengtsvf? is self-explanatory; set it to zero if you do not want arrowheads.
colorvf? determines the color of the vector field.  It should be set to Hue[t] or GrayLevel[t] using the charts below.

The base points for the vectors in the diagram can be chosen from a grid 
(i) with the grid including points on the boundary (i.e., the dots in the diagram below);
(ii) with the grid excluding points on the boundary (i.e.,the "x"s in the diagram below).
Option (i) is the default setting.
To switch options, select the rhs of "datavf = ..." (excluding the semicolon) and press the appropriate palette button.
gridpoints1dvf specifies the number of initial conditions on each boundary of the grid.
drawrestpoints = 1 causes the rest points of the dynamic to be drawn on the diagram.
arrowsfromrestpoints = 1 causes vector field arrows to be drawn from the rest points (in addition to all other arrows).

drawvectorfield1 = 1 ;
vectorfield1 = PhiF ;
vf1thickness =  .001 ;
scale1 =  .1 ;
arrowheadlengthvf1 =  .01 ;
colorvf1 =  Hue[ .64] ;

drawvectorfield2 = 1 ;
vectorfield2 = Dynamic ;
vf2thickness =  .001 ;
scale2 =  .1 ;
arrowheadlengthvf2 =  .01 ;
colorvf2 =  Hue[ .84] ;

    
gridpoints1dvf =  25 ;

    
drawrestpoints = 0 ;
arrowsfromrestpoints =  0 ;

({{Grid initial conditions (boundary included) }, {Grid initial conditions (boundary excluded)}, {}})

datavf = 
        Flatten[Table[{(i/gridpoints1dvf), 
              1 - (( i)/gridpoints1dvf) - (j/gridpoints1dvf), 
              (j/gridpoints1dvf)}, {i, 0, gridpoints1dvf, 1}, {j, 0, 
              gridpoints1dvf - i, 1}] , 1];

Phase diagram

phasediagram = 1 creates a phase diagram on the simplex.  The solution trajectories to be included are specified below.
includecontourplot = 1 draws the phase diagram on top of a contour plot.
ppoints determines how many points will be used when drawing the solution trajectories.

phasediagram = 1 ;
includecontourplot = 1 ;
ppoints = 50 ;

Instructions for "automated" specification of solution trajectories

This section specifies the solution trajectories to be included in the phase diagram using built-in specifications.  These are of three types:
(i) initial conditions drawn from a grid, with the grid including points on the boundary (i.e., the dots in the diagram below);  
(ii) initial conditions drawn from a grid, with the grid excluding points on the boundary (i.e., the "x"s in the diagram below);
(iii) randomly chosen initial conditions.  
To use one of these options, select the rhs of "data = ..." (excluding the semicolon) and then press the appropriate palette button.
endtime determines the time interval [0, endtime] of each solution.  
For the grid options, gridpoints1d specifies the number of initial conditions on each boundary of the grid.  
For the random option, randompoints specifies the number of random initial conditions.
numberofarrows specifies how many arrows to draw on each solution.  
arrowheadlength is self-explanatory; it can be set to zero if arrowheads are not desired.  
If numberofarrows = 1 is specified, the arrow appears at the end of each solution trajectory.  If numberofarrows = n, arrows are drawn at times {endtime/n,  2 endtime/n, ... , endtime}.  For more on how arrows are drawn, see "Adjusting positions of arrow heads and 'tails'" below.

Instructions for "manual" specification of solution trajectories

The user can also specify which solution trajectores to graph directly.  To do this, data must be defined as a table of the following form: {{{initial condition 1}, T1, {color1, thickness1, dashing1},{Arrow positions 1}, {Head lengths 1}}, {{initial condition 2}, T2, {color2, thickness2, dashing2}, {Arrow positions 2}, {Head lengths 2}}, ... }
Each initial condition is entered as a vector in the simplex (e.g.,{1/3, 1/3, 1/3}).  Ti determines time interval [0, Ti] of the ith solution.  Arrow positions i and Head lengths i should be vectors of the same length, where this length is the number of arrowheads to be drawn on the solution trajectory.  Arrow positions are stated as points in the time interval [0, Ti].  For no arrows, set Arrow positions i and Head lengths i to {0}.  

{colori, thicknessi, dashingi} specifies the appearance of solutions trajectories.  You can specify any collection of graphics primitives you like (even ones beyond the three mentioned here), and you canplace them in any order.  To use the default appearance, write {}. 
colori can be Hue[?], GrayLevel[?] or any other color command.
thicknessi can be Thickness[?] or AbsoluteThickness[?].
dashingi is spcified as Dashing[{???}].

endtime = 1 ; 

    gridpoints1d = 14 ; 

    randompoints = 6 ;

    

    numberofarrows = 1 ;

    arrowheadlength =  .025 ;

({{Grid initial conditions (boundary included)}, {Grid initial conditions (boundary excluded)}, {Random initial conditions}})

data = 
        Flatten[Table[{{((1 + 3 i)/(3 gridpoints1d)), -((2 - 
                        3 gridpoints1d + 3  i + 
                        3 j)/(3 gridpoints1d)), ((1 + 3 j)/(3 gridpoints1d))}, endtime, {}, 
              Table[(((numberofarrows - i + 1) endtime)/numberofarrows), {i, numberofarrows}] , 
              Table[arrowheadlength, {i, numberofarrows}]}, {i, 0, 
              gridpoints1d, 1}, {j, 0, gridpoints1d - 1 - i, 1}] , 
          1] ;

Tuning rest point search

RestSearchInit contains the initial conditions used in the FindRoot command when the program searches for rest points.  If you suspect that the program has missed some rest points, add initial conditions in the regions where the missing rest points should be.  Each initial condition is written as {x1, x2}; x3 is computed as 1 - x1 - x2.
RestTolerance is a parameter in a filtering procedure used to eliminate false rest points.  If the speed of the dynamic at a prospective rest point is above (RestTolerance) * (the maximum speed of the dynamic), the prospective rest point is thrown out.

RestSearchInit = {{0, 0}, {0, 0.1}, {0, 0.2}, {0, 0.3}, {0, 0.4}, {0, 
            0.5}, {0, 0.6}, {0, 0.7}, {0, 0.8}, {0, 0.9}, {0.1, 0}, {0.1, 
            0.1}, {0.11, 0.21}, {0.1, 0.3}, {0.1, 0.4}, {0.1, 0.5}, {0.1, 
            0.6}, {0.1, 0.7}, {0.1, 0.8}, {0.2, 0}, {0.2, 0.1}, {0.2, 
            0.2}, {0.2, 0.3}, {0.2, 0.4}, {0.2, 0.5}, {0.2, 0.6}, {0.2, 
            0.7}, {0.3, 0}, {0.3, 0.1}, {0.3, 0.2}, {0.3, 0.3}, {0.3, 
            0.4}, {0.3, 0.5}, {0.3, 0.6}, {0.4, 0}, {0.4, 0.1}, {0.4, 
            0.2}, {0.4, 0.3}, {0.4, 0.4}, {0.4, 0.5}, {0.5, 0}, {0.5, 
            0.1}, {0.5, 0.2}, {0.5, 0.3}, {0.5, 0.4}, {0.6, 0}, {0.6, 
            0.1}, {0.6, 0.2}, {0.6, 0.3}, {0.7, 0}, {0.7, 0.1}, {0.7, 
            0.2}, {0.8, 0}, {0.8, 0.1}, {0.9, 
            0}, { .98,  .01}, { .54,  .27}, { .7,  .3}};

RestTolerance =  .01 ;

Tuning stability tests

The first four parameters determine how rest points are checked for stability.  The parameter numtest specifies how many trajectories will be checked.  These initial conditions are random points at distance eps from the rest point.  Solutions from these points over the time interval [0, bigT] are computed.  If any of these solutions winds up more than delta away from the rest point, the rest point is considered unstable; otherwise it is considered stable.

numtest = 5 ; 

    eps =  .01 ; 

    delta =  .008 ;

    bigT = 1 ;

Adjusting positions of arrow heads and "tails"

To draw an arrow, the program must know where to put the tail of the arrow and where to put the head.  Even if one does not want the base of the arrow to appear in the picture, its position of the tail must be specified so that the arrow points in the right direction.  
The parameter relarrowbase below determines the positions of arrows' tails relative to their heads when arrows are drawn on solution trajectories.  In particular, if an arrow is supposed to appear at a solution trajectory's position at time t, the program draws the head at this point, placing the tail at the solution trajectory's position at time (t – endtime/relarrowbase).  
A value of .008 for relarrowbase works well in most cases:  the arrow base is not visible, and the arrow points in the right direction.  If arrow bases are visible, a smaller value of relarrowbase should be specified.  If arrows point in the wrong directions, a larger value of relarrowbase should be chosen.
The parameter arrowheadcenter  specifies the location of the center of the arrowheads' bases as a fraction of the arrowheads' lengths.

relarrowbase =  .005 ;
arrowheadcenter =  .8 ;

Adding extra graphic elements

This section allows the user to add dots, lines, arrows, text, and color solution trajectories to a phase diagram/contour plot.

Enter the data for dots as follows:  dotdata = {{center1, radius1, color1, open1}, {center2, radius2, color2, open2}, ...}. color1 should be a Mathematica-defined color function (Hue[.], GrayLevel[.], etc).  Set open1 = 0 for solid dot and = 1 for a dot with a white center.
 
Enter the data for lines as follows:  linedata = {{startingpoint1, endpoint1, thickness1, dashing1, color1, arrowheadlength1}, {startingpoint2, endpoint2, thickness2, dashing2, color2, arrowheadlength2},...}.  If you want an arrow at the end of the line enter the value for arrowheadlength specifying the size of arrow head; if you do not want an arrow simply set it to 0. Thickness and Dashing are usual Mathematica commands. If you want to enter position using simplex coordinates, you can directly enter the value (e.g.,{0, 1, 0}).  Otherwise, 2d coordinates can must be used with "old" command:  for example, the bottom-left vertex is at old[{0, 0}] (={0,1,0}).

Enter data for text as follows:  textdata = {{"label1", position1, "fontfamily1","fontslant1", fontsize1}, {"label2", position2, "fontfamily2","fontslant2", fontsize2}, ...}. Remember that you are restricted to positions in PlotRange -> {{-.08, 1.08}, {-.04, .95}}.   If you want to enter position using simplex coordinates, use the "new" command (e.g., new[{0, 1, 0}]).  Otherwise, 2d coordinates can be used:  in this case, the bottom-left vertex is at {0, 0}, the bottom right vertex at {0, 1}, and the top vertex at {1/2,  (Sqrt[3])/2} ≈ (.5, .8660). 

Enter data for extra solution trajectories as follows:  cycledata = {{initial condition on simplex 1, endtime1 for NDSolve, beginningtime1 to be used in in the plot, {color1, thickness1}, {arrow position1}, {head lengths1}}, {initial condition on simplex 2, endtime2 for NDSolve, beginningtime2 to be used in in the plot, {color2, thickness2}, {arrow position2}, {head lengths2}},...}. 
The program computes a solution to the dynamic from time 0 through endtime?, and then plots the solution trajectory from the beginingtime? through endtime.   color? should be a Mathematica-defined color function (Hue[.], GrayLevel[.], etc) (both color and thickness can be ignored, just write {} if you do not want to bother with these.  arrowpositon? must be a number strictly greater than beginingtime? and less than endtime (it must be strictly bigger than begining time).  Each trajectory can have multiple arrows, but even if there is only one arrow, be sure to put brackets around the arrow positions and head lengths.

Write dotdata = {},  linedata = {}, textdata = {}, and cycledata = {} if you do not want to add anything.  (This is the default setting.)

Example:  This example generates one line, one dot, and one piece of text, one special solution trajectory (cycledata).
dotdata={{{1/3, 1/3, 1/3}, .01, GrayLevel[0], 1}} ;    [draws a black dot with white center at the center of the simplex]
linedata={{{1/2, 0, 1/2},{1/2, 1/2, 0}, Thickness[.004], Dashing[{}], GrayLevel[0], 0}} ;   [draws a horizontal line through at x1=1/2]
textdata={{"trial", new[{1/3, 1/3, 1/3}], "Palatino-Roman", "Plain", 12}} ; 
cycledata={{{.8, .1, .1}, 50, 45, {Hue[.83], Thickness[.005]}, {47}, {.03}}} ;

dotdata = {};
linedata = {};
textdata = {};
cycledata = {} ;

uddots = 
        Graphics[
          Table[{dotdata[[i, 3]], 
              Disk[new[dotdata[[i, 1]]], 
                dotdata[[i, 2]]]}, {i, Dimensions[
                  dotdata][[1]]}]] ;
udwdots = 
        Graphics[
          DeleteCases[
            Table[If[
                dotdata[[i, 4]] == 1, {GrayLevel[1], 
                  Disk[new[
                      dotdata[[i, 1]]],  .6 dotdata[[i, 
                          2]]]}], {i, Dimensions[dotdata][[1]]}], 
            Null]] ;
extralines = 
        Graphics[
          DeleteCases[
            Table[{linedata[[i, 3]], linedata[[i, 4]], 
                linedata[[i, 5]], 
                Arrow[new[linedata[[i, 1]]], new[linedata[[i, 2]]], 
                  HeadCenter ->  4/5, 
                  HeadLength -> linedata[[i, 6]]]}, {i, Dimensions[
                    linedata][[1]]}], 
            Null]] ;
extratext = 
        Graphics[
          DeleteCases[
            Table[{Text[textdata[[i, 1]], textdata[[i, 2]], 
                  TextStyle -> {FontFamily -> textdata[[i, 3]], 
                      FontSlant -> textdata[[i, 4]], 
                      FontSize -> 
                        textdata[[i, 5]]}]}, {i, Dimensions[
                    textdata][[1]]}], Null]];

Phase diagram on the surface of the sphere

spherecontour = 1 generates a contour plot on the sphere, which is obtained by mapping vectors {x[[1]], x[[2]], x[[3]]} in the simplex to vectors {(Sqrt[x])[[1]], (Sqrt[x])[[2]], (Sqrt[x])[[3]]} on the sphere. 
viewray defines the ray from the origin from which the sphere is viewed; it should be set to some nonnegative vector.
viewraydot = 1 draws a dot at the point where the view ray hits the surface of the sphere.
Other parameters (e.g., solution trajectories) are borrowed from the previous subsection.

spherecontour = 
        0 ;  

viewray = {5, 1, 1} ; 
viewraydot = 1 ;

3D graph of the contour function

graphcontour3d = 1 creates a 3d plot of the contour function. 
shiftpercentage specifies the distance above the simplex that the lowest point on the contour function will appear, as a percentage of the distance from the minimum value of the function to the maximum value of the function.
grayline = 1 draws a gray line on the edges of the 3d plot.
heightratio specifies the ratios of the three coordinates in the graphical output.  The default setting is {1, 1, 1.25}.
  
vpoint determines the value for the Mathematica command ViewPoint and hence the point from which the 3d plot is observed.  In Mathematica, ViewPoint -> {x, y, z} gives the position of the view point relative to the center of the three-dimensional box that contains the object being plotted.  The view point is given in a special scaled coordinate system in which the longest side of the bounding box has length 1.  (When heightratio is at its default setting of {1, 1, 1.25}, the longest side corresponds to the z coordinate.  The center of the bounding box is taken to have coordinates {0, 0, 0}. Choosing ViewPoint further away from the object reduces the distortion associated with perspective.

graphcontour3d = 0 ;

    
grayline = 1 ;
shiftpercentage =  .2 ;
heightratio = {1, 1, 1.25} ;
vpoint = {-2.730,  -1.673,  1.096} ;

Program Core

Solving the differential equation

time1 = TimeUsed[] ;

x[t] = {x1[t], x2[t], 1 - x1[t] - x2[t]} ;

G=If[Dynamic ===  Projection,Table[NDSolve[{x1'[t]==Dynamic[x[t], 
                              F][[1]],x2'[t]==Dynamic[x[t], 
                              F][[2]],x1[0] == data[[i, 
                              1]][[1]],x2[
                            0] == data[[i, 
                              1]][[2]]},{x1, x2},{t, 0, 
                      data[[i, 2]]},PrecisionGoal ->  10, MaxSteps ->  5000,SolveDelayed ->  True],{i, Dimensions[
                      data][[1]]}],Table[NDSolve[{x1'[t]==Dynamic[x[t], 
                              F][[1]],x2'[t]==Dynamic[x[t], 
                              F][[2]],x1[0] == data[[i, 
                              1]][[1]],x2[
                            0] == data[[i, 
                              1]][[2]]},{x1, x2},{t, 0, 
                      data[[i, 2]]}],{i, Dimensions[
                      data][[1]]}] ];

GCycle=If[Dimensions[
                  cycledata][[1]] == 0,{},Table[NDSolve[{x1'[t]==Dynamic[x[t], 
                              F][[1]],x2'[t]==Dynamic[x[t], 
                              F][[2]],x1[0] == cycledata[[i, 
                              1]][[1]],x2[
                            0] == cycledata[[i, 
                              1]][[2]]},{x1, x2},{t, 0, 
                      cycledata[[i, 
                        2]]}],{i, Dimensions[
                      cycledata][[1]]}]] ;

Plotting the solutions

If[vectorfielddiagram == 0,  drawvectorfield1 = 0 ;  
        drawvectorfield2 = 0 ] ;

    
If[phasediagram == 0, includecontourplot = 0] ;

Rest points and stability test

TolLevel = 
        Times[RestTolerance,  
          Max[Flatten[
              Table[Chop[Speed[Chop[{i, j, 1 - i - j}, (10^(-5))]], 
                  (10^(-5))], {i, 0, 1,  .05}, {j, 0, 
                  1 - i,  .05}]]]]  ;

If[findrestpoints ==  1, 
        RePos = RestPoints[Dynamic, F, RestSearchInit, TolLevel] ; 
        TestStability[Dynamic, F, bigT,  numtest,  eps,  delta, 
          RestSearchInit, TolLevel] ] ;

Drawing vector fields on the simplex

Needs["Graphics`PlotField`"] ;

If[
        vectorfielddiagram == 
            1  &&  (drawvectorfield1 == 1  ||  
              drawvectorfield2 == 1),  
colvf1[
            dum_] = colorvf1 ; 
colvf2[dum_] = 
          colorvf2 ; 

If[
          drawvectorfield1 == 0, vectorf1 = Graphics[{}], 
          vectorf1 = 
            ListPlotVectorField[ 
              If[findrestpoints == 1  &&  
                  arrowsfromrestpoints == 1, 
                Join[Table[{new[datavf[[i]]], 
                      new[vectorfield1[datavf[[i]], F]] - {1, 
                          0}}, {i, Dimensions[datavf][[1]]}],  
                  Table[{new[testrest[[i]]], 
                      new[vectorfield1[testrest[[i]], F]] - {1, 
                          0}}, {i, Dimensions[testrest][[1]]}] ],  
                Table[{new[datavf[[i]]], 
                    new[vectorfield1[datavf[[i]], F]] - {1, 
                        0}}, {i, Dimensions[datavf][[1]]}] ], 
              ScaleFactor ->  scale1 , 
              HeadCenter -> arrowheadcenter, 
              HeadLength ->  arrowheadlengthvf1,  
              ColorFunction ->  ({colvf1[#] , 
                      Thickness[vf1thickness]} &),  
              DisplayFunction ->  
                Identity ] ] ; 

If[
          drawvectorfield2 == 0, vectorf2 = Graphics[{}], 
          vectorf2 = 
            ListPlotVectorField[
              If[findrestpoints == 1  &&  
                  arrowsfromrestpoints == 1,  
                Join[Table[{new[datavf[[i]]], 
                      new[vectorfield2[datavf[[i]], F]] - {1, 
                          0}}, {i, Dimensions[datavf][[1]]}],  
                  Table[{new[testrest[[i]]], 
                      new[vectorfield2[testrest[[i]], F]] - {1, 
                          0}}, {i, Dimensions[testrest][[1]]}] ],  
                Table[{new[datavf[[i]]], 
                    new[vectorfield2[datavf[[i]], F]] - {1, 
                        0}}, {i, Dimensions[datavf][[1]]}] ], 
              ScaleFactor ->  scale2, 
              ColorFunction ->  ({colvf2[#], 
                      Thickness[vf2thickness]}  &),  
              HeadCenter -> arrowheadcenter, 
              HeadLength ->  arrowheadlengthvf2,  
              DisplayFunction ->  Identity] ] ] ;

Drawing Solutions to Diff Eqs if there is no contour plot

e = 
        Table[ParametricPlot[
            Evaluate[new[{x1[t], x2[t]}] /. G[[i]]], {t, 
              0, data[[i, 2]]},  DisplayFunction  ->  Identity, 
            PlotPoints ->  ppoints,  Axes -> {False, False}, 
            PlotRange -> {{- .08, 1.08}, {- .04,  .95}}, 
            PlotStyle ->  {data[[i, 
                  3]]}, 
            AspectRatio -> 
              Automatic], {i, Dimensions[
                data][[1]]}] ;

ecycle = 
        If[Dimensions[
                cycledata][[1]] == 0, Graphics[{}], 
          Table[ParametricPlot[
              Evaluate[
                new[{x1[t], 
                      x2[t]}] /. GCycle[[
                    i]]], {t, 
                cycledata[[i, 3]], 
                cycledata[[i, 2]]},  
              DisplayFunction  ->  Identity, 
              PlotPoints ->  ppoints,  Axes -> {False, False}, 
              PlotRange -> {{- .08, 1.08}, {- .04,  .95}}, 
              PlotStyle ->  {cycledata[[i, 
                    4]]}, 
              AspectRatio -> 
                Automatic], {i, Dimensions[
                  cycledata][[1]]}]] ;

Drawing Triangle and Dots

The cells belongs to this group is for drawing white area around the simplex.

b = new[{0, 1, 0}];
a = new[{1, 0, 0}];
c = new[{0, 0, 1}];
Tri = Graphics[Line[{b, a, c, b}]];
leftri = 
        Graphics[{GrayLevel[1], 
            Polygon[{{- .08, - .04}, {- .08,  .95}, { .5,  .95}, 
                a, {0, 0}, {- .08, - .04}}]}];
rightri = 
        Graphics[{GrayLevel[1], 
            Polygon[{{ .5,  .95}, {1.095,  .95}, {1.095, - .04}, c, 
                a, { .5,  .95}}]}];

    
downl = 
        Graphics[{GrayLevel[1], 
            Polygon[{{- .08, - .04}, {1.08, - .04}, {1.08, 
                  0}, {- .04, 
                  0}, {- .08, - .04}}]}];

These cells draw a white area around the eighth-sphere

If[
        spherecontour == 
          1, 
di =  .001 ; 
curvedtri = 
          Graphics[{Line[
                Table[SRT[{(Sqrt[i]), (Sqrt[1 - i]), 0}, viewray], {i, 0, 1, di}]], 
              Line[Table[
                  SRT[{(Sqrt[1 - i]), 0, (Sqrt[i])}, viewray], {i, 0, 1, di}]], 
              Line[Table[
                  SRT[{0, (Sqrt[i]), (Sqrt[1 - i])}, viewray], {i, 0, 1, 
                    di}]]}] ; 


fromwmin[1] = 
          Min[Join[
              Table[SRT[{(Sqrt[i]), (Sqrt[1 - i]), 0}, viewray][[1]], {i, 0, 
                  1, 10 di}], 
              Table[SRT[{(Sqrt[1 - i]), 0, (Sqrt[i])}, viewray][[1]], {i, 0, 
                  1, 10 di}], 
              Table[SRT[{0, (Sqrt[i]), (Sqrt[1 - i])}, viewray][[1]], {i, 0, 
                  1, 10 di}]]] ; 
towmax[1] = 
          Max[Join[
              Table[SRT[{(Sqrt[i]), (Sqrt[1 - i]), 0}, viewray][[1]], {i, 0, 
                  1, 10 di}], 
              Table[SRT[{(Sqrt[1 - i]), 0, (Sqrt[i])}, viewray][[1]], {i, 0, 
                  1, 10 di}], 
              Table[SRT[{0, (Sqrt[i]), (Sqrt[1 - i])}, viewray][[1]], {i, 0, 
                  1, 10 di}]]] ; 
fromwmin[2] = 
          Min[Join[
              Table[SRT[{(Sqrt[i]), (Sqrt[1 - i]), 0}, viewray][[2]], {i, 0, 
                  1, 10 di}], 
              Table[SRT[{(Sqrt[1 - i]), 0, (Sqrt[i])}, viewray][[2]], {i, 0, 
                  1, 10 di}], 
              Table[SRT[{0, (Sqrt[i]), (Sqrt[1 - i])}, viewray][[2]], {i, 0, 
                  1, 10 di}]]] ; 
towmax[2] = 
          Max[Join[
              Table[SRT[{(Sqrt[i]), (Sqrt[1 - i]), 0}, viewray][[2]], {i, 0, 
                  1, 10 di}], 
              Table[SRT[{(Sqrt[1 - i]), 0, (Sqrt[i])}, viewray][[2]], {i, 0, 
                  1, 10 di}], 
              Table[SRT[{0, (Sqrt[i]), (Sqrt[1 - i])}, viewray][[2]], {i, 0, 
                  1, 10 di}]]] ; 

leftrisrt = 
          Graphics[{GrayLevel[1], 
              Polygon[Join[
                  Table[SRT[{(Sqrt[i]), (Sqrt[1 - i]), 0}, viewray], {i, 0, 1, 
                      di}], {{SRT[{1, 0, 0}, viewray][[1]], 
                      towmax[2] +  .05}}, {{fromwmin[1] -  .05, 
                      towmax[2] +  .05}}, {{fromwmin[
                          1] -  .05, (fromwmin[2] + towmax[2])/
                        2}}, {{fromwmin[1] -  .05, 
                      fromwmin[2] -  .05}}, {SRT[{0, 1, 0}, 
                      viewray]}]]}]; 

rightrisrt = 
          Graphics[{GrayLevel[1], 
              Polygon[Join[
                  Table[SRT[{(Sqrt[i]), 0, (Sqrt[1 - i])}, viewray], {i, 0, 1, 
                      di}], {{SRT[{1, 0, 0}, viewray][[1]], 
                      towmax[2] +  .05}}, {{towmax[1] +  .05, 
                      towmax[2] +  .05}}, {{towmax[
                          1] +  .05, (fromwmin[2] + towmax[2])/
                        2}}, {{towmax[1] +  .05, 
                      fromwmin[2] -  .05}}, {SRT[{0, 0, 1}, 
                      viewray]}]]}] ; 
downlsrt = 
          Graphics[{GrayLevel[1], 
              Polygon[Join[
                  Table[SRT[{0, (Sqrt[1 - i]), (Sqrt[i])}, viewray], {i, 0, 1, 
                      di}], {{towmax[1] +  .05, 
                      fromwmin[2] -  .05}}, {{(towmax[1] + fromwmin[1])/
                        2, fromwmin[2] -  .05}}, {{fromwmin[1] -  .05, 
                      fromwmin[2] -  .05}}, {SRT[{0, 1, 0}, 
                      viewray]}]]}] ] ;

This part draws the dots for the rest points.  TestStability[Dynamic,F,bigT, numtest, eps, delta,RestSearchInit,TolLevel] must be called in order to determine stability of points.  Hence you may need to modify this part if  StabilityCheck do not work for your choice of dynamic.

If[
        findrestpoints ==  1, 
DOTS = 
          Graphics[
            Table[Disk[
                new[testrest[[i]]], 
                0.01], {i, Dimensions[
                    testrest][[1]]}]] ; 
WDots = 
          Graphics[
            Table[{GrayLevel[1], 
                Disk[new[unstbl[[i]]], 
                  0.006]}, {i, Dimensions[
                    unstbl][[1]]}]], 
        DOTS = Graphics[{}] ;  WDots = Graphics[{}] ] ;

for sphere

If[spherecontour == 1  &&  findrestpoints == 1 ,  
        DOTSsrt = 
          Graphics[
            Table[Disk[
                SRT[(Sqrt[testrest])[[i]], 
                  viewray], 
                0.01], {i, Dimensions[
                    testrest][[1]]}]] ; 
WDotssrt = 
          Graphics[
            Table[{GrayLevel[1], 
                Disk[SRT[(Sqrt[unstbl])[[i]], 
                    viewray], 
                  0.006]}, {i, Dimensions[
                    unstbl][[1]]}]] ;  DOTatOrig = 
          Graphics[{If[color == 1, Hue[ .9], GrayLevel[ .8]], 
              Disk[SRT[{0, 0, 0}, viewray], 0.01]}]  ];

These cells draw the triangle, lines, and dots for the 3D plot of contour function

If[graphcontour3d == 1,  
        graphf[x_]  :=  {new[x][[1]], new[x][[2]], 
            SimplexContourFunction[x]} ; 
graphmin[
            x_]  :=  {new[x][[1]], new[x][[2]], 
            MinAttained - distancefrommin} ; 
Tri3d = 
          Graphics3D[
Line[{{0, 0, 
                  MinAttained - distancefrommin},  {1, 0, 
                  MinAttained - distancefrommin}, {1/2, Sqrt[3]/2, 
                  MinAttained - distancefrommin},  {0, 0, 
                  MinAttained - 
                    distancefrommin} } ]] ; 
If[
          findrestpoints == 1, 
          SeveralLines = 
Graphics3D[ {Dashing[{ .01,   .01}],  Flatten[Table[
                    Line[{graphmin[RePos[[i]]], 
                        graphf[RePos[[i]]]}], {i, 
                      1, Dimensions[RePos][[1]], 
                      1}]]}] ; 

SeveralPoints = 
            Graphics3D[ {PointSize [ .02],  
                Flatten[
                  Table[Point[
                      graphmin[
                        stblpnts[[
                          i]]]], {i, Dimensions[
                          stblpnts][[1]]}]], GrayLevel[ .5], 
                Flatten[
                  Table[Point[
                      graphmin[
                        unstbl[[
                          i]]]], {i, Dimensions[
                          unstbl][[1]]}]]}]]] ;

Drawing Solutions to Diff Eqs on quarter sphere if there is no contour plot

If[spherecontour == 1, 
        eonsphere = 
          Table[ParametricPlot[
              Evaluate[
                Re[SRT[{(Sqrt[x1])[t], (Sqrt[x2])[t], (Sqrt[1 - x1[t] - x2[t]])}, 
                      viewray]] /. G[[i]]], {t, 0, data[[i, 2]]},  
              DisplayFunction  ->  
                Identity,   Axes -> {False, False}, 
              PlotRange -> {{fromwmin[1] -  .05, 
                    towmax[1] +  .05}, {fromwmin[2] -  .05, 
                    towmax[2] +  .05}}, 
              AspectRatio -> 
                Automatic], {i, Dimensions[
                  data][[1]]}] ];

Specifying color scale/gray scale

The approximate minimum and maximum values of the contour function are computed here.  These values are then used to assign colors/gray levels optimally.

If[
        includecontourplot == 1  || drawoncontour == 1 || 
          graphcontour3d  ==  1 ,  
        If[SimplexContourFunction  ===  Speed, MinAttained = 0, 
          nrmlzdmin = 
            Flatten[Table[
                Chop[SimplexContourFunction[
                    Chop[{i, j, 1 - i - j}, (10^(-5))]], (10^(-5))], {i, 0, 
                  1,  .025}, {j, 0, 
                  1 - i,  .025}]] ; 
MinAttained = 
            Min[nrmlzdmin]]] ;

    
If[
        includecontourplot == 1  ||  drawoncontour == 1 || 
          graphcontour3d  ==  1, 
        nrmlzd = 
          Flatten[Table[
              Chop[SimplexContourFunction[
                  Chop[{i, j, 1 - i - j}, (10^(-5))]], (10^(-5))], {i, 0, 
                1,  .025}, {j, 0, 
                1 - i,  .025}]] ; 
MaxAttained = 
          Max[nrmlzd] ] ;

    
distancefrommin = 
        shiftpercentage (MaxAttained - 
              MinAttained) ;

    
btwf[Ψ_] = 
        1 - Max[0, 
            Min[((Ψ - MinAttained)/(MaxAttained - MinAttained)), 1]] ;

    
If[(includecontourplot == 1  || 
              drawoncontour == 1 ||    graphcontour3d  ==  
                1)  &&  color == 0, 
        ConColFun[Ψ_] = 
          GrayLevel[ .(95/1.45) (1 - 
                  btwf[Ψ] +  .45) ]] ;
If[(includecontourplot == 1  || 
              drawoncontour == 1 ||  
              graphcontour3d  ==  1) &&  color == 1, 
        ConColFun[Ψ_] = 
          Hue[ Which[
              btwf[Ψ] ≤ (1/2), (2/5) 
                btwf[Ψ], 
              (1/2) < btwf[Ψ] ≤ 
                (2/3),  (6/5) btwf[Ψ] - (2/5), 
              (2/3) < btwf[Ψ], (3/4) btwf[Ψ] - 
                (1/10)]]] ;

    
If[(includecontourplot == 1  ||  
              drawoncontour == 1) &&  colorbar == 1, 
        simplexcolorbar = 
          If[color == 
              1, {Graphics[({Hue[
                          Which[1 - #1  ≤ 
                              (1/2), (2/5) (1 - #1), 
                            (1/2) < (1 - #1) ≤ 
                              (2/3),  (6/5) (1 - #1) - (2/5), 
                            (2/3) < (1 - #1), (3/4) (1 - #1) - 
                              (1/10)]], 
                        Rectangle[{ .95, ((#1 + 1.5)/3)}, {1, ((#1  + 1.51)/3)}]} &) /@ Range[0, 1,  .01]],  
              Graphics[{Text[
                    PaddedForm[ MinAttained,  {3, 2}], {1.02,  .5}],  
                  Text[PaddedForm[
                      MaxAttained, {3, 
                        2}], {1.02,  .83}]}]}, {Graphics[({GrayLevel[ .(95/1.45) ((#1) +  .45)], 
                        Rectangle[{ .95, ((#1 + 1.5)/3)}, {1, ((#1  + 1.51)/3)}]} &) /@ Range[0, 1,  .01]],  
              Graphics[{Text[PaddedForm[MinAttained, {3, 2}], {1.02,  .5}],  
                  Text[PaddedForm[ 
                      MaxAttained, {3, 2}], {1.02,  .83}]}]}] , 
        simplexcolorbar = Graphics[{}] ] ;

    
If[includecontourplot == 1, 
        simplexcolorbarph = simplexcolorbar, 
        simplexcolorbarph = Graphics[{}]] ;
If[drawoncontour == 1, simplexcolorbarvf = simplexcolorbar, 
        simplexcolorbarvf = Graphics[{}]] ;

If[ spherecontour == 1,  
        If[includecontourplot == 1  &&  
            SphereContourFunction  ===  SimplexContourFunction, 
          SphereMinAttained = MinAttained, 
          If[SphereContourFunction  ===  RSSpeed, SphereMinAttained = 0, 
            spherenrmlzdmin = 
              Flatten[Table[
                  Chop[SphereContourFunction[
                      Chop[{i, j, 1 - i - j}, (10^(-5))]], (10^(-5))], {i, 
                    0, 1,  .025}, {j, 0, 
                    1 - i,  .025}]] ; 
SphereMinAttained = 
              Min[spherenrmlzdmin]]]] ;

    
If[ spherecontour == 1 , 
        If[includecontourplot == 1  &&  
            SphereContourFunction  ===  SimplexContourFunction,  
          SphereMaxAttained = MaxAttained, 
          spherenrmlzd = 
            Flatten[Table[
                Chop[SphereContourFunction[
                    Chop[{i, j, 1 - i - j}, (10^(-5))]], (10^(-5))], {i, 0, 
                  1,  .025}, {j, 0, 
                  1 - i,  .025}]] ; 
SphereMaxAttained = 
            Max[spherenrmlzd]]] ;

    
spherebtwf[Ψ_] = 
        1 - Max[0, 
            Min[((Ψ - SphereMinAttained)/(SphereMaxAttained - SphereMinAttained)), 1]] ;

    
If[spherecontour == 1  &&  color == 0, 
        SphereConColFun[Ψ_] = 
          GrayLevel[ .(95/1.45) (1 - 
                  spherebtwf[Ψ] +  .45) ]] ;
If[spherecontour == 1 &&  color == 1, 
        SphereConColFun[Ψ_] = 
          Hue[ Which[
              spherebtwf[Ψ] ≤ (1/2), (2/5) 
                spherebtwf[Ψ], 
              (1/2) < spherebtwf[Ψ] ≤ 
                (2/3),  (6/5) spherebtwf[Ψ] - (2/5), 
              (2/3) < spherebtwf[Ψ], (3/4) 
                  spherebtwf[Ψ] - (1/10)]]] ;

Drawing Solutions to Diff Eqs if there is a contour plot

If[
        includecontourplot == 1  ||  
          drawoncontour == 1, 
     g[y_] := 
          SimplexContourFunction[old[y]] ;  
con = 
          ContourPlot[g[{y1, y2}], {y1, 0, 1}, {y2, 0, ((Sqrt[3])/2)}, 
            DisplayFunction  ->  Identity,  
            PlotPoints -> plotprecision, 
            Contours -> numberofcontours, Frame -> None, 
            AspectRatio -> Automatic,  ContourLines  ->  False, 
            ColorFunctionScaling  ->  False ,  
            ColorFunction ->  (ConColFun[#] &)] , 
        con = Graphics[{}]] ;

    
If[includecontourplot == 1 , conph = con, 
        conph = Graphics[{}]] ;
If[drawoncontour == 1, convf = con, 
        convf = Graphics[{}]] ;

Drawing 3D Plot of contour function

\(\(If[
        graphcontour3d == 1, \ 
frestricted3d[x_] := 
          If[x[\([1]\)] ≥ 0 && x[\([2]\)] ≥ 0 && 
              x[\([3]\)] ≥ 0 && 
              x[\([1]\)] + x[\([2]\)] + x[\([3]\)] == 1, 
            SimplexContourFunction[x], \(-\ Infty\)]\ ; 


        g3d[y_] := 
          frestricted3d[
            old[y]]\ ; \ 

confunplt = \ 
          Plot3D[\ g3d[{y1, y2}]\ , \ {y1, 0, 1}, {y2, 0, \@3\/2}, 
            DisplayFunction\  -> \ 
              Identity, 
PlotPoints\  -> \ 
              plotprecision, \ 
            PlotRange\  -> \ {MinAttained - distancefrommin, 
                MaxAttained +  .05}, \ ViewPoint -> vpoint, \ 
            Lighting -> \ False, 
            ColorFunctionScaling -> \ False\ , \ 
            ColorFunction -> \ \((ConColFun[#] &)\), \ 
Axes\  -> \ False, \ Boxed\  -> \ False, \ 
            Mesh\  -> \ False, \ 
            BoxRatios\  -> \ {1, 1, 
                1.25}]\ ; 
edgeline1 = \ 
          ParametricPlot3D[\ {y1\/2, \(\(\@3\) y1\)\/2, 
              SimplexContourFunction[old[{y1\/2, \(\@3\/2\) y1}]], 
              GrayLevel[ .3]}\ , \ {y1, 0, 1}, 
            DisplayFunction\  -> \ 
              Identity, 
PlotPoints\  -> 200, \ 
            PlotRange\  -> \ {MinAttained - distancefrommin, 
                MaxAttained +  .05}, \ 
            ViewPoint -> vpoint, \ 
Axes\  -> \ 
              False, \ Boxed\  -> \ 
              False, \ \ BoxRatios\  -> \ {1, 1, 1.25}]\ ; 
        edgeline2 = \ 
          ParametricPlot3D[\ {1 - y1\/2, \(\(\@3\) y1\)\/2, 
              SimplexContourFunction[old[{1 - y1\/2, \(\@3\/2\) y1}]], 
              GrayLevel[ .3]}\ , \ {y1, 0, 1}, 
            DisplayFunction\  -> \ 
              Identity, 
PlotPoints\  -> \ 200, \ 
            PlotRange\  -> \ {MinAttained - distancefrommin, 
                MaxAttained +  .05}, \ 
            ViewPoint -> vpoint, \ 
Axes\  -> \ 
              False, \ Boxed\  -> \ 
              False, \ \ BoxRatios\  -> \ {1, 1, 
                1.25}]\ ; \ \ edgeline3 = \ 
          ParametricPlot3D[\ {1 - y1, 0, g3d[{1 - y1, 0}], 
              GrayLevel[ .3]}\ , \ {y1, 0, 1}, 
            DisplayFunction\  -> \ 
              Identity, 
PlotPoints\  -> \ 200, \ 
            PlotRange\  -> \ {MinAttained - distancefrommin, 
                MaxAttained +  .05}, \ 
            ViewPoint -> vpoint, \ 
Axes\  -> \ 
              False, \ Boxed\  -> \ False, \ \ BoxRatios\  -> \ 
              heightratio]];\)\)

Drawing Solutions to Diff Eqs on sphere if there is a contour plot

If[spherecontour == 1 , 
        spherefrestricted[{x_, y_, z_}] = 
          If[x ∈ Reals  &&  y ∈ Reals  &&  
              z ∈ Reals  &&  x ≥ 0 && 
              y ≥ 0 && z ≥ 0 && 
              x + y + z == 1, SphereContourFunction[{x, y, z}], 
            0] ; 

sphereg[{w1_, w2_}] = 
          spherefrestricted[
            inverseSR[oldSRT[{w1, w2}, viewray], 
              viewray]] ;  

spherecon = ContourPlot[
            sphereg[{w1, w2}], {w1, fromwmin[1], towmax[1]}, {w2, 
              fromwmin[2], towmax[2]}, 
            DisplayFunction  ->  Identity,  
            PlotPoints -> plotprecision, 
            Contours -> numberofcontours, Frame -> None, 
            AspectRatio -> Automatic,  ContourLines  ->  False, 
            ColorFunctionScaling ->  False ,  
            ColorFunction ->  (SphereConColFun[#] &)] ] ;

Arrows

ar = 
        Graphics[
          Flatten[Table[{If[Dimensions[
                        data[[i, 
                          3]]][[1]] ≠  
                    0,  Join[
                      Select[data[[i, 
                          3]], (MatchQ[#1, Hue[__]]  || 
                              MatchQ[#1, GrayLevel[__]] || 
                              MatchQ[#1, RGBColor[__]] || 
                              MatchQ[#1, CMYKColor[__]]) &], {GrayLevel[
                          0]}][[1]], 
                  GrayLevel[0] ], 
                Table[Arrow[
                    Flatten[
                      Evaluate[
                        new[{x1[data[[i, 
                                      4]][[j]] - 
                                  relarrowbase data[[i, 
                                      2]]], 
                              x2[data[[i, 
                                      4]][[j]] - 
                                  relarrowbase data[[i, 
                                      2]]]}] /. G[[i]]]], 
                    Flatten[
                      Evaluate[
                        new[{x1[data[[i, 
                                    4]][[j]]], 
                              x2[data[[i, 
                                    4]][[
                                  j]]]}] /. G[[i]]]], 
                    HeadCenter -> arrowheadcenter, 
                    HeadLength -> data[[i, 
                          5]][[
                        j]]], {j, Dimensions[
                        data[[i, 
                          5]]][[1]]}]}, {i, Dimensions[
                    data][[1]]}]]] ;

arcycle = 
        If[Dimensions[
                cycledata][[1]] == 0, Graphics[{}], 
          Graphics[
            Flatten[Table[{If[Dimensions[
                          cycledata[[i, 
                            4]]][[1]] ≠  
                      0, Join[
                        Select[
                          cycledata[[i, 
                            4]], (MatchQ[#1, Hue[__]]  || 
                                MatchQ[#1, GrayLevel[__]] || 
                                MatchQ[#1, RGBColor[__]] || 
                                MatchQ[#1, CMYKColor[__]]) &], {GrayLevel[
                            0]}][[1]], 
                    GrayLevel[0]], 
                  Table[Arrow[
                      Flatten[
                        Evaluate[
                          new[{x1[cycledata[[i, 
                                        5]][[j]] - 
                                    relarrowbase data[[i, 
                                        2]]], 
                                x2[cycledata[[i, 
                                        5]][[j]] - 
                                    relarrowbase data[[i, 
                                        2]]]}] /. GCycle[[i]]]], 
                      Flatten[
                        Evaluate[
                          new[{x1[cycledata[[i, 
                                      5]][[j]]], 
                                x2[cycledata[[i, 
                                      5]][[
                                    j]]]}] /. GCycle[[i]]]], 
                      HeadCenter -> arrowheadcenter, 
                      HeadLength -> cycledata[[i, 
                            6]][[
                          j]]], {j, Dimensions[
                          cycledata[[i, 
                            6]]][[1]]}]}, {i, Dimensions[
                      cycledata][[1]]}]]]] ;

Arrows for the sphere plot

If[spherecontour == 1, 
        arsrt = Graphics[
            Flatten[Table[
                Table[Arrow[
                    Flatten[
                      Evaluate[
                        Re[SRT[{(Sqrt[x1])[data[[i, 4]][[j]] - relarrowbase  data[[i, 2]]], (Sqrt[x2])[data[[i, 4]][[j]] - relarrowbase  data[[i, 2]]], √(1 - x1[data[[i, 
                                        4]][[j]] - 
                                        relarrowbase  data[[i, 2]]] - 
                                      x2[data[[i, 
                                        4]][[j]] - 
                                        relarrowbase  data[[i, 2]]])}, 
                              viewray]] /. G[[i]]]], 
                    Flatten[
                      Evaluate[
                        Re[SRT[{(Sqrt[x1])[data[[i, 4]][[j]]], (Sqrt[x2])[data[[i, 4]][[j]]], √(1 - x1[data[[i, 
                                        4]][[j]]] - 
                                      x2[data[[i, 
                                        4]][[j]]])}, 
                              viewray]] /. G[[i]]]], 
                    HeadCenter -> arrowheadcenter, 
                    HeadLength -> data[[i, 
                          5]][[
                        j]]], {j, Dimensions[
                        data[[i, 
                          5]]][[1]]}], {i, Dimensions[
                      data][[1]]}]]] ];

Generating the output notebook

\(\(\( (*\(\(--\(--\(--\(--\(--Redirecting\)\)\)\)\)\ output\ to\ a\ new\ \(\(\(notebook--\)--\)--\)\)\(-\)*) \)\(
\)\(\($nb = 
        NotebookCreate[
          WindowSize -> \ {650, 550}]\ ;\)

    \($DisplayFunction = 
        NotebookWrite[$nb, \ 
            Cell[GraphicsData["PostScript", \ 
                DisplayString[#]], "Graphics"]] &\ ;\)

    \(\($Post = 
        If[# =!= \ Null, 
            NotebookWrite[$nb, 
              Cell[BoxData[
                  MakeBoxes[#, 
                    StandardForm]], "Output"]]] &\ ;\)\(
\)
    \)

    \(Unprotect[Print]\ ;\)

    \(Print[x_]\  := \ 
        NotebookWrite[$nb, 
          Cell[BoxData[MakeBoxes[x, StandardForm]]]]\ ;\)

    \(Print[x__]\  := Map[Print, {x}]\ ;\)

    \(\(Protect[Print]\ ;\)\(
\)
    \)

    \(Unprotect[StylePrint]\ ;\)

    \(StylePrint[x_]\  := \ 
        NotebookWrite[$nb, 
          Cell[BoxData[ToBoxes[x]], "Output"]]\ ;\)

    \(StylePrint[x_, rest___]\  := \ 
        NotebookWrite[$nb, 
          Cell[BoxData[ToBoxes[x]], rest]]\ ;\)

    \(Protect[
        StylePrint];\)

 (*\(--\(--\(--\(--\(--\(--\(--\(--Redirecting\)\)\)\)\)\)\)\)\ code\ \(\(\(\(\(ends--\)--\)--\)--\)--\) - \(--\(---\)\)*) 

    \)\)\)

NotebookWrite[$nb, 
        Cell[BoxData[
            ToBoxes["💡💡💡 DYNAMO \
💡💡💡"]], "Title",  
          FontColor ->  Hue[ .19], Background ->  Hue[ .72], 
          TextAlignment ->  Center, 
          CellFrame ->  True]] ;

Text output - the game

\(\(\(Print[
        StyleForm[
          ColumnForm[{"", "The Game"}], "Section"]]\ ;\)\(
\)
    \)\)
If[nonlineargame  ==  0, 
        Print[SequenceForm["   Normal form game:  ",  {strategy[1], 
                strategy[2], strategy[3]} // TableForm, 
            A // MatrixForm]]] ;

    
Print[
        SequenceForm["   Payoff vector field:  ", "F", {x, y, z} // 
            MatrixForm,  " = ", 
          F[{x, y, z}] // MatrixForm]] ;

    
If[findnashequilibria == 1,  
        If[  Dimensions[NashEq[F]][[1]] == 1, 
          Print["   Nash equilibrium:"], 
          Print["   Nash equilibria:"]] ; 
Print[
          SequenceForm["     ", 
            ColumnForm[
              Table[PaddedForm[NashEq[F][[i]], {7, 7}, 
                  NumberPadding -> {" ", " "}], {i, 
                  1, Dimensions[
                      NashEq[F]][[1]]}]] ]] ];

Text output - the dynamic

\(\(\(\(\(Print[
        StyleForm[
          ColumnForm[{"", "The Dynamic"}], "Section"]]\ ;\)\(
\)
    \)

    \(\(Print[
        SequenceForm["   Name of dynamic:  ", \ \ Dynamic\ ]]\ ;\)\(
\)
    \)

    \(Print["   Law of motion: ", \ 
        SequenceForm[\ \*""   (Subscript[V, F])"", {x, y, z} // 
            MatrixForm, \ " = ", 
          Simplify[Dynamic[{x, y, z}, F]] // 
            MatrixForm\ ]\ ];\)\)\(\ \ \)\)\)

Text output - stability of rest points

\(\(\(
\)\(If[
        findrestpoints == 
          1, \ 

If[\ \ \(Dimensions[
                stblpnts]\)[\([1]\)] == 1, 
          Print["   Stable rest point:"], 
          Print["   Stable rest points:"]]\ ; 
If[\ \ \(Dimensions[stblpnts]\)[\([1]\)] == 0, Print["    None"], 
          Print[SequenceForm["   ", 
              ColumnForm[
                Table[PaddedForm[stblpnts[\([i]\)], {7, 7}, 
                    NumberPadding -> {" ", " "}], {i, 
                    1, \(Dimensions[
                        stblpnts]\)[\([1]\)]}]]]\ ]\ ]; 

If[\ \ \(Dimensions[unstbl]\)[\([1]\)] == 1, 
          Print["   Unstable rest point:"], 
          Print["   Unstable rest points:"]]\ ; 
If[\ \ \(Dimensions[unstbl]\)[\([1]\)] == 0, Print["    None"], 
          Print[SequenceForm["   ", 
              ColumnForm[
                Table[PaddedForm[unstbl[\([i]\)], {7, 7}, 
                    NumberPadding -> {" ", " "}], {i, 
                    1, \(Dimensions[
                        unstbl]\)[\([1]\)]}]]]\ ]]]\ ;\)\)\)

Text output - the contour function

\(\(\(\(\(If[
        includecontourplot == 1 || \ \ graphcontour3d == 1, 
        Print[StyleForm[
            ColumnForm[{"", "Graphics"}], "Section"]]]\ ;\)\(
\)
    \)

    \(If[includecontourplot == 1 || \ graphcontour3d == 1, 
        Print[SequenceForm[\ "   Name of Contour Function = ", \ 
            SimplexContourFunction]\ ]; \ 
If[
          showcontourformula == 1, 
          Print["   Definition of Contour Function = ", 
            SequenceForm["   ψ", \ {x, y, z} // 
                MatrixForm, \ " = ", \ 
              SimplexContourFunction[{x, y, 
                  z}]\ ]]]; 
Print[
          SequenceForm["   Minimum Value = ", \ \ N[
              MinAttained]\ ]]\ \ ; \ 
Print[
          SequenceForm["   Maximum Value = ", \ \ N[
              MaxAttained]\ ]]\ ]\ ;\)\)\(\ \)\)\)

Generating the vector field diagram

If[
        vectorfielddiagram == 
          1,  
Show[  If[
            drawrestpoints == 1, {convf, leftri, rightri, 
              simplexcolorbarvf,  downl, Tri, vectorf1, vectorf2, DOTS, 
              WDots}, {convf, leftri, rightri, simplexcolorbarvf,  downl, 
              Tri, vectorf1, vectorf2}], 
          DisplayFunction ->  $DisplayFunction, 
 
          AspectRatio ->  Automatic,  ImageSize ->  {500, 500}, 
          DefaultFont -> {"Palatino-Roman", 10}, 
          Epilog -> {Text[strategy[1], {0.5,  .89}], 
              Text[strategy[2], {- .03, - .02}], 
              Text[strategy[3], {1.03, - .02}]} ] ] ;

Generating the phase diagram on simplex

If[phasediagram == 1,  
        Show[{conph, e, ecycle, leftri, rightri, simplexcolorbarph, downl, 
            Tri, extralines, uddots, udwdots, extratext, ar, arcycle, DOTS, 
            WDots}, DisplayFunction  ->  $DisplayFunction, 
          ImageSize ->  {500, 500}, 
          PlotRange -> {{- .08, 1.08}, {- .04,  .95}}, 
          AspectRatio ->  Automatic, 
          DefaultFont -> {"Palatino-Roman", 10}, 
          Epilog -> {Text[strategy[1], {0.5,  .89}], 
              Text[strategy[2], {- .03, - .02}], 
              Text[strategy[3], {1.03, - .02}]} ] ] ;

Generating the 3D plot of the contour function

If[graphcontour3d ==  1,  
        Show[confunplt, 
          Which[findrestpoints == 1  &&  grayline == 1, {Tri3d, 
              SeveralLines, SeveralPoints, edgeline1, edgeline2, edgeline3}, 
            findrestpoints == 1  &&  grayline == 0, {Tri3d, 
              SeveralLines, SeveralPoints}, 
            findrestpoints == 0  &&  grayline == 1, {Tri3d, 
              edgeline1, edgeline2, edgeline3}, 
            findrestpoints == 0  &&  grayline == 0, Tri3d], 
          Graphics3D[{Text[
                StyleForm[strategy[1], 
                  FontFamily -> "Palatino-Roman", 
                  FontSize -> 10], { .5,  .9,  
                  MinAttained - distancefrommin}], 
Text[
                StyleForm[strategy[2], 
                  FontFamily -> "Palatino-Roman", 
                  FontSize -> 
                    10], {- .05, - .02,   MinAttained - 
                    distancefrommin}], 
Text[
                StyleForm[strategy[3], 
                  FontFamily -> "Palatino-Roman", 
                  FontSize -> 10], {1.05, - .02,   MinAttained - 
                    distancefrommin}]} ], 
          DisplayFunction  ->  $DisplayFunction,  
          ImageSize ->  {500, 500}]] ;

Text output - the sphere contour function

\(\(\(\(\(If[\ spherecontour == 1\ , 
        Print[StyleForm[
            ColumnForm[{"", "The Sphere Contour Plot"}], "Section"]]]\ ;\)\(
\)
    \)

    \(If[spherecontour == 1\ , 
        Print[SequenceForm[\ "   Name of Sphere Contour Function = ", \ 
            SphereContourFunction]\ ]; \ 
If[
          showcontourformula == 1, 
          Print["   Definition of Sphere Contour Function = ", 
            SequenceForm["   Ψ", \ {x, y, z} // 
                MatrixForm, \ " = ", \ 
              SphereContourFunction[{x, y, z}]\ ]]]; 
Print[
          SequenceForm["   Minimum Value = ", \ \ N[
              SphereMinAttained]\ ]]\ \ ; \ 
Print[
          SequenceForm["   Maximum Value = ", \ \ N[
              SphereMaxAttained]\ ]]\ ; 
Print[
          SequenceForm["   Tangent point = ", \ 
            N[viewray/\((\@\(viewray[\([1]\)]\^2 + viewray[\([2]\)]\^2 + viewray[\([3]\)]\^2\))\)]\ ]]\ ]\ ;\)\)\(\ \)\)\)

Generating the phase diagram on the sphere

If[spherecontour == 1,  
        Show[spherecon,  eonsphere, rightrisrt, downlsrt, leftrisrt, 
          If[findrestpoints == 
              1, {If[viewraydot == 1, {curvedtri, DOTatOrig}, 
                curvedtri], DOTSsrt, WDotssrt}, 
            If[viewraydot == 1, {curvedtri, DOTatOrig}, curvedtri]], 
          arsrt, Graphics[{Text[strategy[1], 
                SRT[{1, 0, 0}, viewray] + {0,  .04}], 
              Text[strategy[2], 
                SRT[{0, 1, 0}, viewray] + {- .04, - .04}], 
              Text[strategy[3], 
                SRT[{0, 0, 1}, viewray] + { .04, - .04}]}], 
          DisplayFunction  ->  $DisplayFunction, 
          ImageSize ->  {500, 500}, 
          PlotRange -> {{fromwmin[1] -  .1, 
                towmax[1] +  .1}, {fromwmin[2] -  .1, towmax[2] +  .1}}, 
          DefaultFont -> {"Palatino-Roman", 10}]] ;

Print[
        SequenceForm["Runtime: ", 
          If[Quotient[TimeUsed[]  -  time1, 60] > 9, 
            Quotient[TimeUsed[]  -  time1, 60], 
            PaddedForm[Quotient[TimeUsed[]  -  time1, 60], 1, 
              NumberPadding ->  {"0", "0"}, 
              SignPadding ->  False]], ":", 
          If[Round[Mod[TimeUsed[]  -  time1, 60]] > 9, 
            Round[Mod[TimeUsed[]  -  time1, 60]], 
            PaddedForm[Round[Mod[TimeUsed[]  -  time1, 60]], 1, 
              NumberPadding ->  {"0", "0"}, 
              SignPadding ->  False]]]] ;

\(\(\(
\)\( (*\(\(--\(--\(--\(--\(--Returning\)\)\)\)\)\ to\ original\ output\ \(\(\(production--\)--\)--\)\)\(-\)*) \)\(
\)\(
\)\(\($DisplayFunction = 
        CellPrint[\ 
            Cell[GraphicsData["PostScript", \ 
                DisplayString[#]], "Graphics"]] &\ ;\)

    \(\($Post = 
        If[# =!= \ Null, 
            CellPrint[
              Cell[BoxData[
                  MakeBoxes[#, 
                    StandardForm]], "Output"]]] &\ ;\)\(
\)
    \)

    \(Unprotect[Print]\ ;\)

    \(Print[x_]\  := \ 
        CellPrint[
          Cell[BoxData[MakeBoxes[x, StandardForm]]]]\ ;\)

    \(Print[x__]\  := Map[Print, {x}]\ ;\)

    \(\(Protect[Print]\ ;\)\(
\)
    \)

    \(Unprotect[StylePrint]\ ;\)

    \(StylePrint[x_]\  := \ 
        CellPrint[
          Cell[BoxData[ToBoxes[x]], "Output"]]\ ;\)

    \(StylePrint[x_, rest___]\  := \ 
        CellPrint[Cell[BoxData[ToBoxes[x]], rest]]\ ;\)

    \(Protect[StylePrint];\)


    \)\( (*\(--\(--\(--\(--\(--\(--\(--\(--code\)\)\)\)\)\)\)\)\ \(\(\(\(\(ends--\)--\)--\)--\)--\) - \(--\(---\)\)*) \)\)\)

Initialization Cells; Procedures; Known Issues

Preliminary definitions and calculations

Remove["Global`*"] ;

<< "Graphics`Arrow`" ;

Coordinate transformation (for plotting the phase diagram)

Clear[R] ;

ShiftandRotate[x_, viewray_] := 
        Module[{R1, R2, 
            wstar}, 

R1 = {{1, 0, 
                0}, {0, 
                Cos[If[viewray[[3]] == 
                      0, If[viewray[[2]] > 0, ((3 π)/2), (π/2)], 
                    ArcTan[-viewray[[2]]/viewray[[3]]]]], Sin[If[viewray[[3]] == 0, 
                    If[viewray[[2]] > 
                        0, ((3 π)/2), (π/2)], 
                    ArcTan[-viewray[[2]]/viewray[[3]]]]]}, {0, -Sin[If[viewray[[3]] == 0, 
                      If[viewray[[2]] > 
                          0, ((3 π)/2), (π/2)], 
                      ArcTan[-viewray[[2]]/viewray[[3]]]]], Cos[If[viewray[[3]] == 0, 
                    If[viewray[[2]] > 
                        0, ((3 π)/2), (π/2)], 
                    ArcTan[-viewray[[2]]/viewray[[3]]]]]}} ; 

wstar = 
            R1  .  
              viewray  ; 

R2 = {{Cos[
                  If[wstar[[3]] == 0, 
                    If[wstar[[2]] > 
                        0, ((3 π)/2), (π/2)], 
                    ArcTan[-wstar[[1]]/wstar[[3]]]]], 0, Sin[If[wstar[[3]] == 0, 
                    If[wstar[[2]] > 
                        0, ((3 π)/2), (π/2)], 
                    ArcTan[-wstar[[1]]/wstar[[3]]]]]}, {0, 1, 0}, {-Sin[If[wstar[[3]] == 0, 
                      If[wstar[[2]] > 
                          0, ((3 π)/2), (π/2)], 
                      ArcTan[-wstar[[1]]/wstar[[3]]]]], 0, Cos[If[wstar[[3]] == 0, 
                    If[wstar[[2]] > 
                        0, ((3 π)/2), (π/2)], 
                    ArcTan[-wstar[[1]]/wstar[[3]]]]]}} ; 

R = R2  .  R1  ;  
          R  .  (x - viewray)  ] ;

SRT[x_, 
          viewray_] := {-ShiftandRotate[x, 
                viewray][[2]], ShiftandRotate[x, 
              viewray][[1]]}  ;

oldSRT[w_, viewray_] := {w[[2]], -w[[1]], 
          Sqrt[1 - (w[[2]] - ShiftandRotate[{0, 0, 0}, 
                          viewray][[1]])^2  - (-w[[1]] - ShiftandRotate[{0, 0, 0}, viewray][[2]])^2] + ShiftandRotate[{0, 
                  0, 0}, viewray][[3]]} ;

inverseSR[w_, 
          viewray_] := (Inverse[R]  .  w  +  
              viewray)^2 ;

new maps points in the simplex to their 2D represetations for graphing.
old does the reverse.

Clear[TA]  ;

TA=(({{-(1/2), -1}, {((Sqrt[3])/2), 0}}))  ;

Clear[new]  ;

Clear[old2]  ;

Clear[old]  ;

new[r_] := 
        TA . {r[[1]], 
              r[[2]]} + {1, 
            0} ;

old2[c_] := Inverse[TA] . (c - {1, 0}) ;

old[
          c_] := {old2[
              c][[1]], old2[
              c][[2]], 
          1 - old2[c][[1]] - old2[
                c][[2]]} ;

Calculation of restricted equilibria and Nash equilibria

Clear[NashEq] ;

    
NashEq::usage = "is a procedure that finds Nash Eq. of a game \
when payoff vector field, F, as an argument." ;

    
\(\(\(NashEq::notes = "finds Nash Equilibria by first finding rest points of Rep. Dyn. and eleminating the ones that are not Nash Eq.";\)\(
\)
    \)\)
\(\(NashEq[F_] := 
        Module[\ {usex, yusey, i, j, x, nnR, TnnTR, nnsonuc, nnfin, 
            RawRestRep, RestRep, grd1, Nash0, Nash1}, 
          usex = Table[i\  .1 -  .1, \ {i, 11}]\ ; \ 
          yusey = Table[i\  .1 -  .1, \ {i, 11}]\ ; 
i = 
            1\ ; \ j = 
            1\ ; \ 
x = {nn1, nn2, \ 
              1 - nn1 - nn2}\ ; \ 

 (*\ 
            Finds\ rest\ of\ replicator\ by\ "grid search"\ where\ grids\ are\ given\ by\ usex\ and\ yusey\ *) 

nnR = 
            Flatten[Table[
                Table[FindRoot[{0 == \(Replicator[x, 
                            F]\)[[1]], 
                      0 == \(Replicator[x, 
                            F]\)[[2]]}, {nn1, usex[[i]]}, {nn2, 
                      yusey[[j]]}, \ 
                    MaxIterations\  -> 
                      1000], {j, \(Dimensions[
                          yusey]\)[[1]] - i}], {i, \(Dimensions[usex]\)[[1]]}], 
              1]; 

 (*\ 
            This\ function\ is\ defined\ to\ eleminate\ double\ countings\ in\ nnR\ caused\ by\ grid\ \(\(search\)\(.\)\)\ *) \ \ 

TnnTR[H_] := 
            DeleteCases[
              Table[If[\((Abs[\((nn1\  /. \ 
                                H[[1, 
                                  1]])\) - \ \((nn1\  /. \ 
                                H[[i, 
                                  1]])\)] >  .01\ \  || \ 
                      Abs[\((nn2\  /. \ \ H[[1, 
                                  2]])\) - \ \((nn2\  /. \ 
                                H[[i, 
                                  2]]\ )\)] >  .01\ )\)\ , 
                  H[[i]], 0], {i, 
                  2, \(Dimensions[
                      H]\)[[1]]}], 
              0]; 

 (*\ 
            Using\ TnnTR\ we\ eliminate\ double\ countings\ by\ following\ two\ lines\ *) \ \ 

nnsonuc = 
            DeleteCases[
              FixedPointList[TnnTR, nnR], {}]\ ; 
nnfin = 
            Chop[Table[\(nnsonuc[[i]]\)[[1]], {i, \(Dimensions[
                      nnsonuc]\)[[1]]}], 
              10\^\(-6\)]; 

 (*\ 
            Following\ two\ lines\ eleminates\ the\ values\ outside\ the\ \(\(simplex\)\(.\)\)\ *) 

RawRestRep = 
            Chop[{nn1, nn2, 1 - nn1 - nn2}\  /. \ nnfin, 
              10\^\(-6\)]; 
RestRep = 
            DeleteCases[
              Table[If[
                  Min[RawRestRep[[i]]] < \(-10\^\(-6\)\), outside, 
                  RawRestRep[[i]]], {i, \(Dimensions[RawRestRep]\)[[1]]}], 
              outside]; 

grd1 = {{1, 0, 
                0}, {0, 1, 0}, {0, 0, 
                1}}; 

 (*\ 
            Following\ three\ lines\ eleminate\ the\ rest\ point\ that\ are\ not\ Nash\ \(\(Eq\)\(.\)\)\ *) 

Nash0 = 
            Table[Table[
                If[\((F[RestRep[\([j]\)]] . 
                          RestRep[\([j]\)] +  .00001\  ≥ \ \ F[
                          RestRep[\([j]\)]] . grd1[\([i]\)])\), \ 
                  RestRep[\([j]\)], 
                  sil], {i, \(Dimensions[grd1]\)[\([1]\)]}], {j, \(Dimensions[
                    RestRep]\)[\([1]\)]}]\ ; 
Nash1 = 
            DeleteCases[
              Table[If[MatrixQ[Nash0[\([i]\)]], Nash0[\([i]\)], 
                  sil], {i, \(Dimensions[Nash0]\)[\([1]\)]}], 
              sil]\ ; 


Nash2 = 
            Table[Nash1[\([i, 1]\)], {i, \(Dimensions[Nash1]\)[\([1]\)]}]; \ 
          Clear[x]; \ \ Nash2\ ]\ ;\)\)

Calculation of rest points (smooth dynamics)

Clear[RestPointsSmooth]  ;

    
RestPointsSmooth::usage = "Calculates restpoint of smooth \
dynamics "  ;

    
RestPointsSmooth[Dynamic_, F_,  RestSearchInit_,  TolLevel_] :=  
        Module[{sonuc, x, vfield, TR, fin, RAWresult},  
          x = {rr1, rr2, 1 - rr1 - rr2} ;   
vfield[
              Dynamic,  y_, k_]  :=  
            Dynamic[y, k] ; 

 (* 
            Finds restpoints by grid search *)  
          R = Table[
              FindRoot[{0 == vfield[Dynamic, x, 
                        F][[1]], 
                  0 == vfield[Dynamic, x, 
                        F][[2]]}, {rr1, RestSearchInit[[i, 1]]}, {rr2, 
                  RestSearchInit[[i, 
                    2]]},  
                MaxIterations  -> 
                  1000], {i, Dimensions[
                    RestSearchInit][[1]]}] ; 

 (* 
            Eleminates double countings *) 
TR[H_] := 
            DeleteCases[
              Table[If[(Abs[(rr1  /.  
                                H[[1, 
                                  1]]) -  (rr1  /.  
                                H[[i, 
                                  1]])] >  .01   ||  
                      Abs[(rr2  /.   H[[1, 
                                  2]]) -  (rr2  /.  
                                H[[i, 
                                  2]] )] >  .01 ) , 
                  H[[i]], 0], {i, 
                  2, Dimensions[
                      H][[1]]}], 
              0]; 
sonuc = 
            DeleteCases[FixedPointList[TR, R], {}]; 
fin = 
            Chop[Table[sonuc[[
                    i]][[1]], {i, Dimensions[
                      sonuc][[1]]}], 
              (10^(-6))] ; 

RAWresult = Chop[{rr1, rr2, 1 - rr1 - rr2}  /.  fin, (10^(-6))] ;  
          midresult = 
            DeleteCases[
              Table[If[
                  Min[RAWresult[[
                        i]]] < -(10^(-6)), outside, 
                  RAWresult[[i]]], {i, Dimensions[RAWresult][[1]]}], 
              outside] ;  
          result = 
            DeleteCases[
              Table[If[
                  Max[Abs[
                        Dynamic[
                          midresult[[i]], F]]]  >  TolLevel,  notrest, 
                  midresult[[i]]], {i, Dimensions[midresult][[1]]}], 
              notrest] ; 
 Clear[x] ;  
          result ] ;

Specification of rest points

Clear[RestPoints] ;
\(\(\(RestPoints::usage = "Calculation of rest points of dynamics"\ ;\)\(
\)
    \)\)
RestPoints[Dynamic_, F_, RestSearchInit_, TolLevel_] := 
        Which[RPCharacterization[Dynamic] ===  Automatic, 
          RestPointsSmooth[Dynamic, F,  RestSearchInit, TolLevel],  
          RPCharacterization[Dynamic] ===  Nash,  NashEq[F],  
          RPCharacterization[Dynamic] ===  RestrictedEquilibria,  
          RestPointsSmooth[Replicator, F,  RestSearchInit,  
            TolLevel]] ;

Testing stability of rest points

Clear[
        TestStability] ;
\(TestStability::usage = "tests stability of rest points found by Respoints[Dynamic,F] function."\ ;\)
TestStability::notes = "Its arguments are name of the \
dynamic, payoff vector field, final time which will be used to see whether \
solution trajectory is outside neighborhood of the rest point. This \
neighborhood is defined by delta. eps defines another neighborhood of rest \
point from which an initial condition drawn. numtest gives the number of \
initial points for which tests will be conducted." ;

TestStability[Dynamic_, F_, bigT_,  numtest_,  
          eps_,   delta_, RestSearchInit_, TolLevel_]:=Module[{xtest0, vfield, x, G1, G3, dim, Stability}, testrest = 
                RestPoints[Dynamic, F, RestSearchInit, TolLevel] ;   
Table[
                For[j = 1, 
                  j < numtest + 1, j++, (Label[AA]; θ =  
                      Random[Real, {0, 2 Pi}]; 
                    xtest0[i, j] = 
                      old[new[
                            testrest[[
                              i]]] +  
                          eps {Cos[θ], Sin[θ]}];  
                    If[Min[xtest0[i, j]] < 0,  
                      Goto[AA]])], {i, Dimensions[
                      testrest][[1]]}];

xtest = 
                Table[xtest0[i, 
                    j], {i, Dimensions[
                        testrest][[1]]}, {j, numtest}];

Clear[vfield];
vfield[Dynamic,  x_, m_]  :=  
                Dynamic[x, m] ;

  
x = {y1[t], y2[t], 
                  1 - y1[t] - y2[t]};

G1=Table[NDSolve[{y1'[t]==vfield[Dynamic, x, 
                                  F][[1]],y2'[t]==vfield[Dynamic, x, 
                                  F][[2]],y1[
                                0] == xtest[[i, 
                                  j]][[1]],y2[
                                0] == xtest[[i, 
                                  j]][[2]]},{y1, y2},{t, 0, bigT}],{i, Dimensions[
                          testrest][[1]]},{j, Dimensions[
                          xtest][[2]]}] ;


  

G3 = {y1[bigT], y2[bigT], 
                    1 - y1[bigT] - y2[bigT]}  /.  G1 ;

Dimensions[G3];
Stability=Table[If[((∑_(i = 1)^2) (new[testrest[[j]]]-new[G3[[j, k, 
                                        1]]])[[i]]^2)^(1/2) < delta,1,0],{j, Dimensions[
                          G3][[1]]},{k, Dimensions[
                          G3][[2]]}];

dim = Dimensions[
                    Stability][[2]];

  
stblpnts=DeleteCases[Table[If[ (∑_(j = 1)^dim) Stability[[i, 
                                    j]]==dim,testrest[[i]] ],{i, Dimensions[Stability][[1]]}],Null] ;
unstbl=DeleteCases[Table[If[ (∑_(j = 1)^dim) Stability[[i, 
                                    j]]≠dim,testrest[[i]] ],{i, Dimensions[Stability][[1]]}],Null] ; Clear[x];
{stblpnts, unstbl}] ;

Known issues

Rest Points of BR dynamics and Logit Dynamics

Strictly speaking  there is no built-in best response dynamic in this program, but we can approximate it using Logit[η] dynamic with a small value of  η.  But when η is very small, the FindRoot command (which is used to find the rest points, via Newton's method) does not work properly, and hence the rest points of approximate BR dynamic cannot be found accurately.  If you are using this dynamic, and "tuning" the rest point search does not help you, you may want to add rest point manually using the "Extra graphic elements" portion of the "Specification of output - Phase diagram" section.

Credits

Dynamo 3S
Version 0.1.5  (April 11, 2007)
by William H. Sandholm and Emin Dokumaci

mail:			Department of Economics
			University of Wisconsin
			1180 Observatory Drive
			Madison WI 53706

e-mail:			whs@ssc.wisc.edu
			edokumaci@wisc.edu
	
websites:		http://www.ssc.wisc.edu/~whs/
			http://www.ssc.wisc.edu/~edokumac/
		
Dynamo website:		http://www.ssc.wisc.edu/~whs/dynamo
    
Financial support from the National Science Foundation under Grants SES-0092145 and SES-0617753 is gratefully acknowledged.