Studying Soheyla’s constraints

Soh[x_]:=Which[0<x<1,x+1/2,1<=x<15/8,Sqrt[2x+1/4],15/8<=x<9/4,2/3x+3/4,9/4<=x<3,1/3x+3/2,3<=x,1/2x+1,x<0,-10];
(* using conservative bound *)
Psi0[xx_]:=(x-xx)^2/2+1/2(x+xx)-2/3alpha x+2/3 xx^2+xx/3 ; 
(* using improved Castelnuovo bound *)
Psi[xx_]:=(x-xx)^2/2+1/2(x+xx)-2/3alpha x+1/2 xx^2+xx/2 ;

Simplify[Psi[1/k]/.{alpha->3/4(x+1)}/.{x->((1+k)/k)}]

Solve[Psi[x+1/2-alpha]==0,alpha]

Series[(1/6) (6+5 x-(Sqrt[9-12 x+7 (x^2)])),{x,Infinity,0}]

Show[Plot[Soh[x],{x,0,4}],RegionPlot[Psi[x+1/2-alpha]<0,{x,0,4},{alpha,0,4}]]

Plot[{Soh[x]-(1/6) (6+5 x-(Sqrt[9-12 x+7 (x^2)]))},{x,0,4}]

Solve[(1/6) (6+5 x-(Sqrt[9-12 x+7 (x^2)]))==2/3x+3/4]//N

15

Factor[%]

Series[alpha/.Solve[Psi[1/k]==0,alpha],{k,Infinity,5}]

Solve[((3 (-1+x))/(2 x k))==(3/(2 x (k^2))),x]

Solve[{Psi[1/k]==0,alpha==3/4(x+1)},x]

Plot[{Soh[x],Max[x/2+1,Sqrt[2x+1/4]]},{x,0,4}]

RegionPlot[alpha>Soh[x]&& alpha<x+1/2,{x,0,4},{alpha,0,3}]

RegionPlot[{Psi[0]<0&&Psi[x+1/2-alpha]<0&& alpha<x+1/2},{x,0,4},{alpha,0,3},PlotPoints->100]

{RegionPlot[Psi[x+1/2-alpha]<0,{x,0,4},{alpha,0,3}],RegionPlot[Psi[0]<0,{x,0,4},{alpha,0,3}]}

Series[alpha/.Solve[Psi0[x+1/2-alpha]==0,alpha],{x,Infinity,0}]

N[(1/6) (5+(Sqrt[7]))]

Plot[{alpha-Sqrt[alpha^2-2x],alpha+Sqrt[alpha^2-2x]}/.alpha->Soh[x]+.0005,{x,0,4}]
Plot[2Sqrt[alpha^2-2x]/.alpha->Soh[x]+.01,{x,0,4}]

(* in (mu,M) plane *)With[{kappa=1},Show[Plot[{-mu^2/2kappa-mu/2},{mu,0,4kappa},PlotStyle->Red],Plot[Table[n mu+kappa n(n+1/2)-2kappa/3 (mu/kappa+n) Soh[mu/kappa+n],{n,0,3}],{mu,0,4kappa}],PlotRange->{-3,4}]]

(* in (mu,g) plane *)
With[{kappa=1},Show[Plot[{1+mu^2/2kappa+mu/2},{mu,0,4kappa},PlotStyle->Red],Plot[Table[1-n mu-kappa n(n+1/2)+2kappa/3 (mu/kappa+n) Soh[mu/kappa+n],{n,0,4}],{mu,0,4kappa}],PlotRange->{-8,4}]]

Show[Table[RegionPlot[xx<=x+1/2-a&&-1/2xx^2-1/2xx<=-2/3aa xx&&-2/3aa xx<=1/2(x-xx)^2+1/2x+1/2xx-2/3 x a,{xx,0,4},{aa,0,4}],{x,0,6,.2},{a,1/2x+1,4,.2}],Plot[{1/2xx+1,3/4(xx+1)},{xx,0,4},PlotStyle->{Red,Green}]]

Show[Table[RegionPlot[xx<=x+1/2-a&&-1/2xx^2-1/2xx<=-2/3aa xx<=1/2(x-xx)^2+1/2x+1/2xx-2/3 x a,{xx,0,4},{aa,0,4}],{x,0,6,.2},{a,fcon[x],4,.2}],Plot[{fcon[x],1/2x+1},{x,0,6},PlotStyle->{Red,Green}]]

Show[Table[RegionPlot[xx<=x+1/2-a&&-1/2xx^2-1/2xx<=-2/3aa xx<=1/2(x-xx)^2+1/2x+1/2xx-2/3 x a&&-2/3 a x+2/3 aa xx+x+xx<=0,{xx,0,4},{aa,0,4}],{x,0,6,.2},{a,fcon[x],4,.2}],Plot[{fcon[x],1/2x+1},{x,0,6},PlotStyle->{Red,Green}]]

BMT bound and walls of marginal stability

ClearAll[b,t,w,Z,W,Zt,Wt,ch0,ch1,ch2,ch3,cch0,cch1,cch2,cch3]  (* w=1/2 b^2+ 1/6 t^2 *)

(* Here {ch0_,ch1_,ch2_,ch3_} stand for ch0H^3=kappa p0, ch1H^2=kappa p1, ch2H=-q1, ch3=q0*)

Tobw[{ch0_,ch1_,ch2_,ch3_}]:={ch1/ch0,ch2/ch0};
Tobwp[{ch0_,ch1_,ch2_,ch3_}]:={2ch1/ch1,3ch3/ch1};
Disc[{ch0_,ch1_,ch2_,ch3_}]:=ch1^2-2 ch0 ch2;
BMT[{ch0_,ch1_,ch2_,ch3_},{b_,w_}]:=(ch1^2-2ch0 ch2)w+(3 ch0 ch3-ch1 ch2)b+(2ch2^2-3ch1 ch3);
BMTSlope[{ch0_,ch1_,ch2_},{b_,t_}]:=(-t^3 ch0/6 + t (ch2-b ch1+b^2/2ch0))/(t^2(ch1-b ch0));
FTSlope[{ch0_,ch1_,ch2_},{b_,w_}]:=(ch2-w ch0)/(ch1-b ch0);
FTWall[{ch0_,ch1_,ch2_},{cch0_,cch1_,cch2_},{b_,w_}]:=b cch2 ch0-cch2 ch1-b cch0 ch2+cch1 ch2-cch1 ch0 w+cch0 ch1 w;

Simplify[(t BMTSlope[{ch0,ch1,ch2},{b,t}]+b)/FTSlope[{ch0,ch1,ch2},{b,1/2b^2+1/6 t^2 }]]

(* Large volume central charge -- set eps=1 below *)
ZZ[{ch0_,ch1_,ch2_,ch3_},{b_,t_}]:=ch3-ch2(b+I t)+1/2ch1(b+I t)^2-ch0 1/6(b+I t)^3;
Z[{ch0_,ch1_,ch2_,ch3_},{b_,t_}]:=-t^2/2(ch1-b ch0)+eps(ch3-b ch2+b^2/2ch1-b^3/6 ch0)-I t (ch2-b ch1+b^2/2ch0)+I/6 t^3 ch0;
repch3={ch3->b ch2-1/2b^2ch1+b^3/6ch0,cch3->b cch2-1/2b^2cch1+b^3/6cch0};W=Simplify[(Z[{ch0,ch1,ch2,ch3},{b,t}]Z[{cch0,cch1,cch2,cch3},{b,-t}]-Z[{ch0,ch1,ch2,ch3},{b,-t}]Z[{cch0,cch1,cch2,cch3},{b,t}])/(2I t^3)];
W0=Normal[Simplify[Series[W,{t,Infinity,0}]]]

Collect[6W0,b]

Simplify[Z[{ch0,ch1,ch2,ch3},{b,t}]-ZZ[{ch0,ch1,ch2,ch3},{b,t}]/.eps->1]

Solve[D[W0,b]==0,b]

Simplify[{Coefficient[W0,b^2],Coefficient[W0,t^2]}]

Simplify[{Coefficient[W0,b]}]

Simplify[Z[{ch0,ch1,ch2,ch3},{b,t}]-Zt[{ch0,ch1,ch2},{b,t}]]

W1=Normal[Series[FullSimplify[t^2 W/.{ch0->0}/.{b->u b,t->u t}],{u,Infinity,-3}]]/.u->1

Simplify[W1/((b^2)+(t^2))]

Solve[W1==0,b]

(* tilt stability -- set coef of ch3b to zero *)Zt[{ch0_,ch1_,ch2_,ch3_},{b_,t_}]:=-t^2/2(ch1-b ch0)-I t (ch2-b ch1+b^2/2ch0)+I/6 t^3 ch0;

Wt=Simplify[(Zt[{ch0,ch1,ch2,ch3},{b,t}]Zt[{cch0,cch1,cch2,cch3},{b,-t}]-Zt[{ch0,ch1,ch2,ch3},{b,-t}]Zt[{cch0,cch1,cch2,cch3},{b,t}])/(I t^3)];
Simplify[Wt/.{t^2->6(w-1/2b^2)}]

Wt0=Simplify[Series[Wt,{t,Infinity,0}]]

Simplify[W0-(Wt0/.b-> Sqrt[2/3]b)]

Coefficient[Wt0,b^2]

GL(2,R)^+-invariant coordinates

(* BMStellari Lemma 8.3, rescaling ImZ by alpha=aa, swapping b and bb=beta  *)
Z[{ch0_,ch1_,ch2_,ch3_},{a_,b_,aa_,bb_}]:=-(ch3-b ch2+b^2/2ch1-b^3/6 ch0)+bb  (ch2-b ch1+b^2/2ch0)+a(ch1-b ch0)+I aa ( (ch2-b ch1+b^2/2ch0)-1/2 aa^2 ch0);
(*Z[{ch0_,ch1_,ch2_,ch3_},{a_,b_,aa_,bb_}]:=-(ch3-bb ch2+bb^2/2ch1-bb^3/6 ch0)+b  (ch2-bb ch1+bb^2/2ch0)+a(ch1-bb ch0)+I aa( (ch2-bb ch1+bb^2/2ch0)-1/2 aa^2 ch0);*)
repaabb={bb->0,a->1/2t^2,aa->t/Sqrt[3]};
Z0=Z[{1,0,0,0},{a,b,aa,bb}];
Z1=Z[{0,1,0,0},{a,b,aa,bb}];
Z2=Z[{0,0,1,0},{a,b,aa,bb}];
Z3=Z[{0,0,0,1},{a,b,aa,bb}];
Z0b=Z[{1,0,0,0},{a,b,-aa,bb}];
Z1b=Z[{0,1,0,0},{a,b,-aa,bb}];
Z2b=Z[{0,0,1,0},{a,b,-aa,bb}];
Z3b=Z[{0,0,0,1},{a,b,-aa,bb}];
xBMS=Simplify[{(Z0 Z1b-Z1 Z0b)/(Z1 Z2b-Z1b Z2),(Z0 Z2b-Z0b Z2)/(Z1 Z2b-Z1b Z2),(Z0 Z3b-Z3 Z0b)/(Z1 Z2b-Z1b Z2),(Z1 Z3b-Z3 Z1b)/(Z1 Z2b-Z1b Z2),(Z2 Z3b-Z3 Z2b)/(Z1 Z2b-Z1b Z2),1}]

Solve[{Z[{1,x,x^2/2,x^3/6},{a,b,aa,bb}]==0,Z[{1,x,x^2/2,x^3/6},{a,b,-aa,bb}]==0},{a,x}]

Eliminate[xBMS=={x01,x02,x03,x13,x23},{a,aa,b,bb}]

Series[xBMS,{a,Infinity,0}]

Clear[F0,F0b,F1,F1b,kappa,z,zb];
Z0=-F0/kappa;Z1=-F1/kappa;Z2=-(Rez+I Imz);Z3=1;
Z0b=-F0b/kappa;Z1b=-F1b/kappa;Z2b=-(Rez-I Imz);Z3b=1;
repFLV={F0->kappa (Rez+I Imz)^3/6,F1->-kappa (Rez+I Imz)^2/2,F0b->kappa (Rez-I Imz)^3/6,F1b->-kappa (Rez-I Imz)^2/2};
repF={F0->ReF0+I ImF0,F0b->ReF0-I ImF0,F1->ReF1+I ImF1,F1b->ReF1-I ImF1};

xF=Simplify[{(Z0 Z1b-Z1 Z0b)/(Z1 Z2b-Z1b Z2),(Z0 Z2b-Z0b Z2)/(Z1 Z2b-Z1b Z2),(Z0 Z3b-Z3 Z0b)/(Z1 Z2b-Z1b Z2),(Z1 Z3b-Z3 Z1b)/(Z1 Z2b-Z1b Z2),(Z2 Z3b-Z3 Z2b)/(Z1 Z2b-Z1b Z2)}];

Simplify[xF[[1]]/.repFLV]

soa=FullSimplify[FullSimplify[Solve[xBMS==xF,{a,aa,b,bb}][[1]]]/.repF,{kappa>0,t>0}]

bb/.soa//TeXForm

Series[{a,b,bb}/.soa,{Imz,Infinity,4}]

TeXForm[%]

(* large volume slice *)
Z0=Z[{1,0,0,0},{b,t}];
Z1=Z[{0,1,0,0},{b,t}];
Z2=Z[{0,0,1,0},{b,t}];
Z3=Z[{0,0,0,1},{b,t}];
Z0b=Z[{1,0,0,0},{b,-t}];
Z1b=Z[{0,1,0,0},{b,-t}];
Z2b=Z[{0,0,1,0},{b,-t}];
Z3b=Z[{0,0,0,1},{b,-t}];
xLV=Simplify[{(Z0 Z1b-Z1 Z0b)/(Z1 Z2b-Z1b Z2),(Z0 Z2b-Z0b Z2)/(Z1 Z2b-Z1b Z2),(Z0 Z3b-Z3 Z0b)/(Z1 Z2b-Z1b Z2),(Z1 Z3b-Z3 Z1b)/(Z1 Z2b-Z1b Z2),(Z2 Z3b-Z3 Z2b)/(Z1 Z2b-Z1b Z2)}]

Solve[xBMS==(xLV/.b->bLV),{a,aa,b,bb}]

Simplify[xLV/. {a->((t^2)/(2 eps)),aa->(t/(Sqrt[3])),bb->0}]

Clear[bw];Z0=Zt[{1,0,0,0},{b,t}];
Z1=Zt[{0,1,0,0},{b,t}];
Z2=Zt[{0,0,1,0},{b,t}];
Z3=Zt[{0,0,0,1},{b,t}];
Z0b=Zt[{1,0,0,0},{b,-t}];
Z1b=Zt[{0,1,0,0},{b,-t}];
Z2b=Zt[{0,0,1,0},{b,-t}];
Z3b=Zt[{0,0,0,1},{b,-t}];
xbw=Simplify[{(Z0 Z1b-Z1 Z0b)/(Z1 Z2b-Z1b Z2),(Z0 Z2b-Z0b Z2)/(Z1 Z2b-Z1b Z2),(Z0 Z3b-Z3 Z0b)/(Z1 Z2b-Z1b Z2),(Z1 Z3b-Z3 Z1b)/(Z1 Z2b-Z1b Z2),(Z2 Z3b-Z3 Z2b)/(Z1 Z2b-Z1b Z2)}]/.b->bw

Solve[xBMS==xbw,{a,aa,b,bb}]

Simplify[FTWall[{ch0,ch1,ch2},{cch0,cch1,ch2},{((2 b)/3),(1/6) ((b^2)+(t^2))}]]

Check that BMT bound ensures Re(Z)>0 when ImZ=0

BMT[{ch0,ch1,ch2,ch3},{b,1/2b^2+1/6t^2}]/.

repchb=Solve[{ch1b==(ch1-b ch0),ch3b==(ch3-b ch2+b^2/2ch1-b^3/6 ch0),ch2b==(ch2-b ch1+b^2/2ch0),ch0b==ch0},{ch0,ch1,ch2,ch3}][[1]];

Simplify[BMT[{ch0,ch1,ch2,ch3},{b,1/2b^2+1/6t^2}]/.repchb]

Simplify[BMT[{ch0,ch1,ch2,ch3},{b,1/2b^2+1/6t^2}]/.repchb/.ch2b->t^2/6ch0b]

ReZ=-t^2/2(ch1-b ch0)+(ch3-b ch2+b^2/2ch1-b^3/6 ch0);
ImZ=-t (ch2-b ch1+b^2/2ch0)+1/6 t^3 ch0;
FullSimplify[{ReZ,-1/3BMT[{ch0,ch1,ch2,ch3},{b,1/2b^2+9/6t^2}]/ch1}/.t^2->6  (ch2-b ch1+b^2/2ch0)/ch0/.b->0]

Reduce[BMT[{1,4,8,ch3},{2,2}]>=0]

Reduce[BMT[{-1,-1,1,ch3},{2,2}]>=0]

Reduce[BMT[{0,2,6,ch3},{2,2}]>=0]

Reduce[BMT[{-2,-4,-4,ch3},{2,2}]>=0]

With[{kappa=12,nu=1/2},2kappa/nu^2-kappa/nu+1]

Rankm1WC[{x_,alpha_}]:=Module[{b1,b2,rmax,Li,r01max,xmin},
(* follows reasoning in proof of Lemma 2.1 *)
If[alpha^2<2x,Print["The BMT line does not intersect the parabola"]];
If[alpha^2==2x,Print["The BMT line is tangent to parabola"]];
b1=alpha-Sqrt[alpha^2-2x];
b2=alpha+Sqrt[alpha^2-2x];
Print["(b1,b2)=",N[{b1,b2}]];
If[alpha>fcon[x],Print["Satisfies Thm 1.1"]];
rmax=Floor[b1/(b2-b1)];
r01max=Floor[b2/(b2-b1)];
Li=Drop[Flatten[Table[Table[{r,c},{c,Ceiling[b2 r],Floor[b1(1+r)]}],{r,0,rmax}],1],1];
Print[Li];
Table[
Print["(r,c)=",Li[[i]],": E0:",Li[[i]],", E1:",{-1,0}-Li[[i]]];
Do[If[r0+r1>=1&& r0+r1<=r01max&&r1-1-Li[[i,1]]>=0,
xmin=-b2^2/2+1/2(b2^2-b1^2)(r0+r1);
Print["{{r0',r0},{r1',r1}=",{{Li[[i,1]]+r0,r0},{r1-1-Li[[i,1]],r1}},", x<=",N[xmin]]];
,{r0,0,r01max},{r1,0,r01max}];
,{i,Length[Li]}];
];

Rankm1WC[{13/6,57/26}]

Rankm1WC[{19/9,81/38}]

With[{k=16},Table[{d,Floor[ d^2/(2k)+d/2+1],Floor[2/3 d^2/k+d/3+1]},{d,0,k}]]

With[{k=5,gmax=51},Solve[gmax==d^2/(2k)+d/2+1,d]]

With[{k=16,d=13},N[d^2/(2k)+d/2+1]]

Thm 3.2 for quintic

ClearAll[Psi]

<<X5.m
{CY,chi,kappa,c2}
{Length[GVTab]-1,Length[PTTabnew]}

soa=Solve[(Gv[51,20]/.repGV)==175][[1]];
PTTabnew/.soa//MatrixForm

(* using conservative bound *)
Psi0[alpha_,x_,xx_]:=(x-xx)^2/2+1/2(x+xx)-2/3alpha x+2/3 xx^2+xx/3 ; 
(* using improved Castelnuovo bound *)
Psi[alpha_,x_,xx_]:=(x-xx)^2/2+1/2(x+xx)-2/3alpha x+1/2 xx^2+xx/2 ; 
Soh[x_]:=Which[0<x<1,x+1/2,1<=x<15/8,Sqrt[2x+1/4],15/8<=x<9/4,2/3x+3/4,9/4<=x<3,1/3x+3/2,3<=x,1/2x+1,x<0,-10];

Table[{mu,-Floor[mu^2/(2kappa)+mu/2]},{mu,0,25}]

Table[{-Floor[mu^2/(2kappa)+mu/2]+(mu^2/(2kappa)+mu/2)},{mu,-1,10kappa,kappa}]

Table[{mu,(alpha>(1/2 x+1))&&(Psi[alpha,x,1/kappa]<0) &&(Psi[alpha,x,x+1/2-alpha]<0)}/.{alpha->-3m/(2 mu),x->mu/kappa}/.{m->-Floor[mu^2/(2kappa)+mu/2]},{mu,kappa+1,25kappa, kappa}]

Table[{mu,(alpha>Soh[x])&&(Psi[alpha,x,1/kappa]<0) &&(Psi[alpha,x,x+1/2-alpha]<0)}/.{alpha->-3m/(2 mu),x->mu/kappa}/.{m->-Floor[mu^2/(2kappa)+mu/2]},{mu,1,5 kappa}]

kappa=5;
Psi[alpha_,x_,xx_]:=(x-xx)^2/2+1/2(x+xx)-2/3alpha x+1/2 xx^2+xx/2 ; 
Soh[x_]:=Which[0<x<1,x+1/2,1<=x<15/8,Sqrt[2x+1/4],15/8<=x<9/4,2/3x+3/4,9/4<=x<3,1/3x+3/2,3<=x,1/2x+1,x<0,-10];
Table[{mu,(alpha>Soh[x])&&(Psi[alpha,x,1/kappa]<0) &&(Psi[alpha,x,x+1/2-alpha]<0)}/.{alpha->-3m/(2 mu),x->mu/kappa}/.{m->-Floor[mu^2/(2kappa)+mu/2]},{mu,1,5 kappa}]