在Mathematica中自编函数绘制Poincare圆盘

庞加莱圆盘中的双曲直线表现为圆弧形式，若将其延伸，这些圆弧将与单位圆边界形成正交。要在圆盘内实现密铺，需要将多边形瓦片的顶点及其圆弧边沿相同的圆弧边进行反射操作，这对应着在圆上进行反演变换。

具体操作步骤是：首先选取一个中心p边形（即边数为p的多边形），并确保每个顶点处有q个这样的多边形交汇。随后沿该多边形的每条圆弧边进行反射，生成p个新多边形。根据所需的密铺深度，递归重复这一迭代过程。

基于上述原理，可以通过以下方式扩展代码功能：为双曲多边形（非直边多边形）添加色彩；通过在瓦片中点绘制线条构建对偶密铺结构；将算法推广至三维空间实现立体密铺；或通过截切瓦片边角生成新型几何图案等。

HyperbolicLine  函数用于在庞加莱圆盘中绘制点 P 和 Q 之间的双曲直线。

HyperbolicLine[{{Px_, Py_}, {Qx_, Qy_}}] := If[N[Chop[Px Qy - Py Qx]] =!= 0., Circle[OrthoCentre[{{Px, Py}, {Qx, Qy}}], OrthoRadius[{{Px, Py}, {Qx, Qy}}], OrthoAngles[{{Px, Py}, {Qx, Qy}}]], Line[{{Px, Py}, {Qx, Qy}}]] (*三个函数*) OrthoCentre[{{Px_, Py_}, {Qx_, Qy_}}] := With[{d = 2 Px Qy - 2 Py Qx, p = 1 + Px^2, q = 1 + Qx^2 + Qy^2}, If[N[d] =!= 0., {p Qy + Py^2 Qy - Py q, -p Qx - Py^2 Qx + Px q}/d, ComplexInfinity]] OrthoRadius[{{Px_, Py_}, {Qx_, Qy_}}] := If[N[Chop[Px Qy - Py Qx]] =!= 0., Sqrt[Total[OrthoCentre[{{Px, Py}, {Qx, Qy}}]^2] - 1], Infinity] OrthoAngles[{{Px_, Py_}, {Qx_, Qy_}}] := Block[{a, b, c = OrthoCentre[{{Px, Py}, {Qx, Qy}}]}, If[(a = N[Apply[ArcTan, {Px, Py} - c]]) < 0., a = a + 2 \[Pi]]; If[(b = N[Apply[ArcTan, {Qx, Qy} - c]]) < 0., b = b + 2 \[Pi]]; {a, b} = Sort[{a, b}]; If[b - a > \[Pi], {b, a + 2 \[Pi]}, {a, b}]]

Inversion 函数可对点、直线及多边形进行关于圆的反演变换。（即通过几何反演操作，将对象映射到指定圆的镜像位置）

Inversion[Circle[{Cx_, Cy_}, r_], {Px_, Py_}] := {Cx, Cy} + r^2 {Px - Cx, Py - Cy}/((Cx - Px)^2 + (Cy - Py)^2) Inversion[Circle[{Cx_, Cy_}, r_, {a_, b_}], {Px_, Py_}] := {Cx, Cy} + r^2 {Px - Cx, Py - Cy}/((Cx - Px)^2 + (Cy - Py)^2) Inversion[Circle[{Cx_, Cy_}, r_, {a_, b_}], p_Line] := Map[Inversion[Circle[{Cx, Cy}, r], #] &, p, {2}] Inversion[Circle[{Cx_, Cy_}, r_, {a_, b_}], p_Polygon] := Map[Inversion[Circle[{Cx, Cy}, r], #] &, p, {2}] Inversion[Line[{{Px_, Py_}, {Qx_, Qy_}}], {Ux_, Uy_}] := With[{u = Px - Qx, v = Qy - Py}, {-Ux (v^2 - u^2) - 2 u v Uy, Uy (v^2 - u^2) - 2 u v Ux}/(u^2 + v^2)] Inversion[Line[{{Px_, Py_}, {Qx_, Qy_}}], p_Polygon] := Map[Inversion[Line[{{Px, Py}, {Qx, Qy}}], #] &, p, {2}] Inversion[Circle[{Cx_, Cy_}, r_], c_List] := Map[Inversion[Circle[{Cx, Cy}, r], #] &, c]

对多边形或多边形列表的顶点进行关于双曲直线（可能为直线或圆弧）的反演变换。

PolygonInvert[p_Polygon] := Map[Inversion[HyperbolicLine[#], p] &, Partition[Join[p[[1]], {p[[1, 1]]}], 2, 1]] PolygonInvert[p_List] := Flatten[Map[PolygonInvert[#] &, p]]

使用直线或双曲直线连接双曲多边形的各顶点。（即在双曲几何中，既可用欧几里得直线段连接顶点，也可沿庞加莱圆盘模型中的正交圆弧——双曲测地线——进行连接）

LineRule = Polygon[x_] :> Line[Join[x, {x[[1]]}]]; HyperbolicLineRule = Polygon[x_] :> Map[HyperbolicLine, Partition[Join[x, {x[[1]]}], 2, 1]];

CentralPolygon  函数用于生成迭代所需的初始多边形。该多边形（边数为 p）的第一个顶点位于第一象限，与水平轴夹角为 π/p（每个顶点处汇聚了 q 个同类多边形）。通过指定可选的第三个参数 φ（弧度值），可使多边形按逆时针方向旋转指定角度。

（注：该函数通过调节初始顶点角度、多边形边数 p 及顶点交汇数 q，构建符合双曲密铺 {p,q} 条件的基准多边形，旋转参数 φ 可实现密铺图案的整体方位调整）

CentralPolygon[p_Integer, q_Integer, \[Phi]_ : 0] := With[{r = (Cot[\[Pi]/p] Cot[\[Pi]/q] - 1)/ Sqrt[Cot[\[Pi]/p]^2 Cot[\[Pi]/q]^2 - 1], \[Theta] = \[Pi] Range[ 1, 2 p - 1, 2]/p}, r Map[{{Cos[\[Phi]], -Sin[\[Phi]]}, {Sin[\[Phi]], Cos[\[Phi]]}} . # &, Transpose[{Cos[\[Theta]], Sin[\[Theta]]}]]]

删除重复的多边形，允许设置容差。（即在几何处理中，根据预先定义的容差值判定多边形间的相似性，若顶点坐标或形状差异小于该阈值，则视作重复项进行剔除，避免因计算精度问题导致的冗余）

PolygonUnion[p_Polygon, tol_ : 10.^-10] := p PolygonUnion[p_List, tol_ : 10.^-10] := With[{q = p /. Polygon[x_] :> N[Polygon[Round[x, 10.^-10]]]}, DeleteDuplicates[q]]

HyperbolicTessellation 函数通过以下参数生成双曲密铺：

• 以 p 边形（边数为 p 的多边形）为基本瓦片；
• 每个顶点处汇聚 q 个多边形；
• 递归嵌套至 k 级深度；
• 整体密铺图案可按逆时针方向旋转 φ 弧度。

（注：该函数基于双曲几何的 {p,q} 密铺规则，通过逐层反射和反演操作构建层级化的镶嵌结构，旋转参数 φ 用于调整密铺整体方向）

HyperbolicTessellation[p_Integer, q_Integer, \[Phi]_, k_Integer, t_ : 10.^-10] := Map[PolygonUnion[#, t] &, NestList[PolygonInvert, Polygon[CentralPolygon[p, q, \[Phi]]], k][[{-2, -1}]]] /; k > 0 HyperbolicTessellation[p_Integer, q_Integer, \[Phi]_, k_Integer, t_ : 10.^-10] := Polygon[CentralPolygon[p, q, \[Phi]]] /; k == 0

HyperbolicTessellationGraphics[p_Integer, q_Integer, \[Phi]_, k_Integer, rule_RuleDelayed, opts___] := Graphics[{Circle[{0, 0}, 1], HyperbolicTessellation[p, q, \[Phi], k, 10.^-10] /. rule}, opts]

HyperbolicTessellationGraphics[7, 3, 0., 3, HyperbolicLineRule, PlotLabel -> "{7,3}"]

Graphics[{EdgeForm[{Thin, Black}], Flatten[HyperbolicTessellation[5, 4, 0., 4]] /. Polygon[x_] :> {ColorData["DarkRainbow", Norm[Mean[x]]], Polygon[x]}}]

Block[{poly = Flatten[HyperbolicTessellation[7, 3, 0., 4]]}, Graphics[{EdgeForm[{Thin, Black}], poly /. Polygon[x_] :> Polygon[x, VertexColors -> Map[ColorData["SouthwestColors", Norm[#]^1.2 + RandomReal[{0., 0.3}]] &, x]]}]]