Hyperbolic Icosahedron
Concept by Igor Rivin, Picture by Henry Cejtin

Explanation

The object depicted is an ideal hyperbolic icosahedron.  This is the analog of a regular icosahedron in hyperbolic space.

Implementation

Note for Mac version: To save file space, this picture is stored in Bitmap PICT form, rather than resolution-independent PostScript.  This version is stored as a color image, for display on a color monitor.  You can regenerate the PostScript by running the Mathematica code given here.  Note, however, that this will take a long time, and will require a great deal of memory.

Define Functions

(** Code by Henry Cejtin; concept by Igor Rivin **)

Needs ["Graphics`Polyhedra`"]

(*
 * Functions to draw hyperbolic polyhedra.
 *)


(*
 * Good options for color graphics.
 *)
SetOptions[
	Graphics3D,
	Boxed->False,
	RenderAll->False,
	PlotColor->True,
	Axes->None, PlotRange->{{-0.52, 0.52},
	  {-0.52, 0.52}, {-0.55, 0.55}},
	LightSources -> { {{1, 0, 1}, RGBColor[1,0,0]},
	 {{1, 1, 1}, RGBColor[0, 1, 0]},
	 {{0, 0.9, 1}, RGBColor[0,0,1]}}
];




(*
 * Given a triangle, returns a center/radius/triangle.
 *)
TtoCRT[Polygon[{p_, q_, r_}]] :=
	Block[{
		tmp
		},
		tmp = Map[
			N[ToSphere[
				#,
				{
					{0, 0, 0},
					1
				}
			]]&,
			{p, q, r}
		];
		{
			Apply[InSphere, tmp],
			tmp
		}
	]


(*
 * Given a center/radius/triangle, return a triangle.
 *)
CRTtoT[{sphere_, triangle_}] :=
	Polygon[triangle]


(*
 * Given a list of triangles and a list of 
 * triangle-refining functions, return the graphics 
 * object which is the hyperbolic version of the 
 * triangle list, subdivided appropriately.
 *)
 HyperPoly[tlist_List, sdlist_List] :=
	Block[{
		ts
		},
		ts = Map[
			TtoCRT,
			tlist
		];
		Scan[
			(ts = Flatten[
				Map[#, ts],
				1
			])&,
			sdlist
		];
		ts = Map[
			CRTtoT,
			ts
		];
		Graphics3D[ts]
]


(*
 * Perform Barycentric subdivision.
 *)
Bary6[{sphere_List, {p_List, q_List, r_List}}] :=
	Block[{
		center = ToSphere2[
				(p + q + r) / 3,
				sphere
			],
		pq = ToSphere2[(p + q) / 2, sphere],
		qr = ToSphere2[(q + r) / 2, sphere],
		rp = ToSphere2[(r + p) / 2, sphere]
		},
		{
			{sphere, {p, pq, center}},
			{sphere, {pq, q, center}},
			{sphere, {q, qr, center}},
			{sphere, {qr, r, center}},
			{sphere, {r, rp, center}},
			{sphere, {rp, p, center}}
		}
	]


(*
 * Perform subdivision into 4 parts.
 *)
Bary4[{sphere_List, {p_List, q_List, r_List}}] :=
	Block[{
		pq = ToSphere2[(p + q) / 2, sphere],
		qr = ToSphere2[(q + r) / 2, sphere],
		rp = ToSphere2[(r + p) / 2, sphere]
		},
		{
			{sphere, {p, pq, rp}},
			{sphere, {pq, q, qr}},
			{sphere, {qr, r, rp}},
			{sphere, {rp, pq, qr}}
		}
	]


(*
 * Perform subdivision into 4 parts if we are at a spike.
 *)
Bary4If[{sphere_List, p_List}] :=
	Block[{
		rad = Max[
			Map[
				(# . #)&,
				p
			]
		]
		},
		If[rad >= .999,
			Bary4[{sphere, p}],
			{{sphere, p}}
		]
	]


(*
 * Given 3 points on the surface of the unit sphere 
 * centered at the origin, return the center and radius 
 * of a sphere which goes through those points and is 
 * perpendicular to the unit sphere.
 *)
Block[{
		p, px, py, pz,
		q, qx, qy, qz,
		r, rx, ry, rz,
		center, cx, cy, cz,
		radius
		},
		p = {px, py, pz};
		q = {qx, qy, qz};
		r = {rx, ry, rz};
		center = {cx, cy, cz};
		center = center /.
			Solve[{
				p . center == 1,
				q . center == 1,
				r . center == 1
				},
				center
			][[1]];
		radius = Sqrt[center . center - 1];
	InSphere[{px_, py_, pz_}, {qx_, qy_, qz_}, {rx_, ry_, rz_}] =
		{center, radius};
]


(*
 * Given a point and the center/radius of a sphere, 
 * project the point towards the origin until it lies 
 * on the surface of the sphere.
 *)
ToSphere2[p_List, {center_, radius_}] :=
	Block[{
		lambda
		},
		lambda = lambda /.
		Solve[
			lambda ^2 (p . p) - lambda (2 p . center) +
				(center . center) == radius^2,
			lambda
		];
		lambda = Sort[
			lambda,
			Function[
				{x, y},
				Abs[x-1] <= Abs[y-1]
			]
		];
		lambda = lambda[[1]];
		p lambda
	]


(*
 * Given a point and the center and radius of a sphere, 
 * project the point onto the surface of the sphere.
 *)
ToSphere[p_List, {center_, radius_}] :=
	Block[{
		offset = p - center
		},
		center + offset (radius / Sqrt[offset . offset])
	]


(*
 * Given two non-zero vectors, return the angle between 
 * them (ignoring the orientation of the vector).
 *)
VectorAngle[p_, q_] :=
	ArcCos[
		Abs[
			Unitize[p] . Unitize[q]
		]
	]


(*
 * Convert a vector to have unit length.
 *)
Unitize[p_] :=
	p / Sqrt[p . p]


(*
 * Given a center/radius/triangle, return a normal to 
 * the plane of the triangle.
 *)
Norm3crt[{sphere_, {p_, q_, r_}}] :=
	Cross[
		p - r,
		q - r
	]


(*
 * Given two vectors, return the cross product.
 *)
Cross[p_, q_] :=
	Det[{
		IdentityMatrix[3],
		p,
		q
	}]

Generate Graphic

Show[
	HyperPoly[
		Icosahedron[],
		{
			Bary4,
			Bary6,
			Bary4,
			Bary4If
		}
	]
]