Setup

\(\(\( (*\ Copyright\ by\ Marco\ Bassetto, \ Roozbeh\ Hosseini, \ 
      Vadym\ Lepetyuk, \ 
      Christopher\ Phelan\ *) \)\(
\)\( (*\ \(This\ code\ can\ be\ freely\ distributed\ and\ modified\ for\ research\ purposes\ only\)\(,\)\ *) \)\(
\)\( (*\ 
      provided\ this\ copyright\ notice\ is\ included\ in\ the\ modified\ \(\(code\)\(.\)\)*) \)\(\ \)\(
\)\( (*\ 
      Proper\ credit\ should\ be\ given\ in\ all\ publications\ arising\ from\ *) \)\(
\)\( (*\ modifications\ of\ this\ code; \ 
      this\ should\ include\ a\ citation\ of\ *) \)\(
\)\( (*\ "Tax Riots"\ by\ Marco\ Bassetto\ and\ Christopher\ Phelan\ *) \)\)\)

Mathematica Setup

<< Graphics`Colors`
<< Graphics`Graphics`

Off[General::"spell"];
Off[General::"spell1"];

If[$VersionNumber < 
        5.0, 
Total[x_]  := 
        Sum[x[[i]], {i, 1, Dimensions[x][[1]]}]]

SetOptions[Display, 
        ImageSize -> 360];

    SetOptions[Export, ImageSize -> 360];

$FormatType = TraditionalForm;

\(\(\( (*\ 
      current\ directory\ is\ set\ to\ match\ the\ location\ of\ this\ notebook; \ 
      eps\ files\ are\ saved\ there\ *) \)\(
\)\(\(filename = ToFileName["FileName" /. 
            NotebookInformation[EvaluationNotebook[]]];\)

    \(SetDirectory[DirectoryName[filename]];\)\)\)\)

Model Setup

u[c_ ]  :=  2 (Sqrt[c])  ;

pibar   =   .02;     
mlow  = 0;      
If[mlow ≠ 0, 
      ErrorBox["THIS CODE IS WRITTEN FOR THE CASE: mlow=0"] // 
        DisplayForm]
mhigh  = 1;       
If[mhigh ≠ 1, 
      ErrorBox["THIS CODE IS WRITTEN FOR THE CASE: mhigh=1"] // 
        DisplayForm]

pi[m_]  :=  
        If[m > 0, Min[1. , (pibar/m)], 1];      (* 
      audit probability for a household which reports low endowment *)

elow  =  1/2 ;     
ehigh  =  
        3/2 ;

fmu =  .5;         
fsigma =  .3;       
fpdf[m_] := 
      Exp[-(m - fmu)^2/(2*fsigma^2)];

First Order Conditions

(* 
      first order condition with respect to tau1low *) 
eq1[tauhigh_, tau1low_, tau0low_, mu_, m_, 
        lambda_]  =  u'[elow  -  tau1low]  -  mu

(* 
      first order condition with respect to tauhigh *) 
eq3[tauhigh_, tau1low_, tau0low_, mu_, m_, 
        lambda_]  =  u'[ehigh - tauhigh] (1 + lambda)  -  
        mu

eq4[tauhigh_, tau1low_, 
        tau0low_, mu_, m_, lambda_]  =  
      m u'[elow - tau0low]  -  
        lambda (1 - m) u'[ehigh - tau0low]  -  
        m mu

eq5[tauhigh_, 
        tau1low_, tau0low_, mu_, m_, 
        lambda_]  =  (1 - m) tauhigh  +  
        m (pi[m] tau1low  +  (1 - pi[m]) tau0low)

eq5lowlow[tauhigh_, tau1low_, 
        tau0low_, mu_, m_, 
        lambda_]  =  (1 - 
              m) tauhigh  +  m tau1low

Private Information: Optimal Policy

Optimal policy

Delta[m_, lambda_, tauhighstart_, tau1lowstart_, tau0lowstart_, 
          mustart_] := 
If[
          m > pibar, 
Deltamain[m, lambda, tauhighstart, 
            tau1lowstart, tau0lowstart, 
            mustart], 
Deltalowlow[m, lambda, tauhighstart, 
            tau1lowstart, mustart]
];

Optimal policy over (pibar;phigh]

eqvec[tauhigh_, tau1low_, tau0low_, mu_, m_, 
          lambda_] = 
{eq1[tauhigh, tau1low, tau0low, mu, 
            m, lambda], 
eq3[tauhigh, tau1low, tau0low, mu, 
            m, lambda], 
eq4[tauhigh, tau1low, tau0low, mu, 
            m, lambda], 
eq5[tauhigh, tau1low, tau0low, mu, 
            m, lambda]};

policyrule[m_, lambda_, tauhighstart_, tau1lowstart_, tau0lowstart_, 
          mustart_] := 
FindRoot[
          eqvec[tauhigh, tau1low, tau0low, mu, m, 
            lambda], 
{tauhigh, tauhighstart}, {tau1low, 
            tau1lowstart}, {tau0low, tau0lowstart}, {mu, 
            mustart}];

Deltamain[m_, lambda_, tauhighstart_, tau1lowstart_, tau0lowstart_, 
        mustart_] := (pt = 
          policyrule[m, lambda, tauhighstart, tau1lowstart, tau0lowstart, 
            mustart]; 
u[ehigh - tauhigh] - (1 - pi[m]) 
              u[ehigh - tau0low] /. pt)

Optimal policy over [0;pibar]

eqveclowlow[tauhigh_, tau1low_, tau0low_, mu_, m_, 
          lambda_]  = 
{eq1[tauhigh, tau1low, tau0low, mu, 
            m, lambda], 
eq3[tauhigh, tau1low, tau0low, mu, 
            m, lambda], 
eq5lowlow[tauhigh, tau1low, 
            tau0low, mu, m, lambda]};

policyrulelowlow[m_, lambda_, tauhighstart_, tau1lowstart_, 
          mustart_]  := 
FindRoot[
          eqveclowlow[tauhigh, tau1low, 0, mu, m, 
            lambda], 
{tauhigh, tauhighstart}, {tau1low, 
            tau1lowstart}, {mu, mustart}];

Deltalowlow[m_, lambda_, tauhighstart_, tau1lowstart_, 
        mustart_]  :=  (pt  =  
          policyrulelowlow[m, lambda, tauhighstart, tau1lowstart, 
            mustart]; 
pt = 
          Join[pt, {tau0low -> 0}]; 
u[
            ehigh - tauhigh] /. pt)

Private Information: Solution

Grid Setup

gm =  .0005;

Solution over grid on [0,1]

mgrid = Table[m, {m, mlow, mhigh, gm}];
nm = Length[mgrid]

fvec = fpdf[mgrid];      
fvec = fvec/Total[fvec];

deltagrid = Table[0, {nm}];
tauhighgrid = Table[0, {nm}];
taulow1grid = Table[0, {nm}];
taulow0grid = Table[0, {nm}];
mugrid = Table[0, {nm}];

\(dist = 1. ; \ 
    adjcoef =  .5; \  (*\ 
      adjcoef\ might\ have\ to\ be\ adjusted\ depending\ on\ the\ parameters\ to\ achieve\ convergence\ *) 
tauhight0 =  .924; tau1lowt0 =  .1; 
    tau0lowt0 =  .1; 
    mut0 = 1.58;
\)
lambdat =  .151575;  

While[
      Abs[dist] >  .000001, 
(For[im = nm, 
          im ≥ 
            1, im--, 
(deltagrid[[im]] = 
              Delta[mgrid[[im]], lambdat, tauhight0, tau1lowt0, 
                tau0lowt0, 
                mut0]; 
tauhight0 = tauhighgrid[[im]] = tauhigh /. pt; 
tau1lowt0 = taulow1grid[[im]] = 
                tau1low /. 
                  pt; 
tau0lowt0 = taulow0grid[[im]] = 
                tau0low /. 
                  pt; 
mut0 = mugrid[[im]] = 
                mu /. pt)]; 
tauhight0 = 
          tauhighgrid[[nm]];  tau1lowt0 = taulow1grid[[nm]];  
        tau0lowt0 = taulow0grid[[nm]];  
        mut0 = mugrid[[nm]]; 
weighteddelta = 
          deltagrid (1 - mgrid) fvec; 
dist = 
          Total[weighteddelta]; 
lambdat = 
          lambdat - adjcoef dist; 
Print[{dist, 
            lambdat}];)]

Join Grid (not used in this code)

nmfull  =  nm

mgridfull  =  mgrid;
deltagridfull   =  deltagrid;
tauhighgridfull   =  tauhighgrid;
taulow1gridfull   =  taulow1grid;
taulow0gridfull   =  taulow0grid;
mugridfull   = mugrid;
fvecfull  =  fvec;

Private Information: Graphs

pstyle = {Red, AbsoluteThickness[1.6]} ;

deltag  =  
        ListPlot[
          Transpose[{mgridfull, 
              deltagridfull}], 
PlotJoined -> True, 
          PlotRange -> All, PlotStyle -> pstyle, 
          Epilog -> {Text["m", { .9,  .15}], 
              Text["△(m)", {- .15, 
                  1}]}];
Export["deltag.eps", deltag, "eps"];

fg  =  
        ListPlot[
          Table[{mgridfull[[im]], fvecfull[[im]]}, {im, 1, 
              nmfull}], 
PlotJoined -> True, 
          PlotRange -> All, 
          PlotStyle -> {Cobalt, Thickness[ .006]}];

tauhighg  =  
        ListPlot[
          Transpose[{mgridfull, 
              tauhighgridfull}], 
PlotJoined -> True, 
          AxesOrigin -> {0, 0}, 
          PlotRange -> {{0, 1}, {- .05, 1}}, 
          PlotStyle -> pstyle];

taulow1g  =  
        ListPlot[
          Transpose[{mgridfull, 
              taulow1gridfull}], 
PlotJoined -> True, 
          PlotRange -> All, PlotStyle -> pstyle];

ipibar = Floor[pibar/gm] + 1;
taulow0g  =  
        ListPlot[
          Table[{mgridfull[[im]], taulow0gridfull[[im]]}, {im, 
              ipibar + 1, nmfull}], 
PlotJoined -> 
            True, PlotRange -> All, AxesOrigin -> {0, 0}, 
          PlotStyle -> pstyle];

Full Information: Solution

Solution over grid on [0,1]

deltagridf  =  Table[0, {nm}];
tauhighgridf  =  Table[0, {nm}];
taulow1gridf  =  Table[0, {nm}];
taulow0gridf  =  Table[0, {nm}];
mugridf  =  Table[0, {nm}];

lambdaf =  0. ;

tauhight0  =   .924;  tau1lowt0 =  .1; tau0lowt0  =   .1;  
    mut0  =  1.58;

For[im = nm, 
        im ≥ 
          1, im--, 
(deltagridf[[im]]  =  
            Delta[mgrid[[im]], lambdaf, tauhight0, tau1lowt0, tau0lowt0, 
              mut0]; 
tauhight0  =  tauhighgridf[[im]] = tauhigh /. 
                pt; 
tau1lowt0  =  taulow1gridf[[im]] = 
              tau1low /. 
                pt; 
tau0lowt0  =  taulow0gridf[[im]] = 
              tau0low /. 
                pt; 
mut0  =  mugridf[[im]] = 
              mu /. pt)];

Join Grid (not used in this code)

deltagridfullf   =  deltagridf;
tauhighgridfullf   =  tauhighgridf;
taulow1gridfullf   =  taulow1gridf;
taulow0gridfullf   =  taulow0gridf;
mugridfullf   =  mugridf;

Full Information: Graphs

fstyle = {Blue, AbsoluteThickness[1.6], 
          AbsoluteDashing[{1.6, 3.2}]} ;

legendf[dx_,dy_]:={
	White,Rectangle[Scaled[{dx,dy}],Scaled[{dx+.4,dy+.2}]],
	Black,Thickness[0.001],
	Line[{Scaled[{dx,dy}],Scaled[{dx+.4,dy}],Scaled[{dx+.4,dy+.2}],Scaled[{dx,dy+.2}],Scaled[{dx,dy}]}],
	Join[fstyle,{Line[{Scaled[{dx+.03,dy+.06}],Scaled[{dx+.1,dy+.06}]}]}],
	Text["Full Information",Scaled[{dx+.12,dy+.06}],{-1,0}],
	Join[pstyle,{Line[{Scaled[{dx+.03,dy+.14}],Scaled[{dx+.1,dy+.14}]}]}],
	Text["Ex ante mechanism",Scaled[{dx+.12,dy+.14}],{-1,0}]};

deltafg  =  
        ListPlot[
          Transpose[{mgridfull, 
              deltagridfullf}], 
PlotJoined -> True, 
          PlotRange -> All, PlotStyle -> fstyle, 
          DisplayFunction :> Identity];
Show[deltafg, deltag, Epilog -> Text["m", { .9,  .15}], 
        DisplayFunction :> $DisplayFunction];

weighteddeltaf  =  
        deltagridfullf (1 - mgridfull) fvecfull;
ListPlot[
        Transpose[{mgridfull, 
            weighteddeltaf}], 
PlotRange -> All, 
        PlotJoined -> True, 
        PlotStyle -> {DarkOrange, Thickness[ .006]}];

tauhighfg  =  
        ListPlot[
          Transpose[{mgridfull, 
              tauhighgridfullf}], 
PlotJoined -> True, 
          AxesOrigin ->  {0, 0}, PlotRange -> All, 
          PlotStyle -> fstyle, DisplayFunction :> Identity];
\(\(tauhighglabel = 
        Show[tauhighfg, tauhighg, 
          Epilog -> {Text["m", { .9,  .05}], 
              Text[\*""\!\(τ\&_\)(m)"", {\(- .15\),  .5}], 
              legendf[0.05,  .8]}, 
          DisplayFunction :> $DisplayFunction];\)\)

taulow1fg  =  
        ListPlot[
          Transpose[{mgridfull, 
              taulow1gridfullf}], 
PlotJoined -> True, 
          PlotRange -> All, PlotStyle -> fstyle, 
          PlotRange -> {{0, 1}, {- .7,  .5}}, 
          DisplayFunction :> Identity];
\(\(taulow1glabel = 
        Show[taulow1fg, taulow1g, 
          Epilog -> {Text["m", { .9,  .05}], 
              Text[\*""\!\(τ\+_\_1\)(m)"", {\(- .15\), \(- .5\)}], 
              legendf[ .6, 0]}, 
          DisplayFunction :> $DisplayFunction];\)\)

taulow0fg  =  
        ListPlot[
          Table[{mgridfull[[im]], taulow0gridfullf[[im]]}, {im, 
              ipibar + 1, nmfull}], 
PlotRange -> All, 
          PlotJoined -> True, PlotStyle -> fstyle, 
          AxesOrigin -> {0, 0}, 
          DisplayFunction :> Identity];
\(\(taulow0glabel = 
        Show[taulow0fg, taulow0g, 
          Epilog -> {Text["m", { .9,  .07}], 
              Text[\*""\!\(τ\+_\_0\)(m)"", {\(- .15\), \(- .25\)}], legendf[ .6, 0]}, 
          DisplayFunction :> $DisplayFunction];\)\)

Ex Post: Optimal Policy

Optimal policy over [0,1]

policyruleex[m_, lambdastart_, tauhighstart_, tau1lowstart_, 
          tau0lowstart_, mustart_] := 
If[
          m > pibar, 
policyrulemainex[m, lambdastart, 
            tauhighstart, tau1lowstart, tau0lowstart, 
            mustart], 
policyrulelowlowex[m, lambdastart, 
            tauhighstart, tau1lowstart, 
            mustart]
];

Optimal policy over (pibar,phigh]

eq6[tauhigh_, tau1low_, tau0low_, mu_, m_, lambda_]  :=  
        u[ehigh - tauhigh]  -  (1 - pi[m]) u[
              ehigh - tau0low];

eqvecex[tauhigh_, tau1low_, tau0low_, mu_, m_, 
          lambda_] = 
{eq1[tauhigh, tau1low, tau0low, mu, 
            m, lambda], 
eq3[tauhigh, tau1low, tau0low, mu, 
            m, lambda], 
eq4[tauhigh, tau1low, tau0low, mu, 
            m, lambda], 
eq5[tauhigh, tau1low, tau0low, mu, 
            m, lambda], 
eq6[tauhigh, tau1low, tau0low, mu, 
            m, lambda]};

mean[m_]  :=  
        m elow  +  (1 - m) ehigh;

    rsrule[m_]  :=  {tauhigh -> ehigh - mean[m],  
          tau1low ->  elow - mean[m], tau0low -> elow - mean[m],  
          mu -> u'[mean[m]],  
          lambda -> 0};

    rsdelta[m_]  :=  
        u[mean[m]]  -  (1 - pi[m]) u[
              ehigh  -  elow  +  mean[m]];

policyrulemainex[m_, lambdastart_, tauhighstart_, tau1lowstart_, 
        tau0lowstart_, mustart_]  :=  
If[
        rsdelta[m] ≥ 0, 
        rsrule[m], 
FindRoot[
          eqvecex[tauhigh, tau1low, tau0low, mu, m, 
            lambda], 
{tauhigh, tauhighstart}, {tau1low, 
            tau1lowstart}, {tau0low, tau0lowstart},  {mu, mustart}, {lambda, 
            lambdastart}]]

Optimal policy over [0;pibar]

policyrulelowlowex[m_, lambdastart_, tauhighstart_, tau1lowstart_, 
        mustart_]  :=  rsrule[m]

Ex Post: Solution

Solution over grid on [0,1]

tauhighgridex  =  Table[0, {nm}];
taulow1gridex  =  Table[0, {nm}];
taulow0gridex  =  Table[0, {nm}];
mugridex  =  Table[0, {nm}];
lambdagridex  =  Table[0, {nm}];

tauhight0  =   .924;  tau1lowt0 =  .1; tau0lowt0  =   .1;  
    mut0  =  1.58;  lambdat0  =   .1;
For[im = nm, 
        im ≥ 
          1, im--, 
(pt =  
            policyruleex[mgrid[[im]], lambdat0, tauhight0, tau1lowt0, 
              tau0lowt0, 
              mut0]; 
tauhight0  =  tauhighgridex[[im]] = 
              tauhigh /. 
                pt; 
tau1lowt0  =  taulow1gridex[[im]] = 
              tau1low /. 
                pt; 
tau0lowt0  =  taulow0gridex[[im]] = 
              tau0low /. 
                pt; 
mut0  =  mugridex[[im]] = 
              mu /. pt; 
lambdat0  =  lambdagridex[[im]] = lambda /. pt)];

Join Grid (not used in this code)

tauhighgridfullex   = tauhighgridex;
taulow1gridfullex   =  taulow1gridex;
taulow0gridfullex   =  taulow0gridex;
mugridfullex   =  mugridex;
lambdagridfullex   =  lambdagridex;
deltagridfullex = 
        u[ehigh - tauhighgridfullex]  -  (1 - pi /@ mgridfull) 
            u[ehigh - taulow0gridfullex];

Ex Post: Graphs

exstyle = {ForestGreen, AbsoluteThickness[1.6], 
          AbsoluteDashing[{4.8, 4.8}]} ;

legendex[dx_,dy_]:={
	White,Rectangle[Scaled[{dx,dy}],Scaled[{dx+.4,dy+.28}]],
	Black,Thickness[0.001],
	Line[{Scaled[{dx,dy}],Scaled[{dx+.4,dy}],Scaled[{dx+.4,dy+.28}],Scaled[{dx,dy+.28}],Scaled[{dx,dy}]}],
	Join[fstyle,{Line[{Scaled[{dx+.03,dy+.06}],Scaled[{dx+.1,dy+.06}]}]}],
	Text["Full Information",Scaled[{dx+.12,dy+.06}],{-1,0}],
	Join[pstyle,{Line[{Scaled[{dx+.03,dy+.14}],Scaled[{dx+.1,dy+.14}]}]}],
	Text["Ex Ante Mechanism",Scaled[{dx+.12,dy+.14}],{-1,0}],
	Join[exstyle,{Line[{Scaled[{dx+.03,dy+.22}],Scaled[{dx+.1,dy+.22}]}]}],
	Text["Ex Post Mechanism",Scaled[{dx+.12,dy+.22}],{-1,0}]};

tauhighexg  =  
        ListPlot[
          Transpose[{mgridfull, 
              tauhighgridfullex}], 
PlotJoined -> 
            True, PlotRange -> All, PlotStyle -> exstyle, 
          DisplayFunction :> Identity];
\(\(tauhighexglabel = 
        Show[tauhighfg, tauhighg, tauhighexg, 
          Epilog -> {Text["m", { .9, \(- .03\)}], 
              Text[\*""\!\(τ\&_\)(m)"", {\(- .15\),  .5}], 
              legendex[0.05,  .72]}, 
          DisplayFunction :> $DisplayFunction];\)\)
Export["tauhighex.eps", 
        tauhighexglabel, "eps"];

taulow1exg  =  
        ListPlot[
          Transpose[{mgridfull, 
              taulow1gridfullex}], 
PlotJoined -> 
            True, PlotRange -> All, PlotStyle -> exstyle, 
          DisplayFunction :> Identity];
\(\(taulow1exglabel = 
        Show[taulow1fg, taulow1g, taulow1exg, 
          Epilog -> {Text["m", { .9,  .05}], 
              Text[\*""\!\(τ\+_\_1\)(m)"", {\(- .15\), \(- .5\)}], 
              legendex[ .6, 0]}, 
          DisplayFunction :> $DisplayFunction];\)\)
Export["taulow1ex.eps", 
        taulow1exglabel, "eps"];

taulow0exg  =  
        ListPlot[
          Table[{mgridfull[[im]], taulow0gridfullex[[im]]}, {im, 
              ipibar + 1, nmfull}], 
PlotJoined -> 
            True, PlotRange -> All, PlotStyle -> exstyle, 
          DisplayFunction :> Identity];
\(\(taulow0exglabel = 
        Show[taulow0fg, taulow0g, taulow0exg, 
          Epilog -> {Text["m", { .9,  .07}], 
              Text[\*""\!\(τ\+_\_0\)(m)"", {\(- .15\), \(- .25\)}], legendex[ .6, 0]}, 
          DisplayFunction :> $DisplayFunction];\)\)
Export["taulow0ex.eps", 
        taulow0exglabel, "eps"];

Minimax Direct Mechanism: Solution

xbar = 1 ;  (* 
      Maximal probability of cheating against which we guard *)

Check of the ex post solution

lambdagridmmex =  u'[elow  -  taulow1gridfullex]/u'[
              ehigh - tauhighgridfullex] - 1;

For[im = 2, 
        im ≤ 
          nmfull, im++, 
lambdagridmmex[[im]] = (lambdagridmmex[[im]] - 
                  Sum[lambdagridmmex[[iim]] 
                      fpdf[1 - (1 - mgridfull[[im]])/(1 - 
                                  mgridfull[[iim]])]/
                        fpdf[mgridfull[[im]]], {iim, 1, im - 1}]) 
              fpdf[mgridfull[[im]]]/
                fpdf[0];
];

nontrivialmm = True;

If[
        Min[lambdagridmmex] ≥ -10^(-7), (ListPlot[
            Transpose[{mgridfull, lambdagridmmex}], PlotJoined -> True, 
            PlotStyle -> Blue]; nontrivialmm = False)];

Grid Setup

gmmm =  .005;

mgridmm  =  Table[m, {m, 0, 1, gmmm}];
nmmm  =  Length[mgridmm]

deltagridmm = Table[0, {nmmm}];
tauhighgridmm = Table[0, {nmmm}];
taulow1gridmm = Table[0, {nmmm}];
taulow0gridmm = Table[0, {nmmm}];
mugridmm = Table[0, {nmmm}];
lambdagridmm = Table[0, {nmmm}];
incentivegridmm = Table[0, {nmmm}];

imlowmm = 1;    
imhighmm = nmmm;     
imxbarmm = 
      Min[Ceiling[(mlow + (1 - mlow) xbar)/gmmm] + 1, 
        nmmm];

Solution over grid on [0,1]

adjcoefmm =  .01 ; ite = 0 ; (* 
      This requires fine tuning depending on the application *)

While[
        nontrivialmm, 
( 
 (* 
            optimal taxes given lambda *) 
tauhight0 =  .924; tau1lowt0 =  .1; tau0lowt0 =  .1; 
          mut0 = 1.58; 
deltagridmm[[imhighmm]] = 
            Delta[1, Sum[lambdagridmm[[iim]], {iim, imlowmm, imxbarmm}], 
              tauhight0, tau1lowt0, tau0lowt0, mut0]; 
For[
            im = imhighmm - 1, 
            im ≥ 
              imlowmm, im--, 
(deltagridmm[[im]] = Delta[mgridmm[[im]], 
Sum[
                    lambdagridmm[[iim]] 
                      fpdf[1 - (1 - mgridmm[[im]])/(1 - 
                                  mgridmm[[iim]])]/
                        fpdf[mgridmm[[im]]], {iim, imlowmm, 
                      Min[im, imxbarmm]}], 
tauhight0, 
                  tau1lowt0, tau0lowt0, 
                  mut0]; 
tauhight0 = tauhighgridmm[[im]] = 
                  tauhigh /. 
                    pt; 
tau1lowt0 = taulow1gridmm[[im]] = 
                  tau1low /. 
                    pt; 
tau0lowt0 = taulow0gridmm[[im]] = 
                  tau0low /. 
                    pt; 
mut0 = mugridmm[[im]] = 
                  mu /. pt;
)]; 

 (* 
            incentive compatibility constraints *) 
For[
            im = imlowmm, 
            im ≤ 
              imhighmm - 
                1, im++, 
(x = mtildalow = (im - 
                        1) gmmm; 
mtildahigh = 
                1; 
imtildahigh = 
                nmmm; 
incentivegridmm[[im]] = 
                Sum[deltagridmm[[iim]] (1 - mgridmm[[iim]]) 
                      fpdf[(mgridmm[[iim]] - x)/(1 - x)], {iim, 
                      im, imtildahigh}]/
                  Sum[fpdf[(mgridmm[[iim]] - x)/(1 - x)], {iim, 
                      im, imtildahigh}];   (* 
                We pick a scaling that hopefully will behave well *)  
)]; 
incentivegridmm[[imhighmm]] = deltagridmm[[imhighmm]]; 

 (* 
            loop exit condition *) 
criteria1 = 
            Max[
              Abs[Table[
                  incentivegridmm[[im]] lambdagridmm[[im]], {im, 
                    imlowmm, imxbarmm}]]]; 
criteria2 = 
            Min[Table[
                incentivegridmm[[im]], {im, imlowmm, 
                  imxbarmm}]]; 
Print[{criteria1, 
              criteria2, ite}]; 
If[
            criteria1 < 0.00001  &&  criteria2 > -0.00001  , 
            Break[]]; 
ite = ite + 1;  
          If[ite > 10, adjcoefmm =  .01]; 
 (* 
            adjustment of lambda *) 
For[im = imlowmm, 
            im ≤ 
              imxbarmm, im++, 
lambdagridmm[[im]] = 
              Max[0, lambdagridmm[[im]] - 
                  adjcoefmm incentivegridmm[[im]]]];

)];

Minimax Direct Mechanism: Graphs

If[nontrivialmm, 
        ListPlot[
          Table[{mgridmm[[im]], lambdagridmm[[im]]}, {im, 1, 
              nmmm - 1}], PlotJoined -> True, PlotStyle -> Blue, 
          PlotRange -> All]];

If[nontrivialmm, 
        ListPlot[Transpose[{mgridmm, incentivegridmm}], 
          PlotJoined -> True, PlotStyle -> Red, 
          PlotRange -> All]];

mmstyle = {Navy, AbsoluteThickness[1.6], 
          AbsoluteDashing[{1.6, 3.2}]} ;

legendmm[dx_,dy_]:={
	White,Rectangle[Scaled[{dx,dy}],Scaled[{dx+.4,dy+.28}]],
	Black,Thickness[0.001],
	Line[{Scaled[{dx,dy}],Scaled[{dx+.4,dy}],Scaled[{dx+.4,dy+.28}],Scaled[{dx,dy+.28}],Scaled[{dx,dy}]}],
	Join[pstyle,{Line[{Scaled[{dx+.03,dy+.06}],Scaled[{dx+.1,dy+.06}]}]}],
	Text["Ex Ante Mechanism",Scaled[{dx+.12,dy+.06}],{-1,0}],
	Join[exstyle,{Line[{Scaled[{dx+.03,dy+.14}],Scaled[{dx+.1,dy+.14}]}]}],
	Text["Ex Post Mechanism",Scaled[{dx+.12,dy+.14}],{-1,0}],
	Join[mmstyle,{Line[{Scaled[{dx+.03,dy+.22}],Scaled[{dx+.1,dy+.22}]}]}],
	Text["Minimax Mechanism",Scaled[{dx+.12,dy+.22}],{-1,0}]};

tauhighmmg  =  
        ListPlot[
          Transpose[{mgridmm, 
              tauhighgridmm}], 
PlotRange -> {{0, 
                1}, {-6, 1}}, PlotJoined -> True, 
          AxesOrigin -> {0, 0}, PlotStyle -> mmstyle, 
          DisplayFunction :> Identity];
tauhighmmglabel = 
        Show[tauhighg, tauhighexg, tauhighmmg, 
          PlotRange -> {{0, 1}, {- .1, 1}}, 
          Epilog -> {Text["m", { .9, - .04}], 
              legendmm[ .02,  .72]}, 
          DisplayFunction :> $DisplayFunction];

taulow1mmg  =  
        ListPlot[
          Transpose[{mgridmm, 
              taulow1gridmm}], 
PlotRange -> All, 
          PlotJoined -> True, AxesOrigin -> {0, 0}, 
          PlotStyle -> mmstyle, 
          DisplayFunction :> Identity];
taulow1mmglabel = 
        Show[taulow1g, taulow1exg, taulow1mmg, 
          Epilog -> {Text["m", { .9,  .05}], legendmm[ .6, 0]}, 
          DisplayFunction :> $DisplayFunction];

ipibarmm = Floor[pibar/gmmm] + 1;

taulow0mmg  =  
        ListPlot[
          Table[{mgridmm[[im]], taulow0gridmm[[im]]}, {im, 
              ipibarmm + 1, nmmm}], 
PlotRange -> All, 
          PlotJoined -> True, AxesOrigin -> {0, 0}, 
          PlotStyle -> mmstyle, 
          DisplayFunction :> Identity];
taulow0mmglabel = 
        Show[taulow0g, taulow0exg, taulow0mmg, 
          Epilog -> {Text["m", { .9,  .08}], legendmm[ .6, 0]}, 
          DisplayFunction :> $DisplayFunction];