สร้างพล็อต (ดิสก์ Poincare) ของ tessellation บนระนาบไฮเพอร์โบลิกเช่น:

โปรแกรมใช้สี่อินพุต:

1) จำนวนขอบ / รูปหลายเหลี่ยม (สามในตัวอย่างนี้)

2) จุดตัดแต่ละจุดยอดแต่ละจุด (เจ็ดในตัวอย่างนี้)

3) ห่างจากจุดศูนย์กลางกึ่งกลางที่จะแสดง (5 ในตัวอย่างนี้ถ้าคุณดูอย่างใกล้ชิด) ซึ่งหมายความว่าจุดสุดยอดจะถูกรวมถ้ามันสามารถเข้าถึงได้ใน 5 ขั้นตอนหรือน้อยกว่ารูปแบบที่ศูนย์ ขอบมีการแสดงผลถ้ารวมทั้งจุดสุดยอดของพวกเขาจะรวม

4) ความละเอียดของภาพ (จำนวนพิกเซลเดียวคือภาพเป็นสี่เหลี่ยม)

ผลลัพธ์จะต้องเป็นภาพ ขอบจะต้องแสดงผลเป็นวงกลมเส้นโค้งไม่ใช่เส้น (การฉายดิสก์Poincaréเปลี่ยนเส้นเป็นวงกลม) ไม่จำเป็นต้องแสดงคะแนน เมื่อผู้ใช้ใส่อะไรที่ไม่ใช่ไฮเพอร์โบลิก (เช่น 5 สามเหลี่ยมประชุมที่แต่ละจุดสุดยอด) โปรแกรมไม่ต้องทำงานอย่างถูกต้อง นี่คือรหัสกอล์ฟดังนั้นคำตอบที่สั้นที่สุดชนะ

Mathematica, 2535 ไบต์

นำมาจากที่นี่ (เพราะเหตุใดจึงเป็นชุมชน wiki) ไม่ใช่ว่าเล่นกอล์ฟจริงๆ ดูลิงค์ที่ให้ไว้สำหรับคำอธิบายของผู้เขียนรหัสของเขา

นอกจากนี้ฉันไม่ใช่ผู้เชี่ยวชาญทางคณิตศาสตร์ แต่ฉันคิดว่ามาร์ตินสามารถทำสิ่งมหัศจรรย์เกี่ยวกับความยาวของรหัสได้ ฉันไม่เข้าใจแม้แต่คณิตศาสตร์ที่อยู่เบื้องหลัง

ฉันปล่อยให้อ่านได้ แต่ถ้าคำถามไม่ปิดฉันจะอ่านมันผ่านไปแล้วและย้ายพารามิเตอร์ 2 ตัวอื่น ๆ ภายในฟังก์ชั่นผู้โทร

ในปัจจุบันไม่ถูกต้องรู้สึกฟรีเพื่อช่วยปรับปรุง:

• ฉันคิดว่านี่ใช้เส้นมากกว่าส่วนโค้ง

• มีศูนย์กลางที่ใบหน้าแทนที่จะเป็นจุดสุดยอด

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[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_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_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[3, 7, 0., 7, HyperbolicLineRule, ImageSize -> 300, PlotLabel -> "{7,7}"]