Mathematica 中五边形的双曲镶嵌

Question

我想在 Mathematica 中实现这个：

我意识到我可以使用 ParametricPlot 来获取线条，然后使用 Mesh 选项来填充颜色。谁能告诉我这些直线方程的通用公式是什么？它能推广到规则的 n 边形吗？

Answer 1

我在 1999 年编写了一些代码，定义了一个

PTiling

函数，该函数可以执行接近您想要的操作。我已将该代码包含在该响应的底部。一旦执行定义

PTiling

，您应该能够生成如下图片：

Show[PTiling[5, 2, 3], ImageSize -> 600, PlotRange -> 1.1]

显然，我们只有一张黑白图片来说明您想要的五边形的边界，但希望这是一个好的开始。 我认为人们可以使用圆盘的一部分，而不是圆圈，来更接近你想要的。

---

对代码的一些注释是有序的。 这些想法都在 Saul Stahl 的优秀著作《庞加莱半平面》中进行了描述，特别是关于庞加莱圆盘的章节。 我编写代码是为了说明我在 1999 年教授的几何课的一些想法，因此它一定是针对版本 3 或 4 的。我没有采取任何措施来尝试优化任何后续版本的代码。

此外，并非所有

n

和

k

的组合都效果那么好。我认为他们实际上需要谨慎选择；老实说，我不记得应该如何选择它们。

(* Generates a groovy image of the Poincare disk *)
(* Not all combinations of n and k work great *)

PTiling[n_Integer, k_Integer, depth_ : 2] := Module[
    {aH, a, q, r, idealPoints, z1Ideal, z2Ideal, init, initCircs},
    
    aH = ArcCosh[(Cos[Pi/n] Cos[Pi/2] + 
            Cos[(n - 2) Pi/(2 k)])/(Sin[Pi/n] Sin[Pi/2])];
    a = (Exp[aH] - 1)/(Exp[aH] + 1);
    q = (a + 1/a)/2;
    r = q - a;
    
    (* The Action *)
    idealPoints = {x, y} /. NSolve[{x^2 + y^2 == 1, 
            (x - q)^2 + y^2 == r^2}, {x, y}]; 
    {z1Ideal, z2Ideal} = toC /@ idealPoints;
    
    init = N@IdealPLine[{z1Ideal, z2Ideal}];
    initCircs = NestList[RotateCircle[#, 2 Pi/n] &, init, n - 1];
    
    Show[Graphics[{Nest[Iter, initCircs, depth], PGamma}],
        AspectRatio -> Automatic]
];


(* Ancillary code *)

(* One step in the iteration *)
Iter[PLineList_List] := Union[PLineList, Select[Flatten[
        Outer[Reflect, PLineList, PLineList]], (# =!= Null &)],
  SameTest -> sameCircleQ
];


(* Generate the ideal Poincare line through the points z1 and z2 *)
(* Should be an arc, if z1 and z2 are not on the same diameter *)
IdealPLine[{z1_, z2_}] := Module[
    {center},
    center = Exp[I (Arg[z2] + Arg[z1])/2] / 
            Cos[(Arg[z2] - Arg[z1])/2];
    arc[{z1, z2}, center]
];
arc[{z1_, z2_}, z0_] := Module[{theta1, theta2},
        theta1 = Arg[z1 - z0]; 
        theta2 = Arg[z2 - z0];
    
        If[Abs[N[theta1 - theta2]] > Pi, 
            If[N[theta1] < N[theta2], 
                theta1 = theta1 + 2 Pi, 
                theta2 = theta2 + 2 Pi]
    ];
    
        Circle[toR2[z0], Abs[z1 - z0],
            Sort[{theta1, theta2}, N[#1] < N[#2] &]
    ]
];

(* Circle operations *)
Invert[Circle[c_, r1_, ___], z_] := 
        r1^2/Conjugate[z - toC[c]] + toC[c];
Reflect[circ1_Circle, Circle[c2_, r2_, thetaList_]] := 
        IdealPLine[
      Invert[circ1, toC[c2 + r2 *{Cos[#], Sin[#]}]] & /@ thetaList
    ];
RotateCircle[Circle[c_, r_, thetaList_], theta_] := 
    Circle[RotationMatrix[theta] . c, r, theta + thetaList];

cSameCircleQ = Compile[
   {{c1, _Real, 1}, {r1, _Real}, {th1, _Real, 1},
    {c2, _Real, 1}, {r2, _Real}, {th2, _Real, 1}},
   (c1[[1]] - c2[[1]])^2 + (c1[[2]] - c2[[2]])^2 + (r1 - r2)^2 +
     (th1[[1]] - th2[[1]])^2 + (th1[[2]] - th2[[2]])^2 < 0.00001];
sameCircleQ[Circle[c1_, r1_, th1_], Circle[c2_, r2_, th2_]] := 
  cSameCircleQ[c1, r1, th1, c2, r2, th2];


(* Basics *)
toR2 = {Re[#], Im[#]} &;
toC = #[[1]] + #[[2]] I &;
PGamma = {Thickness[.008], GrayLevel[.3],Circle[{0, 0}, 1]};