Poster pictures

Introduction

This notebook contains the source code for producing the pictures shown on the poster.

Warning

All but the first three pictures require a great deal of time or memory (or both).

Fundamental theorem of algebra

zz = {-3 - 8 I, 3 - I, -6 + I, -2 + 8 I, 7 - 4 I};
poly = Expand @ (Times @@ ((x + I y)-#& /@ zz));

Plot3D[Log[Abs[poly]+1], {x, -10, 10}, {y, -10, 10},
       PlotPoints -> 41, 
       AxesLabel -> {"Re(z)", "Im(z)", None},
       PlotRange -> All, Ticks -> {None, None, None}];

Show[{
 ContourPlot[Re[poly], {x,-10,10}, {y,-10,10},
     Contours -> {0}, ContourShading -> False,
     DisplayFunction -> Identity,
     ContourStyle -> 
         {RGBColor[1, 0, 0], Thickness[0.001]},
     PlotPoints -> 41],
 ContourPlot[Im[poly], {x, -10, 10}, {y, -10, 10},
     Contours -> {0}, ContourShading -> False,
     DisplayFunction -> Identity,
     PlotPoints -> 41,
     ContourStyle -> 
          {RGBColor[0, 1, 1], Thickness[0.001]}],
 Graphics[
      {PointSize[0.02], Point[{Re[#], Im[#]}]& /@ zz}]},
    DisplayFunction -> $DisplayFunction, 
    FrameTicks -> None,
    FrameLabel -> {"Re(z)", "Im(z)"}]

Show[GraphicsArray[{%%, %}]];

Icosahedral sphere division

Needs["Graphics`Polyhedra`"]

faces = #[[1]]& /@ Polyhedron[Dodecahedron][[1]] ;

This divides the faces of a dodecahedron into smaller ones:

divide[pentgon_] := Append[#, Plus @@ pentgon/5]& /@ 
       Flatten[{{#[[1]], #[[3]]},
                {#[[2]], #[[3]]}}& /@
                  (Append[#, (Plus @@ #)/2]& /@ 
        Partition[Append[pentgon,
                     First[pentgon]], 2, 1]), 1]

This colors the faces black and white:

Module[{three, still, color},
For[three = Flatten[divide /@ faces, 1];
    still = DeleteCases[three, three[[1]]]; white={};
    black = {three[[1]]}; color="b", still!= {}, , temp={}; i=1;
    Which[color == "b", 
    While[temp == {}, temp = Select[still,
    Length[Intersection[black[[-i]], #]] == 2&]; i = i+1;];
    AppendTo[white, temp[[1]]]; color = "w", color == "w",
    While[temp == {},temp = Select[still, Length[
    Intersection[white[[-i]], #]] == 2&]; i = i+1;];
    AppendTo[black, temp[[1]]]; color = "b"];  
    still = DeleteCases[still, temp[[1]]]]]

Here is the icosahedral sphere division:

OnSphere[l_List, n_] := #/Sqrt[#.#]& /@ Flatten[
Table[Evaluate[First[#]+j(Last[#]-First[#])/n], 
{j, 0, n}]& /@ Partition[Append[l, First[l]], 2, 1], 1]

Show[Graphics3D[{EdgeForm[],
 {GrayLevel[1], Polygon /@ (OnSphere[#, 3]& /@ white) },
 {GrayLevel[0], Polygon /@ (OnSphere[#, 3]& /@ black) } }],
 Lighting -> False, Boxed -> False, 
 Background -> GrayLevel[0.8]];

The next picture shows how the sphere looks after stereographic projection. We drop the faces which have a point which goes to infinity.

StereographicProjection[{x_, y_, z_}]={x/(1+z), y/(1+z)};

nwhite = Map[{{0,1,0}, {-1,0,0}, {0,0,1}}.#&,
   Select[white, Plus @@ (Last /@ #)/3 > -0.8505&], {-2}];
nblack=Map[{{0,1,0}, {-1,0,0}, {0,0,1}}.#&,
   Select[black, Plus @@ (Last /@ #)/3 > -0.8505&], {-2}];
Show[Graphics[{
{GrayLevel[0.8], Polygon[Table[
4.5{Cos[i 2Pi/5+Pi/10 //N], Sin[i 2Pi/5+Pi/10//N]}, 
    {i, 0, 4}]]},
{GrayLevel[0], Map[StereographicProjection,
	   Polygon /@ (OnSphere[#,24]& /@ nblack), {-2}]},
{GrayLevel[1], Map[StereographicProjection,
	   Polygon /@ (OnSphere[#,24]& /@ nwhite), {-2}]}}],
    PlotRange->All, AspectRatio->Automatic];

Five octohedra inscribed in an icosahedron

<<Graphics`Polyhedra`

mp[i_,j_] := mp[i,j] = (Vertices[Icosahedron][[i]]+
                    Vertices[Icosahedron][[j]])/2

Holed[poly_Polygon,ri_,ra_,opts___]:=
Module[{pl,mp,i,o},
pl=poly[[1]];mp=(Plus @@ pl)/Length[pl];
i=(mp + ri (#-mp))& /@ pl;
o=(mp + ra (#-mp))& /@ pl;
i=Reverse /@ Partition[Append[i,i[[1]] ],2,1];
o=Partition[Append[o,o[[1]] ],2,1];
{opts,Polygon /@ MapThread[Join,{i,o}]} ]

cross[rn1_,rn2_] :=
{rn1[[2]] rn2[[3]]-rn1[[3]] rn2[[2]],
 rn1[[3]] rn2[[1]]-rn1[[1]] rn2[[3]],
 rn1[[1]] rn2[[2]]-rn1[[2]] rn2[[1]]};

oct1=Polygon /@ 
{{mp[1,5],mp[6,11],mp[2,3]},{mp[7,12],mp[6,11],mp[2,3]},
 {mp[1,5],mp[6,11],mp[9,10]},{mp[7,12],mp[6,11],mp[9,10]},
 {mp[1,5],mp[4,8],mp[2,3]},{mp[7,12],mp[4,8],mp[2,3]},
 {mp[1,5],mp[4,8],mp[9,10]},{mp[7,12],mp[4,8],mp[9,10]} };

Bars[p_,ri_,ra_,rr_] :=
Module[{i,o,b,hi,ha},
        o = Holed[#,ri,ra]& /@p;
        i = Holed[#,ri,ra]& /@ Map[rr #&, p,{-1}];
        hi = Partition[#,2,1]& /@ 
           (Append[#,First[#]]& /@ (#[[1]]& /@ Flatten[i])) ; 
        ha = Partition[#,2,1]& /@ 
           (Append[#,First[#]]& /@ (#[[1]]& /@ Flatten[o])) ;             
        b = MapThread[Polygon[Join[#1,Reverse[#2]]]&,
             {hi,ha},2];
        {o,i,b} ]

g = Flatten[ Bars[oct1,0.9,1,0.95] ]//.Polygon[l_] :> 
     Line[Append[l,First[l]]];

Do[m[i]={{Cos[2Pi/5 i],Sin[2Pi/5 i],0},
{-Sin[2Pi/5 i],Cos[2Pi/5 i],0},{0,0,1}}//N,{i,0,4}];

Show[Graphics3D[{{Thickness[0.006],GrayLevel[0],
    Dashing[{0.01,0.01}],
(Polyhedron[Icosahedron][[1]])/.Polygon[l_] :> 
    Line[Append[l,First[l]]]},
{Thickness[0.001],Table[{Hue[i/6],Map[m[i].#&,g,{-2}]},
    {i,0,4}]}}],
Boxed->False];

Riemann surfaces

Using the method of differential reslovents, we can generate the following solutions of the polynomial x^n - x - z for n = 2, 3, 4 and x^5 - x + z.

roots[2,1,z_] = 1/2-HypergeometricPFQ[{-1/2},{},-4z]/2;


roots[2,2,z_] = 1/2+HypergeometricPFQ[{-1/2},{},-4z]/2;


roots[3,1,z_] = 
Hypergeometric2F1[1/6, -1/6, 1/2, (27*z^2)/4] +
     (z*Hypergeometric2F1[2/3, 1/3, 3/2, (27*z^2)/4])/2;


roots[3,2,z_]  =
-Hypergeometric2F1[1/6, -1/6, 1/2, (27*z^2)/4] +
     (z*Hypergeometric2F1[2/3, 1/3, 3/2, (27*z^2)/4])/2;


roots[3,3,z_] = 
-(z*Hypergeometric2F1[2/3, 1/3, 3/2, (27*z^2)/4]);


roots[4,1,z_] = 
-(z*HypergeometricPFQ[{1/4, 1/2, 3/4}, {2/3, 4/3}, 
     (-256*z^3)/27]);


roots[4,2,z_] =
HypergeometricPFQ[{-1/12, 1/6, 5/12}, {1/3, 2/3}, 
     (-256*z^3)/27] +
     (z*HypergeometricPFQ[{1/4, 1/2, 3/4}, {2/3, 4/3}, 
     (-256*z^3)/27])/3 -
     (2*z^2*HypergeometricPFQ[{7/12, 5/6, 13/12}, 
 {4/3, 5/3}, (-256*z^3)/27])/9;


roots[4,3,z_] =
(-1)^(2/3)*HypergeometricPFQ[{-1/12, 1/6, 5/12}, 
     {1/3, 2/3},
     (-256*z^3)/27] + 
     (z*HypergeometricPFQ[{1/4, 1/2, 3/4}, {2/3, 4/3},
          (-256*z^3)/27])/3 + (2*(-1)^(1/3)*z^2*
     HypergeometricPFQ[{7/12, 5/6, 13/12}, {4/3, 5/3}, 
          (-256*z^3)/27])/9;


roots[4,4,z_] =
-((-1)^(1/3)*HypergeometricPFQ[{-1/12, 1/6, 5/12}, 
     {1/3, 2/3}, (-256*z^3)/27]) + 
     (z*HypergeometricPFQ[{1/4, 1/2, 3/4}, {2/3, 4/3},
        (-256*z^3)/27])/3 - (2*(-1)^(2/3)*z^2*
       HypergeometricPFQ[{7/12, 5/6, 13/12}, {4/3, 5/3}, 
       (-256*z^3)/27])/9;


roots[5,1,z_] =
z*HypergeometricPFQ[{1/5, 2/5, 3/5, 4/5}, {1/2, 3/4, 5/4}, 
     (-3125*z^4)/256];


roots[5,2,z_] =
(-4*(-1)^(1/4)*Gamma[3/4]*
HypergeometricPFQ[{-1/20, 3/20, 7/20, 11/20}, 
      {1/4, 1/2, 3/4}, (-3125*z^4)/256])/Gamma[-1/4] - 
  (z*HypergeometricPFQ[{1/5, 2/5, 3/5, 4/5}, 
  {1/2, 3/4, 5/4}, (-3125*z^4)/256])/
   4 + (25*(-1)^(3/4)*z^2*Gamma[5/4]*
     HypergeometricPFQ[{9/20, 13/20, 17/20, 21/20}, 
     {3/4, 5/4, 3/2}, 
      (-3125*z^4)/256])/(128*Gamma[9/4]) + 
   (5*I)/32*z^3*HypergeometricPFQ[
   {7/10, 9/10, 11/10, 13/10}, {5/4, 3/2, 7/4}, 
     (-3125*z^4)/256];


roots[5,3,z_] =
(-4*(-1)^(3/4)*Gamma[3/4]*
HypergeometricPFQ[{-1/20, 3/20, 7/20, 11/20}, 
      {1/4, 1/2, 3/4}, (-3125*z^4)/256])/Gamma[-1/4] - 
  (z*HypergeometricPFQ[{1/5, 2/5, 3/5, 4/5}, 
  {1/2, 3/4, 5/4}, (-3125*z^4)/256])/
   4 + (25*(-1)^(1/4)*z^2*Gamma[5/4]*
     HypergeometricPFQ[{9/20, 13/20, 17/20, 21/20}, 
     {3/4, 5/4, 3/2}, 
       (-3125*z^4)/256])/(128*Gamma[9/4]) - 
   (5*I)/32*z^3*HypergeometricPFQ[
   {7/10, 9/10, 11/10, 13/10}, {5/4, 3/2, 7/4}, 
     (-3125*z^4)/256];


roots[5,4,z_] =
(4*(-1)^(1/4)*Gamma[3/4]*
HypergeometricPFQ[{-1/20, 3/20, 7/20, 11/20}, 
      {1/4, 1/2, 3/4}, (-3125*z^4)/256])/Gamma[-1/4] - 
  (z*HypergeometricPFQ[{1/5, 2/5, 3/5, 4/5}, 
  {1/2, 3/4, 5/4}, (-3125*z^4)/256])/
   4 - (25*(-1)^(3/4)*z^2*Gamma[5/4]*
      HypergeometricPFQ[{9/20, 13/20, 17/20, 21/20}, 
      {3/4, 5/4, 3/2}, 
       (-3125*z^4)/256])/(128*Gamma[9/4]) + 
   (5*I)/32*z^3*HypergeometricPFQ[
   {7/10, 9/10, 11/10, 13/10}, {5/4, 3/2, 7/4}, 
     (-3125*z^4)/256];


roots[5,5,z_] =
(4*(-1)^(3/4)*Gamma[3/4]*
HypergeometricPFQ[{-1/20, 3/20, 7/20, 11/20}, 
      {1/4, 1/2, 3/4}, (-3125*z^4)/256])/Gamma[-1/4] - 
  (z*HypergeometricPFQ[{1/5, 2/5, 3/5, 4/5}, 
  {1/2, 3/4, 5/4}, (-3125*z^4)/256])/
    4 - (25*(-1)^(1/4)*z^2*Gamma[5/4]*
      HypergeometricPFQ[{9/20, 13/20, 17/20, 21/20}, 
      {3/4, 5/4, 3/2}, 
       (-3125*z^4)/256])/(128*Gamma[9/4]) - 
   (5*I)/32*z^3*HypergeometricPFQ[
   {7/10, 9/10, 11/10, 13/10}, {5/4, 3/2, 7/4}, 
     (-3125*z^4)/256];

Show[
GraphicsArray[
Table[
Graphics3D[Table[{{EdgeForm[],
Map[Function[v,Function[m,MapThread[
Polygon[Join[#1,Reverse[#2]]]&,
Partition[Append[#,First[#]],2,1]&/@{m+0.8(#-m)&/@v,v}]][
Plus@@v/4]],#,{2}]},
{Thickness[0.001],
Map[Function[v,Function[m,Line[Append[#,First[#]]]&[m+
     0.8(#-m)&/@v]][
Plus@@v/4]],#,{2}]}}&[
Function[p,Flatten[MapThread[{Join[#1,
     Reverse[#2]]}&,#,1]& /@
Partition[Partition[#,2,1]&/@p,2,1],2]]/@ 
     Function[{e,b,c},
Table[{Re[#],Im[#],Re[roots[i,j,#]]}&[N[Exp[I Pi p]r]],
     {k,0,2i-3},
{p,(k-c)/c+e,(k-c+1)/c-e,(1/c-2e)/(12/c)},{r,e,b,
     (b-e)/6}]][10.^-12,
2.(#^#/i^i)^(1/#)&[i-1],i-1]],{j,i}],PlotRange->All,
Boxed->False,BoxRatios->{1,1,2},ViewPoint->{1,-1.3,1.3},
PlotLabel->
{"Quadratic","Cubic","Quartic","Quintic"}[[i+1]]],
{i,2,5}]]]

Riemann surface of Quintic

<<Graphics`Graphics3D`

RE[y_] :=
Module[{hyps},
hyps={(-4Gamma[3/4] HypergeometricPFQ[{-1/20,3/20,7/20, 
       11/20},{1/4,1/2,3/4},(-3125y^4)/256])/Gamma[-1/4],
y HypergeometricPFQ[{1/5,2/5,3/5,4/5}, 
{1/2,3/4,5/4},(-3125y^4)/256],
(5y^2*Gamma[5/4] HypergeometricPFQ[{9/20,13/20,17/20, 
21/20},{3/4,5/4,3/2},(-3125y^4)/256])/(8Gamma[9/4]), 
(y^3 HypergeometricPFQ[{7/10,9/10,11/10,13/10},
{5/4,3/2,7/4},(-3125y^4)/256])/6  };
 (hyps.#& /@  {{0,1,0,0},
{ (-1)^(1/4),-1/4,5/16 ( (-1)^(1/4))^3,15/16 ( 
     (-1)^(1/4))^2},
{ (-1)^(3/4),-1/4,5/16 ( (-1)^(3/4))^3,15/16 ( 
     (-1)^(3/4))^2},
{-(-1)^(1/4),-1/4,5/16 (-(-1)^(1/4))^3,15/16 (
     -(-1)^(1/4))^2},
{-(-1)^(3/4),-1/4,5/16 (-(-1)^(3/4))^3,15/16 (
     -(-1)^(3/4))^2}})]

nr = 20; np = 7; Table[tab[j] =
Table[{r Cos[p],r Sin[p],#}& /@ 
     RE[ Chop[N[ r Exp[I p] ] ] ],
   {r,10.^-4,N[2 (4^4/5^5)^(1/4)],
        N[(2 (4^4/5^5)^(1/4) -10^-4) /nr] },
   {p,j Pi/4+10.^-4,j Pi/4 + Pi/4-10.^-4,
        (Pi/4-2 10.^-4)/np} ] // N, {j,0,7} ] ;

Do[mt[i,j+1] = Map[#[[i]]&,tab[j] // N,{2}],{i,5},{j,0,7}]

Do[b[i,j] = ListSurfacePlot3D[  
     Map[MapAt[Abs,#,3]&,mt[i,j],{2}],Axes->True,
DisplayFunction->Identity],{i,5},{j,8}]

BB=Graphics3D[ Show[ Flatten[Table[b[i,j],{i,5},{j,8}]] ,
     Axes->True] ];

Show[Graphics3D[{
{EdgeForm[],SurfaceColor[GrayLevel[1/2],
     RGBColor[1/2,1/2,1]],
Function[poly,Module[{mp,p1,p2,p3,p4,
pn1,pn2,pn3,pn4,fac=0.8},mp=Plus @@ poly[[1]]/4;
{p1,p2,p3,p4}=poly[[1]];pn1=mp+fac(p1-mp);
pn2=mp+fac(p2-mp);pn3=mp+fac(p3-mp);
pn4=mp+fac(p4-mp);{Polygon[{p1,p2,pn2,pn1}],
Polygon[{p2,p3,pn3,pn2}],Polygon[{p3,p4,pn4,pn3}],
Polygon[{p4,p1,pn1,pn4}]}] ] /@ Flatten[ BB[[1,1]] ] },
{Thickness[0.001],GrayLevel[0],
Function[poly,Module[{mp,p1,p2,p3,p4,
pn1,pn2,pn3,pn4,fac=0.8},mp=Plus @@ poly[[1]]/4;
{p1,p2,p3,p4}=poly[[1]];pn1=mp+fac(p1-mp);
pn2=mp+fac(p2-mp);pn3=mp+fac(p3-mp);
pn4=mp+fac(p4-mp); 
Line[{pn1,pn2,pn3,pn4,pn1}]]] /@ 
     Flatten[ BB[[1,1]] ]} } ],
PlotRange->All,Axes->False,Boxed->False, LightSources -> 
{{{1.,0.,1.},RGBColor[1,0,0]},{{1.,1.,1.},
     RGBColor[0,1,0]}, 
 {{1.,-1.,-1.},RGBColor[0,1,0]},{{0.,1.,-1.},
     RGBColor[0,0,1]},
 {{0.,1.,1.},RGBColor[0,0,1]},{{-1.,-1.,-1.},
    RGBColor[0,1,0]}},
BoxRatios->{1,1,3/2},ViewPoint->{1,-1.3,1.3}];

Contour plot of modular function

cpre=
Table[Table[Re[((EllipticTheta[2, 0, N[r Exp[I p] ]]/ 
     EllipticTheta[3, 0, N[r Exp[I p] ]])^4)^(1/8) ],
       {p,N[-Pi+10^-12],N[Pi-10^-12],
       N[(2Pi-2 10^-12)/300]}],
       {r,0,0.999,0.999/300}];

conts=Table[i,{i,0,2,1/20}];

contsty=Table[{Hue[i]},{i,0,4,1/10}];

gr=Graphics[ListContourPlot[cpre,
     MeshRange->{N[{-Pi+10^-12,Pi-10^-12}],{0,0.999}},
         Contours->conts,ContourShading->False,
         ContourStyle->contsty]];

Show[Graphics[{
Map[If[Head[#]===List,
    N[{#[[2]] Cos[#[[1]]],
       #[[2]] Sin[#[[1]]]}],#]&,
   gr[[1]],{-2}],{Thickness[0.002],
       Circle[{0,0},0.999]}}],
    PlotRange->All,AspectRatio->Automatic];