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"];
Off[Display::"pserr"];

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;\)\ \ \  (*\ 
      maximum\ fraction\ of\ audited\ households\ *) 

    \(mlow\  = 0;\)\ \ \ \  (*\ 
      low\ bound\ of\ probability\ of\ low\ endowment\ *) 

    \(mhigh\  = 1;\)\)\(\ \ \ \ \)\( (*\ 
      upper\ bound\ of\ probability\ of\ low\ endowment\ *) \)\)\)

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 ;

fpdf[m_] := 1 + 0  m

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

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

eq4high[tauhigh_, tau1low_, 
        tau0low_, mu_, m_, lambda_]  =  
      mhigh  u'[elow - tau0low]  -  
        lambda (1 - mhigh) u'[ehigh - tau0low]  -  
        mhigh 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 over [plow;phigh]

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 [max{plow,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)

Optimal policy over [pibar;plow]

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

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

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

Optimal policy over [phigh;1]

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

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

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

Private Information: Solution

Grid Setup

gm =  .0005;

Solution over grid on [plow;phigh]

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 = 0;  

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}];)]

Solution over grid on (pibar;plow)

mgridlow  =  
        Table[m, {m, pibar + gm, mlow - gm, 
            gm}];
nmlow  =  Length[mgridlow]

deltalowgrid  =  Table[0, {nmlow}];
tauhighlowgrid  =  Table[0, {nmlow}];
taulow1lowgrid  =  Table[0, {nmlow}];
taulow0lowgrid  =   Table[0, {nmlow}];
mulowgrid  =  Table[0, {m, nmlow}];

tauhight0 =  tauhighgrid[[1]];
tau1lowt0 =   taulow1grid[[1]];
tau0lowt0  =  taulow0grid[[1]];
mut0 =  mugrid[[1]];

For[im = nmlow, 
        im ≥ 
          1, im--, 
(deltalowgrid[[im]]  =  
            Deltalow[mgridlow[[im]], lambdat, tauhight0, tau1lowt0, 
              tau0lowt0,  
              mut0]; 
tauhight0 = tauhighlowgrid[[im]] = 
              tauhigh /. 
                pt; 
tau1lowt0 = taulow1lowgrid[[im]] = 
              tau1low /. 
                pt; 
tau0lowt0 = taulow0lowgrid[[im]] = 
              tau0low /. 
                pt; 
mut0 = mulowgrid[[im]] = 
              mu /. pt)];

Solution over grid on [0;min{pibar,plow}]

mgridlowlow  =  
        Table[m, {m, 0, Min[pibar, mlow - gm], 
            gm}];
nmlowlow  =  Length[mgridlowlow]

deltalowlowgrid  =  Table[0, {nmlowlow}];
tauhighlowlowgrid  =  Table[0, {nmlowlow}];
taulow1lowlowgrid  =  Table[0, {nmlowlow}];
taulow0lowlowgrid  =   Table[0, {nmlowlow}];
mulowlowgrid  =  Table[0, {nmlowlow}];

tauhight0 =  tauhighgrid[[1]];
tau1lowt0 =   taulow1grid[[1]];
mut0 =  mugrid[[1]];

For[im = nmlowlow, 
        im ≥ 
          1, im--, 
(deltalowlowgrid[[im]]  =  
            Deltalowlow[mgridlowlow[[im]], lambdat, tauhight0, tau1lowt0, 
              mut0]; 
tauhight0  =  tauhighlowlowgrid[[im]] = 
              tauhigh /. 
                pt; 
tau1lowt0  =  taulow1lowlowgrid[[im]] = tau1low /. 
                pt; 
mut0  =  mulowlowgrid[[im]] = mu /. pt)];

Solution over grid on (phigh;1]

mgridhigh  =  
        Table[m, {m, mhigh + gm, 1, gm}];
nmhigh  =  Length[mgridhigh]

deltahighgrid  =  Table[0, {nmhigh}];
tauhighhighgrid  =  Table[0, {nmhigh}];
taulow1highgrid  =  Table[0, {nmhigh}];
taulow0highgrid  =   Table[0, {nmhigh}];
muhighgrid  =  Table[0, {nmhigh}];

tauhight0 =  tauhighgrid[[nm]];
tau1lowt0 =   taulow1grid[[nm]];
tau0lowt0  =  taulow0grid[[nm]];
mut0 =  mugrid[[nm]];

For[im  =  1, 
        im ≤ 
          nmhigh, im++, 
(deltahighgrid[[im]]  =  Deltahigh[mgridhigh[[im]], lambdat, tauhight0, tau1lowt0, tau0lowt0, 
              mut0]; 
tauhight0 = tauhighhighgrid[[im]] = 
              tauhigh /. 
                pt; 
tau1lowt0 = taulow1highgrid[[im]] = tau1low /. 
                pt; 
tau0lowt0 = taulow0highgrid[[im]] = tau0low /. pt; 
mut0 = muhighgrid[[im]] = 
              mu /. pt)];

Join Grid

nmfull  =  nmlowlow + nmlow + nm + nmhigh

mgridfull  =  
        Join[mgridlowlow, mgridlow, mgrid, 
          mgridhigh];
deltagridfull   =  
        Join[deltalowlowgrid, deltalowgrid, deltagrid, 
          deltahighgrid];
tauhighgridfull   =  
        Join[tauhighlowlowgrid, tauhighlowgrid, tauhighgrid, 
          tauhighhighgrid];
taulow1gridfull   =  
        Join[taulow1lowlowgrid, taulow1lowgrid, taulow1grid, 
          taulow1highgrid];
taulow0gridfull   =  
        Join[taulow0lowlowgrid, taulow0lowgrid, taulow0grid, 
          taulow0highgrid];
mugridfull   =  
        Join[mulowlowgrid, mulowgrid, mugrid, 
          muhighgrid];
fvecfull  =  
        Join[Table[0, {nmlowlow + nmlow}], fvec, 
          Table[0, {nmhigh}]];

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 = Ceiling[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 [plow;phigh]

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)];

Solution over grid on [pibar;plow)

deltalowgridf  =  Table[0, {nmlow}];
tauhighlowgridf  =  Table[0, {nmlow}];
taulow1lowgridf  =  Table[0, {nmlow}];
taulow0lowgridf  =   Table[0, {nmlow}];
mulowgridf  =  Table[0, {nmlow}];

tauhight0 =  tauhighgridf[[1]];
tau1lowt0 =   taulow1gridf[[1]];
tau0lowt0  =  taulow0gridf[[1]];
mut0 =  mugridf[[1]];

For[im = nmlow, 
        im ≥ 
          1, im--, 
(deltalowgridf[[im]]  =  
            Deltalow[mgridlow[[im]], lambdaf, tauhight0, tau1lowt0, 
              tau0lowt0, 
              mut0]; 
tauhight0  =  tauhighlowgridf[[im]] = 
              tauhigh /. 
                pt; 
tau1lowt0  =  taulow1lowgridf[[im]] = 
              tau1low /. 
                pt;  
tau0lowt0  =  taulow0lowgridf[[im]] = tau0low /. 
                pt; 
mut0  =  mulowgridf[[im]] = 
              mu /. pt)];

Solution over grid on [0;min{pibar,plow}]

deltalowlowgridf  =  Table[0, {nmlowlow}];
tauhighlowlowgridf  =  Table[0, {nmlowlow}];
taulow1lowlowgridf  =  Table[0, {nmlowlow}];
taulow0lowlowgridf  =   Table[0, {nmlowlow}];
mulowlowgridf  =  Table[0, {nmlowlow}];

tauhight0 =  tauhighgridf[[1]];
tau1lowt0 =   taulow1gridf[[1]];
mut0 =  mugridf[[1]];

For[im = nmlowlow, 
        im ≥ 
          1, im--, 
(deltalowlowgridf[[im]]  =  
            Deltalowlow[mgridlowlow[[im]], lambdaf, tauhight0, tau1lowt0, 
              mut0]; 
tauhight0  =  tauhighlowlowgridf[[im]] = tauhigh /. 
                pt; 
tau1lowt0  =  taulow1lowlowgridf[[im]] = 
              tau1low /. 
                pt; 
mut0  =  mulowlowgridf[[im]] = mu /. pt)];

Solution over grid on [phigh;1]

deltahighgridf  =  Table[0, {nmhigh}];
tauhighhighgridf  =  Table[0, {nmhigh}];
taulow1highgridf  =  Table[0, {nmhigh}];
taulow0highgridf  =   Table[0, {nmhigh}];
muhighgridf  =  Table[0, {nmhigh}];

tauhight0 =  tauhighgridf[[nm]];
tau1lowt0 =   taulow1gridf[[nm]];
tau0lowt0  =  taulow0gridf[[nm]];
mut0 =  mugridf[[nm]];

For[im  =  1, 
        im ≤ 
          nmhigh, im++, 
(deltahighgridf[[im]]  =  Deltahigh[mgridhigh[[im]], lambdaf, tauhight0, tau1lowt0, tau0lowt0, 
              mut0]; 
tauhight0  =  tauhighhighgridf[[im]] = 
              tauhigh /. 
                pt; 
tau1lowt0  =  taulow1highgridf[[im]] = 
              tau1low /. 
                pt; 
tau0lowt0  =  taulow0highgridf[[im]] = 
              tau0low /. 
                pt; 
mut0  =  muhighgridf[[im]] = 
              mu /. pt)];

Join Grid

deltagridfullf   =  
        Join[deltalowlowgridf, deltalowgridf, deltagridf, 
          deltahighgridf];
tauhighgridfullf   =  
        Join[tauhighlowlowgridf, tauhighlowgridf, tauhighgridf, 
          tauhighhighgridf];
taulow1gridfullf   =  
        Join[taulow1lowlowgridf, taulow1lowgridf, taulow1gridf, 
          taulow1highgridf];
taulow0gridfullf   =  
        Join[taulow0lowlowgridf, taulow0lowgridf, taulow0gridf, 
          taulow0highgridf];
mugridfullf   =  
        Join[mulowlowgridf, mulowgridf, mugridf, muhighgridf];

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];\)\)
Export["tauhighg.eps", tauhighglabel, "eps"];

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];\)\)
Export["taulow1g.eps", taulow1glabel, "eps"];

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];\)\)
Export["taulow0g.eps", taulow0glabel, "eps"];

Ex Post: Optimal Policy

Optimal policy over [plow;phigh]

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 [max{plow,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]

Optimal policy over (pibar;plow)

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

policyrulelowex[m_, lambdastart_, tauhighstart_, tau1lowstart_, 
        tau0lowstart_, mustart_]  :=  
If[
        rsdelta[m] ≥ 0, 
        rsrule[m], 
FindRoot[
          eqveclowex[tauhigh, tau1low, tau0low, mu, m, 
            lambda], 
{tauhigh, tauhighstart}, {tau1low, 
            tau1lowstart}, {tau0low, tau0lowstart},  {mu, mustart}, {lambda, 
            lambdastart}, MaxIterations -> 100]]

Optimal policy over (phigh;1]

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

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

Ex Post: Solution

Solution over grid on [plow;phigh]

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)];

Solution over grid on [0;pibar]

tauhighlowlowgridex  =  Table[0, {nmlowlow}];
taulow1lowlowgridex  =  Table[0, {nmlowlow}];
taulow0lowlowgridex  =   Table[
          0, {nmlowlow}];
mulowlowgridex  =  
        Table[0, {nmlowlow}];
lambdalowlowgridex  =  Table[0, {nmlowlow}];

tauhight0  =   .924;  tau1lowt0 =  .1;  mut0  =  1.58;  
    lambdat0  =   .1;
For[im = nmlowlow, 
        im ≥ 
          1, im--, 
(pt =  
            policyrulelowlowex[mgridlowlow[[im]], lambdat0, tauhight0, 
              tau1lowt0, 
              mut0]; 
tauhight0  =  tauhighlowlowgridex[[im]] = 
              tauhigh /. 
                pt; 
tau1lowt0  =  taulow1lowlowgridex[[im]] = 
              tau1low /. 
                pt; 
mut0  =  mulowlowgridex[[im]] = 
              mu /. pt; 
lambdat0  =  lambdalowlowgridex[[im]] = lambda /. pt)];

Solution over grid on (pibar;plow)

tauhighlowgridex  =  Table[0, {nmlow}];
taulow1lowgridex  =  Table[0, {nmlow}];
taulow0lowgridex  =  
        Table[0, {nmlow}];
mulowgridex  =  Table[0, {nmlow}];
lambdalowgridex  =  Table[0, {nmlow}];

tauhight0  =   .924;  tau1lowt0 =  .1; tau0lowt0  =   .1;  
    mut0  =  1.58;  lambdat0  =   .1;
For[im = nmlow, 
        im ≥ 
          1, im--, 
(pt =  
            policyrulelowex[mgridlow[[im]], lambdat0, tauhight0, 
              tau1lowt0, tau0lowt0, 
              mut0]; 
tauhight0  =  tauhighlowgridex[[im]] = 
              tauhigh /. 
                pt; 
tau1lowt0  =  taulow1lowgridex[[im]] = 
              tau1low /. 
                pt; 
tau0lowt0  =  taulow0lowgridex[[im]] =  
              tau0low /. 
                pt; 
mut0  = mulowgridex[[im]] = 
              mu /. pt; 
lambdat0  =  lambdalowgridex[[im]] = lambda /. pt)];

Solution over grid on (phigh;1]

tauhighhighgridex  =  Table[0, {nmhigh}];
taulow1highgridex  =  Table[0, {nmhigh}];
taulow0highgridex  =  
        Table[0, {nmhigh}];
muhighgridex  =  Table[0, {nmhigh}];
lambdahighgridex  =  Table[0, {nmhigh}];

tauhight0  =   .924;  tau1lowt0 =  .1; tau0lowt0  =   .1;  
    mut0  =  1.58;  lambdat0  =   .1;
For[im = nmhigh, 
        im ≥ 
          1, im--, 
(pt =  
            policyrulehighex[mgridhigh[[im]], lambdat0, tauhight0, 
              tau1lowt0, tau0lowt0, 
              mut0]; 
tauhight0  =  tauhighhighgridex[[im]] = 
              tauhigh /. 
                pt; 
tau1lowt0  =  taulow1highgridex[[im]] = tau1low /. 
                pt; 
tau0lowt0  =  taulow0highgridex[[im]] = tau0low /. 
                pt; 
mut0  =  muhighgridex[[im]] = mu /. pt; 
lambdat0  =  lambdahighgridex[[im]] = lambda /. pt)];

Join Grid

tauhighgridfullex   =  
        Join[tauhighlowlowgridex, tauhighlowgridex, tauhighgridex, 
          tauhighhighgridex];
taulow1gridfullex   =  
        Join[taulow1lowlowgridex, taulow1lowgridex, taulow1gridex, 
          taulow1highgridex];
taulow0gridfullex   =  
        Join[taulow0lowlowgridex, taulow0lowgridex, taulow0gridex, 
          taulow0highgridex];
mugridfullex   =  
        Join[mulowlowgridex, mulowgridex, mugridex, 
          muhighgridex];
lambdagridfullex   =  
        Join[lambdalowlowgridex, lambdalowgridex, lambdagridex, 
          lambdahighgridex];
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"];