Составьте график (диск Пуанкаре) тесселяции на гиперболической плоскости, такой как:

Программа принимает четыре входа:

1) Сколько ребер / полигонов (три в этом примере).

2) Сколько пересекается в каждой вершине (семь в этом примере).

3) Сколько шагов от центральной вершины для рендеринга (5 в этом примере, если вы посмотрите внимательно). Это означает, что вершина включена, если она может быть достигнута за 5 или менее шагов от центра. Края отображаются, если обе их вершины включены.

4) Разрешение изображения (одно количество пикселей, изображение квадратное).

На выходе должно быть изображение. Края должны быть представлены как дуги окружности, а не линии (проекция диска Пуанкаре превращает линии в круги). Очки не должны быть оказаны. Когда пользователь вводит что-то, что не является гиперболическим (т.е. 5 треугольников, встречающихся в каждой вершине), программа не должна работать должным образом. Это код-гольф, поэтому выигрывает самый короткий ответ.

Mathematica, 2535 байт

Взято отсюда (отсюда и почему это вики сообщества). Не то чтобы игра в гольф. Просмотрите предоставленную ссылку для объяснения автора своего кода.

Кроме того, я не эксперт по Mathematica, но держу пари, что Мартин мог творить чудеса с длиной кода. Я даже не понимаю математику за этим.

Я оставил его читаемым, но если вопрос не будет закрыт, я оставлю его в читаемом состоянии и перенесу 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}"]