Wolfram Research

Function Repository Resource:

ModularTessellation

Source Notebook

Compute polygons, circles, compositions and transformation functions for the tessellation of the upper half-plane by the modular group

Contributed by: Michael Trott

ResourceFunction["ModularTessellation"][order]

returns a list of lists of polygons of mappings of the fundamental domain under up to order repeated applications of the generators of the modular group.

ResourceFunction["ModularTessellation"][order, prop]

returns a list of lists of associations of the property prop of the fundamental domain under up to order repeated applications of the generators of the modular group.

ResourceFunction["ModularTessellation"][function, prop]

returns the property prop of the fundamental domain under the modular transformation function.

Details and Options

Modular transformations are univariate fractional linear transformations generated by compositions of and . Alternatively a map f is a modular transformation if it can be written as with .
The modular transformations of successive orders arise from applying the generators to the maps of a given order.
The curvilinear triangles arising from applying all modular transformations to the fundamental domain tessellates the upper half-plane ℍ. The fundamental domain is the set of complex numbers .
order can be either a nonnegative integer or a list of one or two nondecreasing nonnegative integers.
For most properties the output is a list of associations with one association per order. The keys of the associations are the modular transforms represented as pure functions.
function must be a modular function represented as a pure function (head Function).
The following properties prop are supported:
"BoundingCircles" circles/lines bounding the curvilinear triangles
"BooleanRegions" Boolean region descriptions of the curvilinear triangles
"ImplicitRegions" implicit region descriptions of the curvilinear triangles
"ApproximationPolygons" polygons of the curvilinear triangles
"Compositions" representations of the modular transformations as compositions of generators
{"UnitDiskMappedApproximationPolygons",{β,θ}} curvilinear triangles mapped to the unit disk 𝔻 through
ResourceFunction["ModularTessellation"] has the following options:
"PlotPoints" 20 number of points of the approximate polygons
"IncludeVerticalStripes" True if the vertical stripes that extend to ⅈ ∞ should be included in polygon lists
"VerticalStripeTruncation" Infinity maximal vertical extension of the vertical stripes

Examples

Basic Examples

Plot the first few iterations of applying the generators of the modular group with alternating black and white colors:

In[1]:=
Graphics[MapIndexed[{GrayLevel[Mod[#2[[1]], 2]], #1} &, ResourceFunction["ModularTessellation"][8] ], PlotRange -> {{0, 2}, {0, 3/2}}]
Out[1]=

The polygons of the first two orders of the tessellations:

In[2]:=
ResourceFunction["ModularTessellation"][{2}, "ApproximationPolygons"]
Out[2]=

The bounding circles of the first orders:

In[3]:=
Graphics[{Darker[Blue], Values @ ResourceFunction["ModularTessellation"][8, "BoundingCircles"]},
                   PlotRange -> 3/2]
Out[3]=

Show the fundamental domain and the boundary circles of the first order modular transformations:

In[4]:=
Graphics[{ResourceFunction["ModularTessellation"][0], Darker[Red], Values[ResourceFunction["ModularTessellation"][8, "BoundingCircles"]]},
 PlotRange -> { {-3, 3}, {0, 3}} , Frame -> True, PlotRangeClipping -> True]
Out[4]=

The mapped fundamental polygons of the upper half-plane conformally mapped into the unit disk:

In[5]:=
Graphics[MapIndexed[{GrayLevel[Mod[#2[[1]], 2]], #1} &, Values @ ResourceFunction["ModularTessellation"][
    10, {"UnitDiskMappedApproximationPolygons", {I, -Pi/2}}] ],
                   PlotRange -> 1]
Out[5]=

The polygons of the first eight orders of mapping the fundamental domain:

In[6]:=
Graphics[{Darker[Red], #}, PlotRange -> {All, {0, 3/2}}, Frame -> True, FrameTicks -> None] & /@ \
                                                                      \
   Rest[ResourceFunction["ModularTessellation"][9]]
Out[6]=

Scope

Use the keys of the association to add tooltip labels to the mapped fundamental domain polygons:


Explicit exact form of the circles and lines bounding the curvilinear triangles of order 3:

In[7]:=
ResourceFunction["ModularTessellation"][{3}, "BoundingCircles"]
Out[7]=

Plot the bounding circles of curvilinear triangles:

In[8]:=
polygonCircleSketch /@ {Function[\[FormalZ], \[FormalZ]/(
   1 + 2 \[FormalZ])], Function[\[FormalZ], -(1/\[FormalZ])], Function[\[FormalZ], (-3 - \[FormalZ])/(2 + \[FormalZ])]}
Out[8]=

The bounding circles of the first few orders of curvilinear triangle (the blue circles are overlaid over the polygons):

In[9]:=
Graphics[{MapIndexed[{{Yellow, Purple}[[Mod[#2[[1]], 2] + 1]], #1} &, ResourceFunction["ModularTessellation"][6 ]], Blue, Values[ResourceFunction["ModularTessellation"][6, "BoundingCircles"]]},
                   PlotRange -> {{0, 2}, {0, 3/2}}]
Out[9]=

The curvilinear triangles and vertical stripes as Boolean regions:

In[10]:=
ResourceFunction["ModularTessellation"][{2}, "BooleanRegions"]
Out[10]=

Discretize one of the regions:

In[11]:=
DiscretizeRegion[%[[1, 2]]] // Show[#, Frame -> True] &
Out[11]=

The curvilinear triangles and vertical stripes as implicit regions:

In[12]:=
ResourceFunction["ModularTessellation"][{2}, "ImplicitRegions"]
Out[12]=

Discretize one of the regions:

In[13]:=
DiscretizeRegion[%[[1, 2]]] // Show[#, Frame -> True] &
Out[13]=

Compute the area of one of these regions exactly:

In[14]:=
Area[%%[[1, 2]]]
Out[14]=

Compute the perimeter of the map of the fundamental domain under :

In[15]:=
ResourceFunction["ModularTessellation"][
 Function[\[FormalZ], -(1/\[FormalZ])], "ImplicitRegions"]
Out[15]=
In[16]:=
Perimeter[%[[2]]]
Out[16]=

The modular transformations of the first few orders:

In[17]:=
(mtList = Flatten[ResourceFunction["ModularTessellation"][ 4, "TransformationFunctionList"]]) // TraditionalForm
Out[85]=

Show curvilinear triangles from a range of orders (here from 6 to 12):

In[86]:=
Graphics[{RandomColor[], #} & /@ Flatten[ResourceFunction["ModularTessellation"][{6, 12}, "IncludeVerticalStripes" -> False]],
                    Frame -> True, PlotRange -> {{-1, 1}, {0, 0.16}},
                   PlotRangeClipping -> True, AspectRatio -> 1]
Out[86]=

Options

By default, the translations of the fundamental domains extending to are included:

In[87]:=
ResourceFunction["ModularTessellation"][2, "ApproximationPolygons"]
Out[87]=

Do not include the vertical stripe polygons:

In[88]:=
ResourceFunction["ModularTessellation"][2, "ApproximationPolygons", "IncludeVerticalStripes" -> False]
Out[88]=

Include the vertical stripe polygons, but cut them at :

In[89]:=
ResourceFunction["ModularTessellation"][2, "ApproximationPolygons", "IncludeVerticalStripes" -> True, "VerticalStripeTruncation" -> 3]
Out[89]=

Vary the number of points along the boundary segments of the fundamental domain and its mappings:

In[90]:=
Table[Graphics[{Gray, ResourceFunction["ModularTessellation"][2, "ApproximationPolygons",
      "IncludeVerticalStripes" -> False, "PlotPoints" -> pp][[3, 3]]}, PlotLabel -> pp],
             {pp, {2, 6, 20}}]
Out[90]=

Applications

Calculate the areas of the curvilinear triangles of order 5 (the vertical stripes generated by have infinite area):

In[91]:=
(Area /@ ResourceFunction["ModularTessellation"][{5}, "ImplicitRegions"][[1]]) // Normal // FullSimplify // Column
Out[91]=

Compute the eigenvalues of the Laplacian (with appropriate metric factor 1/y2) for the map of the fundamental domain under the modular transformation .

The region the eigenvalue problem is to be solved in:

In[92]:=
fr2 = ResourceFunction["ModularTessellation"][
   Function[\[FormalZ], -(1/\[FormalZ])], "ImplicitRegions"][[2]]
Out[92]=
In[93]:=
Show[Region[fr2], Frame -> True]
Out[93]=

Plot the values of the first 50 eigenvalues:

In[94]:=
ListPlot[Take[evals, 50]]
Out[94]=

Plot the eigenfunctions of the first six eigenfunctions:

In[95]:=
Table[Plot3D[Evaluate[Abs[evecs[[j]]]], {x, y} \[Element] fr2,
                           Mesh -> False, PlotPoints -> 60, Axes -> False],
             {j, 6}]
Out[95]=

A contour plot of a higher eigenstate:

In[96]:=
ContourPlot[Evaluate[Abs[evecs[[82]]]], {x, y} \[Element] fr2,
                           Mesh -> False, PlotPoints -> 120, Axes -> False]
Out[96]=

Compare the shape of the curvilinear triangles. To compare triangles of different size, rescale all triangles to have the same horizontal extension:

In[97]:=
rescale[Polygon[l_]] := Module[{xs, ys, minx, maxx, \[Delta]x, miny},
  {xs, ys} = Transpose[l];
  {minx, maxx} = MinMax[xs];
  \[Delta]x = maxx - minx;
  miny = Min[ys];
  Polygon[((# - {minx, miny}))/\[Delta]x & /@ l]]
In[98]:=
Graphics[{RandomColor[], Opacity[0.8], Thickness[0.01], Line @@ rescale[#]} & /@ Flatten[Values[
    ResourceFunction["ModularTessellation"][{6}, "ApproximationPolygons",
                                                                      \ "IncludeVerticalStripes" -> False]]]]
Out[98]=

Show all triangles of the order 16:

In[99]:=
polys = Flatten[
   Values[ResourceFunction["ModularTessellation"][{16}, "ApproximationPolygons",
                                                                      \
                   "IncludeVerticalStripes" -> False]]];
Length[polys]
Out[99]=
In[100]:=
Graphics[{GrayLevel[0.5], Opacity[0.4], Thickness[0.001],
                 Line @@ rescale[#]} & /@ polys]
Out[100]=

The radii distribution of the circles of the first 18 orders:

In[101]:=
Histogram[
 Last /@ Cases[
   Values[ResourceFunction["ModularTessellation"][18, "BoundingCircles"]], _Circle, \[Infinity]],
                      {"Log", 50}, PlotRange -> All]
Out[101]=

Plot the sum of the radii of the first 16 orders of circles:

In[102]:=
Plot[radiiSum, {x, -1, 1}]
Out[102]=

Add the local heights of the order 10 circles:

In[103]:=
radiiSum2 = Total[Piecewise /@ ( {{Sqrt[#2^2 - (x - #1[[1]])^2], #1[[1]] - #2 <=
           x <= #1[[1]] + #2}} & @@@ Cases[Values[
        ResourceFunction["ModularTessellation"][{10}, "BoundingCircles"]], _Circle, \[Infinity]])];
In[104]:=
Plot[radiiSum2, {x, -1, 1}, Exclusions -> None]
Out[104]=

The size of the triangles varies substantially within a given order. Plot a histogram of all finite order 16 triangles:

In[105]:=
polys = Flatten[
   Values[ResourceFunction["ModularTessellation"][{16}, "ApproximationPolygons",
                                                                      \
                    "IncludeVerticalStripes" -> False]]];
Length[polys]
Out[105]=
In[106]:=
Histogram[Area /@ polys, {"Log", 50}, PlotRange -> All]
Out[106]=

Plot a histogram of the distribution of the perimeter-to-area values for the order 14 triangles:

In[107]:=
Histogram[perimeterAreaRatios, {"Log", 50}, PlotRange -> All]
Out[107]=

Properties and Relations

The Klein invariant takes on every complex value within each of the mapped fundamental domains. Plot the Klein invariant over one of the triangles:

In[108]:=
rt[z_Complex] = RegionMember[
   ResourceFunction["ModularTessellation"][
    Function[\[FormalZ], -(1/\[FormalZ])], \
                                     "ApproximationPolygons"], ReIm[z]];
In[109]:=
ComplexPlot[KleinInvariantJ[z], {z, -1/2 + 10^-4 I, 1/2 + I},
 Exclusions -> None, WorkingPrecision -> 25, Method -> {"RasterSize" -> 400},
 ColorFunction -> "CyclicLogAbsArg", PlotPoints -> 120, MaxRecursion -> 2,
 RegionFunction -> Function[{z}, rt[z]]]
Out[109]=

The Klein invariant obeys J(z)=J(f(z)) for any modular transform f. Check this for the first three orders to 50 digits:

In[110]:=
{#, N[ KleinInvariantJ[1/5 + 2 I] - KleinInvariantJ[#[1/5 + 2 I]], {Infinity, 50}]} & /@ Flatten[ResourceFunction["ModularTessellation"][ 3, "TransformationFunctionList"]]
Out[110]=

Use the Fourier series of the Klein invariant to visualize the mapping from a fundamental triangle to the complex plane:

In[111]:=
fr2 = ResourceFunction["ModularTessellation"][
  Function[\[FormalZ], -(1/\[FormalZ])], "ApproximationPolygons"]
Out[111]=
In[112]:=
JFourier[z_] = Series[With[{o = 100},
      (1 + 240 Sum[DivisorSigma[3, n] q^n, {n, o}])^3/(q Product[(1 - q^n)^24, {n, o}])],
     {q, 0, 50}][[3]] Table[E^(2 k I \[Pi] z), {k, -1, 50}];
In[113]:=
Take[JFourier[z], 12]
Out[113]=

Use an arctan transformation to map the infinite plane into a finite square:

In[114]:=
path\[DoubleStruckCapitalC][z_, f_ : Identity] := With[{zL = f@ReIm[Accumulate[JFourier[z]/1729]]},
              {Thickness[0.001], Opacity[0.2], Gray, Line[zL],
              Opacity[0.8], PointSize[0.003], Blue, Point[Last[zL]]}]
In[115]:=
Graphics[{Red,  Map[ArcTan, fr2, {1}], Table[ path\[DoubleStruckCapitalC][RandomPoint[fr2].{1, I}, ArcTan], {1000}]}, PlotRange -> All]
Out[115]=

A given modular transform can be represented in multiple ways. Here are all possibilities with up to three generator applications (for easier readability we abbreviate the pure functions of the generators):

In[116]:=
Normal[ResourceFunction["ModularTessellation"][{3}, "Compositions"] //.
     {Function[\[FormalZ], \[FormalZ]] -> \
\[ScriptCapitalI], Function[\[FormalZ], -\[FormalZ]^(-1)] -> \[ScriptCapitalK], Function[\[FormalZ], \[FormalZ] - 1] -> \[ScriptCapitalL], Function[\[FormalZ], \[FormalZ] + 1] -> \[ScriptCapitalR]}] //
                                 \
                                Column // TraditionalForm
Out[12]=

Show the network of modular transforms by connecting transforms that arise from applying a generator:

In[117]:=
nextF[f_, z_] := {f -> Together[f - 1], f -> Together[f + 1], f -> Together[-1/f]}
In[118]:=
Graph[Flatten[
  Rest[NestList[
    Flatten[nextF[#, z] & /@ Union[Last /@ #]] &, {Null -> z}, 14]]],
 VertexLabels -> Placed["Name", Tooltip], GraphLayout -> "SpringElectricalEmbedding"]
Out[118]=

Plot the circle radii for the first 16 orders on a logarithmic scale (each order adds two circles of radius 1 and near the origin more and more small circles are generated):

In[119]:=
ListLogPlot[ Reverse[({#1[[1]], #2} & @@@ Cases[Values[#], _Circle, \[Infinity]]) & /@ ResourceFunction["ModularTessellation"][16, "BoundingCircles"]]]
Out[119]=

Place the circles in 3D with smaller circles placed in front of larger ones:

In[120]:=
coloredCircle3D[Circle[{x_, y_}, r_]] := With[{mp = {x, 4 Log10[1. r], y}},  {ColorData["DarkRainbow"][-Log10[1. r]],
     Polygon[Append[#, mp] & /@  #], Black, Line[#]} &@
   Partition[
    Table[mp + r {Cos[\[CurlyPhi]], 0, Sin[\[CurlyPhi]]}, {\[CurlyPhi], 0., 2. Pi, 2 Pi/36}], 2, 1]]
In[121]:=
Graphics3D[{EdgeForm[], coloredCircle3D /@ Cases[Values[
     ResourceFunction["ModularTessellation"][{12}, "BoundingCircles"]], _Circle, \[Infinity]]}, Axes -> {True, False, False}]
Out[121]=

Plot Ford circles (arising from the Farey sequence) together with the circles from the modular tessellation:

In[122]:=
FordCircle[r_] := With[{den = (2 Denominator[r]^2)}, Circle[{r, 1/den}, 1/den]]
In[123]:=
Graphics[{Black, FordCircle /@ FareySequence[12],
                   Darker[Red], Values[ResourceFunction["ModularTessellation"][12, "BoundingCircles"]]},
                   PlotRange -> {{0, 1}, {0, 1/3}}, ImageSize -> Medium, Axes -> {True, False}, PlotRangeClipping -> True]
Out[123]=

Possible Issues

The number of modular transformations increases quickly with the order. This means graphics of order ≃20 will take longer to compute and render:

In[124]:=
Length /@ ResourceFunction["ModularTessellation"][ 20, "TransformationFunctionList"]
Out[124]=

The polygons are approximate; this means making their boundaries near the x axis visible by using logarithmic scaling shows numerical artifacts:

In[125]:=
Graphics[MapIndexed[{GrayLevel[Mod[#2[[1]], 2]], #1} &, ResourceFunction["ModularTessellation"][
    12] ] /.
                                                         \ Polygon[l_] :> Polygon[{#1, Log10[#2]} & @@@ l], PlotRange -> {{0, 2}, {-3, 1}}, AspectRatio -> 1]
Out[125]=

Boolean regions, implicit regions and bounding circles are only supported for the upper half-plane, not for the unit circle–mapped triangles:

In[126]:=
ResourceFunction["ModularTessellation"][
 Function[\[FormalZ], (-1 - 2 \[FormalZ])/\[FormalZ]], {"BooleanRegions", {I, -Pi/2}}]
Out[126]=
In[127]:=
ResourceFunction["ModularTessellation"][
 Function[\[FormalZ], (-1 - 2 \[FormalZ])/\[FormalZ]], {"BoundingCircles", {I, -Pi/2}}]
Out[127]=

Neat Examples

A symmetrized version of the modular tessellation:

In[128]:=
With[{bw = MapIndexed[{GrayLevel[Mod[#2[[1]], 2]], #1} &, Select[#, Max[Norm /@ #[[1]]] <= 1 &] & /@ \
              ResourceFunction["ModularTessellation"][12]]},
 Graphics[{bw, GeometricTransformation[bw /. GrayLevel[g_] :>
                                                                      \
                       GrayLevel[1 - g], ReflectionTransform[{0, 1}]]},
                    PlotRange -> 1, Background -> LightBlue]]
Out[128]=

Color each order of triangles differently:

In[129]:=
Graphics[{RandomColor[], #} & /@ ResourceFunction["ModularTessellation"][12],
                   PlotRange -> {{-1, 1}, {0, 1}}, Background -> LightBlue]
Out[129]=

Convert each triangle into a 3D plot with the height depending on the distance to the polygon boundary:

In[130]:=
ridgePlot[p : Polygon[l_]] := Module[{rd = SignedRegionDistance[p], d}, d[x_Real, y_Real] := -rd[{x, y}];
   Plot3D[d[x, y], {x, y} \[Element] p, Mesh -> False, PlotRange -> All, PlotPoints -> 60,
    ColorFunction -> (Blend[{Black, Red}, #3^2] &), ColorFunctionScaling -> True]][[1]]
In[131]:=
Graphics3D[{#, GeometricTransformation[#, ReflectionTransform[{0, 1, 0}]]} &[
  ridgePlot /@ Flatten[Select[#, Max[Norm /@ #[[1]]] <= 1 &] & /@ ResourceFunction["ModularTessellation"][5]]],
 PlotRange -> All, Axes -> False, BoxRatios -> {1, 1, 0.3}]
Out[131]=

Conformally map the triangles of the unit disk into a triangle:

In[132]:=
nGonMap[n_, {x_, y_}] := With[{z = x + I y},
   ReIm[ z/n Beta[z^n, 1/n, 1 - 2/n]/((z^n)^(1/n))]];
In[133]:=
Graphics[MapIndexed[{GrayLevel[Mod[#2[[1]], 2]], #1} &, Values @ ResourceFunction["ModularTessellation"][
     12, {"UnitDiskMappedApproximationPolygons", {2 I, -Pi/2}}] /. Polygon[l_] :>  Polygon[nGonMap[3, #] & /@ l]],
                   PlotRange -> All]
Out[133]=

Interactively change the parameters of the most general map from the upper half-plane to the unit disk:

In[134]:=
Manipulate[
 Graphics[MapIndexed[{GrayLevel[Mod[#2[[1]], 2]], #1} &, Values @ ResourceFunction["ModularTessellation"][
     m, {"UnitDiskMappedApproximationPolygons", {\[Beta].{1, I}, \[Theta]}}] ],
                    PlotRange -> 1],
 {{m, 6}, Range[12], SetterBar},
 {{\[Beta], {0, 2}}, {-3, 0.001}, {3, 3}},
 {{\[Theta], -Pi/2}, -Pi, Pi}]
Out[134]=

Map an interactively movable point from the fundamental domain into other triangles and connect nearest points by lines:

In[135]:=
mtList = Flatten[
   ResourceFunction["ModularTessellation"][6, "TransformationFunctionList"]];
In[136]:=
gr = MapIndexed[{{Lighter[Blue, 0.2],
        Lighter[Red, 0.2]}[[Mod[#2[[1]], 2] + 1]], #1} &, ResourceFunction["ModularTessellation"][6]];
In[137]:=
DynamicModule[{pt = {0, 1.3}},
 Graphics[{gr,  Yellow, Dynamic[
    With[{l = Select[ReIm[#[pt.{1, I}] & /@ mtList], Max[Abs[#]] < 3 &]}, LL = l;
     {Point[l], nf = Nearest[l]; {White, Line[{#, nf[#, 2][[-1]]} & /@ l]},
      {Gray, Line[{#, nf[#, 3][[-1]]} & /@ l]},
      {LightGray, Line[{nf[#, 2][[-1]], nf[#, 3][[-1]]} & /@ l]}}]],
   Locator[
    Dynamic[pt, (pt = {Min[0.5, Max[-0.5, #[[1]]]], Max[#[[2]], Sqrt[1 - #[[1]]^2]]}) &]]},
                   PlotRange -> {{-2, 2}, {0, 2}}, ImageSize -> 400]]
Out[137]=

Extract the circles of order 12 and locally add their radii:

In[138]:=
circleData = SortBy[Cases[
    Flatten[Values[
      ResourceFunction["ModularTessellation"][{12}, "BoundingCircles"]]],
                Circle[{_?(-1 <= # <= 1 &), _}, _]], N[#[[1, 1]]] &];
In[139]:=
Plot[Evaluate[
  Total[Piecewise[{{#2, #1[[1]] - #2 <= t <= #1[[1]] + #2 }}] & @@@ circleData]],
            {t, -1, 1}, PlotRange -> {0, 1}]
Out[139]=

Associate a frequency proportional to the circle's curvatures and play the resulting sound:

In[140]:=
Play[Evaluate[sound[t]], {t, -2, 2}]
Out[140]=

Resource History

License Information