Dror Bar-Natan: Talks: UofT-GS-090930:

Dror Bar-Natan: Academic Pensieve: 2009-09:

Hilbert's 13th Problem, the First Step

Pensieve Header: The first step of the Kolmogorov-Arnol'd solution of Hilbert's 13th problem.

SetOptions[Rasterize, RasterSize -> 1600, ImageSize -> 1600];
SetOptions[Plot3D, PlotPoints -> 150, ColorFunction -> Hue, ColorFunctionScaling -> False, ViewPoint -> {-1,-2,1}];
SetOptions[DensityPlot, PlotPoints -> 150, ColorFunction -> Hue, ColorFunctionScaling -> False];

f[x_,y_] := N[
Re[Zeta[x+I (13+4y)]]/3
];
Rasterize[GraphicsRow[{
Plot3D[f[x,y], {x,0,1}, {y,0,1}],
DensityPlot[f[x,y], {x,0,1}, {y,0,1}]
}]]

{lambda=N[((-1+(Sqrt[5]))/2)], n=5, eps=0.1}

Lattice=Table[
Point[(i-0.5)/n, (j-0.5)/n],
{i,1,n},{j,1,n}
]

ProjectionPoints = Sort[Flatten[Lattice /. Point[x_,y_] :> x+lambda*y]]

MinGap = Min[Abs[ProjectionPoints-RotateRight[ProjectionPoints]]]

Slope=2/3*MinGap*n/(1+lambda)

Phi = PLFunction@@Flatten[{
Point[0,0],
Table[
{
Point[(i-1+eps)/n,(i-1/2)/n-Slope*(1/2-eps)/n] ,
Point[(i-eps)/n,(i-1/2)/n+Slope*(1/2-eps)/n]
},
{i,n}
],
Point[1,1]
}
]

PLFunction[pts__Point][x_] := Module[
{i=1,x0,x1,xi0,xi1},
While[{pts}[[i,1]]<x, ++i];
If[i==1,
{pts}[[1,1]],
(* else *) {x0,xi0} = List @@ {pts}[[i-1]];
{x1,xi1} = List @@ {pts}[[i]];
xi0+(x-x0)*(xi1-xi0)/(x1-x0)
]
]

Plot[Phi[x], {x,0,1}]

Rasterize[Plot3D[Phi[x]+lambda*Phi[y], {x,0,1},{y,0,1}, ColorFunction -> Automatic]]

g = PLFunction@@Sort[Flatten[{
Point[0,f[0,0]],
Table[
{
Point[
((i-1/2)/n-Slope*(1/2-eps)/n)+lambda((j-1/2)/n-Slope*(1/2-eps)/n),
f[(i-1/2)/n, (j-1/2)/n]
] ,
Point[
((i-1/2)/n+Slope*(1/2-eps)/n)+lambda((j-1/2)/n+Slope*(1/2-eps)/n),
f[(i-1/2)/n, (j-1/2)/n]
] 
},
{i,n}, {j,n}
],
Point[1+lambda,f[1,1]]
}]]

Plot[
g[zeta], {zeta,0,1+lambda},
PlotPoints-> 200, ColorFunction -> (Hue[#2]&), ColorFunctionScaling -> False
]

Rasterize[DensityPlot[
g[zeta], {zeta,0,1+lambda}, {dummy, 0, 0.1},
PlotPoints-> {400,2}, AspectRatio -> 1/10
]]

Rasterize[GraphicsRow[{
DensityPlot[g[Phi[x]+lambda*Phi[y]], {x,0,1}, {y,0,1}],
DensityPlot[f[x,y], {x,0,1}, {y,0,1}]
}]]

DoubleStairs=Rasterize[Plot3D[
Phi[x]+lambda*Phi[y], {x,0,1},{y,0,1},
ColorFunction -> (Hue[g[#3]]&), PlotPoints -> 300
]]

Export[
"C:/drorbn/AcademicPensieve/2009-09/DoubleStairs.jpg",
ImageCrop[DoubleStairs]
]

Export[
"C:/drorbn/AcademicPensieve/2009-09/DoubleStairs_640.jpg",
ImageResize[ImageCrop[DoubleStairs], 640]
]