Parameters

baseDir="~/doc/research/complex_complex/papers/bezout";

κs=1-(4^(-#))&/@Range[0,3];(* For figures 2 and 3. *)

fS=10; (* Font size *)

Definitions

ellipse[p_][a_,ϵ_,κ_]:=TransformedRegion[Disk[-p ReIm[ϵ],Sqrt[((p(p-1))/2)]Sqrt[(a^(p-2))]{1+Abs[κ]/(a^(p-2)),1-Abs[κ]/(a^(p-2))}],RotationTransform[Arg[κ]/2,-p ReIm[ϵ]]]

fLogDet[p_][a_,ϵ_,κ_]:=Module[{x,y},
(1/(π(((p(p-1))/2)(a^(p-2)))(1-(((Abs[κ]/(a^(p-2))))^2))))NIntegrate[Log[(x^2)+(y^2)],{x,y}∈ellipse[p][a,ϵ,κ]]
]/;(NumericQ[ϵ]&&NumericQ[κ]&&NumericQ[a])

fDeltas[p_][a_,ϵ_,κ_]:=
2(((a^(2(p-2))) (1+(-1+(a^2)) (2+(a^2) (-1+p)-p) p)-((Abs[κ])^2) ) Re[(ϵ^2)κ\[Conjugate]]+(a^p)((a^(2(p-2)))  ((p-1)-p (a^2)) +((Abs[κ])^2))((Abs[ϵ])^2))/((a^(4(p-1)))+((Abs[κ])^4)- (a^(2(p-2))) ((((p-1))^2)-p(2p-4) (a^2)+(((p-1))^2) (a^4))((Abs[κ])^2))+1+(1/2) Log[((4 (-1+(a^2)))/((p^2) ((a^(2(p-1)))-((Abs[κ])^2))))]

Σϵ0[p_][r_,κ_]:=Log[(p-1)(r^(2(p-1)))Sqrt[((1-(r^(-4)))/((r^(4(p-1)))-((Abs[κ])^2)))]]

Σ[p_][ϵ_]:=fLogDet[p][ϵ]+((-2+2 p+2 (ϵ^2)-3 p (ϵ^2)+(-1+p) Log[(4/((-1+p) (p^2)))])/(2 (-1+p)))

ϵGround3=FindRoot[0==Σ[3][ϵ],{ϵ,1},WorkingPrecision->20]

Σ[p_][a_,ϵ_,κ_]:=fDeltas[p][a,ϵ,κ]+fLogDet[p][a,ϵ,κ]

ϵth[p_][a_,ϵ_,κ_]:=With[{δ=κ (a^(-(p-2)))},Exp[I Arg[ϵ]]Sqrt[(1/(2p))(p-1)(a^(p-2))((((1-((Abs[δ])^2)))^2)/(1+((Abs[δ])^2)-2 Abs[δ]Cos[Arg[δ]+2Arg[ϵ]]))]]

spectrumSaddle[p_][a_,c_,ϵ_,κ_][α_,χ_][λ_]:=1+((p(p-1) (a^(p-2)) (α^2))/16)-((α λ)/2)-(p/4) χ Conjugate[ϵ]+((p(p-1))/32) (c^(p-2)) (χ^2) Conjugate[κ]-(p/4) ϵ Conjugate[χ]+((p(p-1))/32) κ ((Conjugate[c])^(p-2)) ((Conjugate[χ])^2)-(1/2) Log[(1/((α^2)-χ Conjugate[χ]))]

spectrumG[3]=(1/2)α/.Solve[0==D[spectrumSaddle[3][a,1,ϵ,κ][α,χ][λ],{{χ,χ\[Conjugate],α}}],{χ,χ\[Conjugate],α}];

ρ[p_][aa_,ϵϵ_,κκ_][λλ_Real]:=With[
{func=spectrumG[p]/(2π)/.{ϵ->ϵϵ,a->aa,λ->λλ,κ->κκ}},
2Abs[Im[First@MaximalBy[MinimalBy[Round[Select[func,Abs[#]<(10^6)&],(10.^(-6))],Sign[λλ] Re[#]&],Abs[Im[#]]&]]]
]

(* Technology for generating structured random matrices. *)
matrix[n_][p_][a_,ϵ_,κ_]:=With[{
M=p ϵ IdentityMatrix[n]+Symmetrize@Map[#.{1,I}&,RandomVariate[MultinormalDistribution[{0,0},N[((p(p-1))/(2n))]{{(a^(p-2))+Re[κ],Im[κ]},{Im[κ],(a^(p-2))-Re[κ]}}],{n,n}],{2}]
},
M\[ConjugateTranspose].M
]

(* Technology for generating random (valid) parameters and plottings PDFs and histograms. *)
testPDF[p_,Δx_:50][a_,ϵ_,κ_]:=
Plot[2ρ[p][a,ϵ,κ][λ],{λ,0,Δx},PlotRange->All,WorkingPrecision->20,AxesLabel->{λ,ρ[λ]}]
testHist[N_,n_,Δx_:6][p_][a_,ϵ_,κ_]:=Histogram[
Flatten[ParallelTable[Sqrt@Eigenvalues[matrix[n][p][a,ϵ,κ]],{N}]],{0,Δx,Δx/40},"PDF"]
testComp[N_,n_,let_,Δx_:6,range_:Automatic,lab_:{σ,ρ[σ]},blank_:False][p_][a_,ϵ_,κ_]:=Show[
testHist[N,n,Δx][p][a,ϵ,κ],
testPDF[p,Δx][a,ϵ,κ],
AxesLabel->lab,AxesStyle->Black,LabelStyle->Directive[Black,FontFamily->"Times",FontSize->fS],TicksStyle->Directive[Black,FontFamily->"Times",FontSize->fS],
Ticks->{Automatic,Join[{#,"",{0.01,0}}&/@Range[0,0.35,0.02],{{0.1,0.1},{0.2,0.2},{0.3,0.3}}]},
PlotRange->{0,0.35},ImageSize->246 10/15 ,
Epilog->{Inset[testEllipse[range,blank][p][a,ϵ,κ],{4.9,0.32}],Text[Style["("<>let<>")",Bold,FontSize->fS],{-0.6,-0.04}]}
]
testEllipse[range_:Automatic,blank_:False][p_][a_,ϵp_,κ_]:=Graphics[{ColorData[97][3],ellipse[p][a,ϵp,κ]},Axes->True,AxesOrigin->{0,0},AxesLabel->If[blank,{Style[Re[λ],White],Style[Im[λ],White]},{Re[λ],Im[λ]}],AxesStyle->{Black},LabelStyle->{Black,FontSize->fS,FontFamily->"Times"},PlotRange->range,ImageSize->95,Ticks->{{2,4},{2}}]
testSet[N_,n_,Δx_:6,range_:Automatic][p_][a_,ϵ_,κ_]:=With[{ϵt=ϵth[p][a,ϵ,κ]},
List[
testComp[N,n,"a",Δx,range,{Style[σ,White],ρ[σ]},True][p][a,0,κ],
testComp[N,n,"b",Δx,range][p][a,0.5ϵt,κ],
testComp[N,n,"c",Δx,range,{Style[σ,White],Style[ρ[σ],White]},True][p][a,ϵt,κ],
testComp[N,n,"d",Δx,range,{σ,Style[ρ[σ],White]},True][p][a,1.5ϵt,κ]
]]

Figures

Figure 1

test={1.25,-1,0.75Exp[-I π/4]};

figure=testSet[8,(2^10),6.5,{{-3,5.5},{-2,2}}][3]@@test

Export[FileNameJoin[{baseDir,"fig/spectra_0.0.pdf"}],figure[[1]]];
Export[FileNameJoin[{baseDir,"fig/spectra_0.5.pdf"}],figure[[2]]];
Export[FileNameJoin[{baseDir,"fig/spectra_1.0.pdf"}],figure[[3]]];
Export[FileNameJoin[{baseDir,"fig/spectra_1.5.pdf"}],figure[[4]]];

Figure 2

complexityPlot=Plot[{Evaluate[Σϵ0[3][r,#]&/@Append[κs,1]],(1/2)Log[2],Log[2]},{r,1,2},
PlotLegends->LineLegend[Join[{0},N[Rest[κs]],{1}],LegendLabel->κ,LabelStyle->{FontFamily->"Times",FontSize->fS,Black}],
PlotRange->{0,Automatic},PlotStyle->Join[ColorData[97]/@Range[5],{{Black,Dashed},{Black,Dotted}}]
,AxesLabel->{R,Σ[κ,0,R]},ImageSize->246 ,AxesStyle->Black,LabelStyle->Directive[FontSize->10,Black,FontFamily->"Times"],TicksStyle->Directive[Black,FontFamily->"Times",FontSize->fS]
]

Export[FileNameJoin[{baseDir,"fig/complexity.pdf"}],complexityPlot];

Figure 3

dataAmin=Join[
Map[κ|->ParallelTable[{ϵ,Exp[loga]/.FindRoot[0==Σ[3][(((1+Exp[loga]))^2),ϵ,κ],{loga,0},WorkingPrecision->20]},{ϵ,0,2,1/100}],κs],
{Join[{{ϵ/.ϵGround3,0}},Table[{ϵ,Exp[loga]/.FindRoot[0==Σ[3][(((1+Exp[loga]))^2),ϵ,1],{loga,0},WorkingPrecision->20]},{ϵ,(10^(-4))+ϵ/.ϵGround3,2,1/100}]]}
];

desertPlot=ListLogPlot[Join[Reverse[{-#1,#2}&@@@#],#]&/@dataAmin/. 0->(10^(-8)),
Joined->True,AxesLabel->{ϵ,R-1},PlotRange->{7 (10^(-4)),4},ImageSize->246 ,AxesStyle->Black,LabelStyle->Directive[Black,FontFamily->"Times",FontSize->fS],TicksStyle->Directive[Black,FontFamily->"Times",FontSize->fS],PlotLegends->LineLegend[Join[{0},N[Rest[κs]],{1}],LegendLabel->Placed[κ,Top],LabelStyle->{FontFamily->"Times",Black,FontSize->fS}],Epilog->{Thickness[0.006],Dotted,Line[{{ϵ/.ϵGround3,-1000},{ϵ/.ϵGround3,10}}],Line[{{-ϵ/.ϵGround3,-1000},{-ϵ/.ϵGround3,10}}]}]

Export[FileNameJoin[{baseDir,"/fig/desert.pdf"}],desertPlot];

Figure 4

aegg=Rationalize@{1.125,1.325,2};κegg=3/4Exp[I π/4];

groundData=ParallelTable[
{-Cos[ϕ],Sin[ϕ]}ϵ/.FindRoot[Σ[3][#,ϵ Exp[I ϕ],κegg],{ϵ,1},WorkingPrecision->20],{ϕ,0,2π,2π/400}
]&/@aegg;

eggPlots=MapIndexed[Show[
If[#2[[1]]==4,ListPlot[{}],ListPlot[groundData[[4-#2[[1]]]],Joined->True,PlotStyle->{Opacity[0]},FillingStyle->ColorData[97][3]&/@Range[2],Filling->Axis]],
ParametricPlot[Evaluate[ ReIm[ϵth[3][#1[[1]],Exp[I ϕ],κegg]]],{ϕ,0,2π},PlotStyle->{Black,Thickness[0.003]}],
PlotRange->{{-1.1,1.1},{-0.6,0.6}},AspectRatio->0.6/1.1,AxesLabel->{Style[Re[ϵ],#1[[3,1]]],Style[Im[ϵ],#1[[3,2]]]},AxesStyle->Black,LabelStyle->Directive[Black,FontFamily->"Times",FontSize->fS],TicksStyle->Directive[Black,FontFamily->"Times",FontSize->fS],ImageSize->246 2/3,Ticks->{{-1,-0.5,0.5,1},{-0.5,0.5}},Epilog->Text[Style["("<>#1[[2]]<>")",Bold,FontSize->fS],{-1,-0.5}]
]&,Thread[{Join[Reverse@aegg,{1}],{"a","b","c","d"},{{White,Black},{Black,Black},{White,White},{Black,White}}}]]

Export[FileNameJoin[{baseDir,"fig/threshold_2.000.pdf"}],eggPlots[[1]]];
Export[FileNameJoin[{baseDir,"fig/threshold_1.325.pdf"}],eggPlots[[2]]];
Export[FileNameJoin[{baseDir,"fig/threshold_1.125.pdf"}],eggPlots[[3]]];
Export[FileNameJoin[{baseDir,"fig/threshold_1.000.pdf"}],eggPlots[[4]]];