💡💡💡 DYNAMO 4 💡💡💡
Phase Diagrams for Evolutionary Dynamics

User-defined Parameters

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

Off[General::spell1];

Choice of game

A=(({{0, -1, 1, 1}, {1, 0, -1, -1}, {-1, 1, 0, 0}, {-1, 1, 0, 0}})) ;

Nonlinear population games

To choose a nonlinear game, set nonlineargame = 1 and define F[x_] as you like.  The argument of F[.] must be a single element in (R^4)(i.e., F[x_] or F[{x_,y_,z_,t_}], not F[x_,y_,z_,t_]).  The default value of F[x_] is A.x, which is the payoff vector field for the normal form game A.

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

Give the strategies one-character names to be printed on the phase diagram.  If you use more than one character for each name or if you change the viewpoint from the default value, you may need to adjust the positions in which in the names are printed in the phase diagrams.

strategy[1] = "R" ; 
strategy[2] = "P" ; 
strategy[3] = "S" ;
strategy[4] = "T" ;

Payoff related definitions

Population Average Payoff

Clear[Fbar] ;

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

Excess payoff

Clear[Fhat] ;

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

Positive part of the excess payoff

Clear[Fhatplus] ;

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

Choice of dynamic

Choose a dynamic here.  To use one of the built-in dynamics, select the rhs of "Dynamic = (.)" (excluding the semicolon) and then press the button corresponding to the dynamic you desire.  If you use Logit, be sure to enter a value for the noise parameter η.  Making  η very small generates close approximations of the best response dynamic.  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), and ConvexComb must be specified in greater detail below.

Noise level for the logit dynamic

η  =   .001;

({{Replicator , Logit[η] , BNN , PD , Projection , EP , PC , , ConvexComb}})

Dynamic = Replicator ;

Definition of convex combination of two dynamics

To define the combined dynamic, specify the two dynamics to be combined, the weight (between 0 and 1) on the first dynamic  The last line of code formally defines the combined dynamic according to your specificcations.

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

    
ConvexComb[x_, F_] := 
        weight[1]  dyn[1][x, F] +  (1 - weight[1]) dyn[2][x, 
              F] ;

Definition of Dynamics

Replicator Dynamic

Clear[Replicator] ;

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

Logit Dynamic

Clear[Logit] ;

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

BNN dynamic

Clear[BNN] ;

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

Excess payoff dynamic

Here you can specify the vector field sigmatilde that defines the 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].  When computing rest points, the program assumes that sigmatilde is Lipschitz continuous and satisfies acuteness, 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, (Max[0, Fhat[x, 
                    F][[4]]])^2};

The dynamic itself is defined in here.

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

Projection Dynamic

closetozero = 10^(-8) ;

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

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

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

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

Pairwise Comparison Dynamic

Clear[PC] ;

Clear[rho1];

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

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

Pairwise Difference Dynamic

Clear[PD] ;

Clear[rho];

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

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

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_] := 
        Null;

Specification of solution trajectories

Instructions for specification of solution trajectories

data is specfies the solution trajectories to be drawn. ex,: data= {{{0, 0, 0, 1}, 20, Hue[1]}, {{1, 0, 0, 0}, 20, Hue[.7]}, {{0, 1, 0, 0}, 20, Hue[.3]},{{0, 0, 1, 0}, 20, Hue[.15]}}. The first entry in the example {{0, 0, 0, 1}, 20, Hue[1]} is for the first solution trajectory. {0, 0, 0, 1} is an initial condition for the differential equation. 20 determines the time span over which which the differential equational will be solved, [0, 20].  Hue[1] determines in which color the solution trajectory will be drawn, in this case red. Any color command can be used, i.e. GrayLevel, Hue, RGBColor. This structure must be followed in order for the program run correctly. If only one solution trajectory is needed, do not foget the outermost brackets, i.e. { {{0, 0, 0, 1}, 20, Hue[1]} }. 
Dotdata specifies dots to be drawn at rest points, etc. ex.: dotdata = {{.01, {1/3, 1/3, 1/6, 1/6}, GrayLevel[.2]}, {...........}}. creates a spehere with radius .0, centered at {1/3, 1/3, 1/6, 1/6} and with color GrayLevel[.2 ].  The color that you will see is influenced by a number of factors.  (Simulated illumination determines the shading of polygons in three-dimensional pictures. The shading of a particular polygon is computed as a sum of contributions from point light sources, plus a contribution from ambient light. ) 
ppoints determines the number of line segments used when drawing the solution trajectories.  Increase its value if the trajectories have kinks. 
Use vpoint to change the vantage point from which the diagram is viewed.

data =  {{{ .02,  .02,  .46,  .5}, 
            4, {Hue[1], Thickness[ .006]}}, {{ .01,  .01,  .68,  .3}, 
            4, {Hue[ .7], Thickness[ .006]}}, {{ .01,  .01,  .28,  .7}, 
            4, {Hue[ .7], Thickness[ .006]}}} ;

    
dotdata = {{ .01, {1/3, 1/3, 1/6, 1/6}, 
            GrayLevel[ .2]}} ;

    
ppoints = 500 ;

    
vpoint = {1.0,   .800,  0} ;

Program Core

Solving the differential equation

time1 = TimeUsed[] ;

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

G=Table[NDSolve[{x1'[t]==Dynamic[x[t], 
                          F][[1]],x2'[t]==Dynamic[x[t], 
                          F][[2]],x3'[t]==Dynamic[x[t], 
                          F][[3]],x1[
                        0] == data[[i, 
                          1]][[1]],x2[
                        0] == data[[i, 
                          1]][[2]],x3[
                        0] == data[[i, 
                          1]][[3]]},{x1, x2, x3},{t, 0, 
                  data[[i, 2]]},SolveDelayed ->  True],{i, Dimensions[
                  data][[1]]}] ;

Plotting the solutions

Drawing Triangle and Dots

The cells belongs to this group is for drawing white area around the simplex and for putting dots on the simplex.

simplex = 
        Graphics3D[{{Dashing[{ .02,  .01}], 
              Line[{{0, 0, 
                    0}, {(1/2), ((Sqrt[3])/6), ((Sqrt[6])/3)}}]}, {Line[{{(1/2), ((Sqrt[3])/6), ((Sqrt[6])/3)}, {1, 0, 0}}]}, {Dashing[{ .02,  .01}], 
              Line[{{1, 0, 0}, {0, 0, 0}}]}, {Dashing[{ .02,  .01}], 
              Line[{{0, 0, 0}, {(1/2), ((Sqrt[3])/2), 0}}]}, 
            Line[{{(1/2), ((Sqrt[3])/2), 0}, {1, 0, 0}}], 
            Line[{{(1/2), ((Sqrt[3])/2), 0}, {(1/2), ((Sqrt[3])/6), ((Sqrt[6])/3)}}], {EdgeForm[], 
              Polygon[{{0 -  .0015, 0 -  .0015, 0 -  .0015}, {1 +  .0015, 
                    0 -  .0015, 
                    0 -  .0015}, {(1/2), ((Sqrt[3])/6) -  .0015, ((Sqrt[6])/3) -  .0015}}]}, {EdgeForm[], Polygon[{{0 -  .0015, 0 -  .0015, 0 -  .0015}, {1 +  .0015, 
                    0 -  .0015, 0 -  .0015}, {(1/2), ((Sqrt[3])/2) +  .0015, 
                    0 -  .0015}}]}, {EdgeForm[], 
              Polygon[{{(1/2), ((Sqrt[3])/6) +  .0015, ((Sqrt[6])/3) +  .0015}, {(1/2), ((Sqrt[3])/2) +  .0015, 0 -  .0015}, {0 -  .0015, 0 -  .0015, 
                    0 -  .0015}}]}}] ;

    
kureler = 
        Table[Graphics3D[{SurfaceColor[ dotdata[[i, 3]] ], EdgeForm[], 
              TranslateShape[Sphere[dotdata[[i, 1]], 20, 15],  
                new[dotdata[[i, 2]]] ] }] , {i, Dimensions[
                dotdata][[1]]}] ;

Drawing Solutions to Diff.Eqn's if there is no contour plot

e = 
        Table[ParametricPlot3D[
            Evaluate[
              Join[new[{x1[t], x2[t], x3[t]}] /. G[[i, 
                      1]], {data[[i, 3]]}]], {t, 0, 
              data[[i, 2]]},  DisplayFunction  ->  Identity,  
            Boxed ->  False,  Axes ->  False,  
            PlotPoints ->  
              ppoints], {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]] ;

Generating output related to game properties

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

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

Generating output related to dynamic properties

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

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

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

Generating phase diagram on simplex without contour plot

Show[e, kureler, simplex, 
        Graphics3D[{Text[strategy[1], {0.5, ((Sqrt[3])/6), ((Sqrt[6])/3) +  .02}], 
            Text[strategy[2], {- .03,  .02,  .02}], 
            Text[strategy[3], {1.02, 0, 0}], 
            Text[strategy[4], { .52, ((Sqrt[3])/2) +  .03,  .015}]}], 
        PlotRange ->  {{- .04, 
              1.04}, {- .04, ((Sqrt[3])/2) +  .04}, {- .04, ((Sqrt[6])/3) +  .04}}, 
        DisplayFunction  ->  $DisplayFunction, 
        AspectRatio ->  Automatic,  ViewPoint ->  vpoint, 
        DefaultFont -> {"Palatino-Roman", 10}, 
        AmbientLight ->  Hue[ .55], 
        LightSources ->  {{{ .5, 1, 1}, 
              RGBColor[1, 0, 0]}, {{1,  .8,  .5}, 
              RGBColor[0, 1, 0]}, {{1, 1, 1}, 
              RGBColor[0, 0, 1]}}] ;

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 Library

Preliminary Definitions and Calculations

<< Graphics`Shapes`

Clear[AA]  ;

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

Clear[new]  ;

Clear[old2]  ;

Clear[old]  ;

new[r_] := 
        AA . {r[[1]], 
              r[[2]], 
              r[[3]]} + {(1/2), ((Sqrt[3])/2), 
            0} ;

old2[c_] := Inverse[AA] . (c - {(1/2), ((Sqrt[3])/2), 0}) ;

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

Credits

Dynamo 4S
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.