Poincaré Hyperbolic Disk

Author

Eric W. Weisstein
June 26, 2006

This notebook downloaded from http://mathworld.wolfram.com/notebooks/DifferentialGeometry/PoincareHyperbolicDisk.nb.

For more information, see Eric's MathWorld entry http://mathworld.wolfram.com/PoincareHyperbolicDisk.html.

©2006 Wolfram Research, Inc. except for portions noted otherwise

Additional Authors

Animation code written by 
Matthew Cook
http://library.wolfram.com/infocenter/Demos/148/

Hyperbolic tessellation by 
Michael Trott
Graphica 1

Code

PoincareArc::usage="PoincareArc[{theta1,theta2}] gives the arc from theta1 to theta2 on the Poincare hyperbolic disk."

PoincareDisk::usage="PoincareDisk[{{t11,t12},...,{tn1,tn2}}] plots a unit disk and the PoincareArcs with specified starting and ending angles."

PoincareArc[l0_List]:=Module[{l=Sort[l0],dt,t,t1,t2,r,R,c},dt=Abs[l[[1]]-l[[2]]];
t=Plus@@l/2;
If[dt==Pi,Line[{{Cos[l[[1]]],Sin[l[[1]]]},{Cos[l[[2]]],Sin[l[[2]]]}}],c={Cos[t],Sin[t]};
r=Tan[dt/2];
R=Sec[dt/2];
t1=ArcTan@@({Cos[l[[2]]],Sin[l[[2]]]}-R c);
t2=ArcTan@@({Cos[l[[1]]],Sin[l[[1]]]}-R c);
If[t2<t1,t2+=2Pi];
Circle[R c,r,{t1,t2}]]]

PoincareDisk[l_List]:=Module[{i},{{Thickness[.01],Circle[{0,0},1]},Table[PoincareArc[l[[i]]],{i,Length[l]}]}]

Hyperbolic Tessellation

From Michael Trott

Simple Diagrams

Show[Graphics[PoincareDisk[{{.4,1.8}}]],	AspectRatio->Automatic]

Show[Graphics[PoincareDisk[
			{{0,.5},{.5,1.7},{0,Pi},{-.7,1.},{-1.1,1.},{3.,4.5},{2.8,-.1},{2.2,2.4}}]],
	AspectRatio->Automatic]

Animation

This code written by Matthew Cook

http://library.internal.wolfram.com/infocenter/Demos/148/

We will represent lines in terms of the two args of their limiting directions.

argPoint[arg_] := {Cos[arg], Sin[arg]}

PLine[arg1_, arg2_] := If[N[Cos[(arg2 - arg1) / 2]] == 0,
	Line[{argPoint[arg1], argPoint[arg2]}],
	If[N[arg2 - arg1 > Pi], PLine[arg2, arg1],
	If[N[arg2 - arg1] < 0, PLine[arg1, arg2 + 2 Pi],
	Circle[Sec[(arg2 - arg1) / 2] *
			argPoint[(arg1 + arg2) / 2],
			Tan[(arg2 - arg1) / 2],
			{arg2 + Pi/2, arg1 - Pi/2
				+ If[N[arg2 + Pi] > arg1, 2 Pi, 0]}]
	]]]

We make a simple function to draw PLines.

PShow[stuff_] := Show[Graphics[{Circle[{0,0},1],stuff}],
	AspectRatio -> Automatic]

PShow[Table[PLine[x, x+y], {x, 0, 2 Pi, .6},
	{y, .1, 6, .3}]]

Now we need a function to give the perpendicular to a given line through a given limit point (the answer can be given just as the other limit point of the new line).

PPerp[{arg1_, arg2_}, arg3_] :=
	2 Apply[ArcTan,
			intersection[line[argPoint[arg1], argPoint[arg2]],
						line[argPoint[arg3], arg3 + Pi/2]
						]] - arg3

Now we are doing Euclidean geometry.  We can have a line of two points, or a point and a direction.  We prefer the second form.

line[p1_List, p2_List] := line[p1, Apply[ArcTan, p2 - p1]]

intersection[line[{x1_, y1_}, a1_], line[{x2_, y2_}, a2_]] :=
	{x1, y1} + argPoint[a1] * (a /. Flatten[{
	NSolve[{x1 + a Cos[a1] == x2 + b Cos[a2],
			y1 + a Sin[a1] == y2 + b Sin[a2]}, {a, b}],
		a -> 10.^6}])

Off[RowReduce::luc]

Now we make a function to make tilings like Igor's.

PTree[a1_, {a2_, a3_}, lev_] := If[lev == 0,
	PLine[a2, a3],
	{PLine[a2, a3],
		PTree[a2, {PPerp[{a2, a3}, a1], a3}, lev - 1],
		PTree[a3, {a2, PPerp[{a2, a3}, a1]}, lev - 1]
	}]

trinest[{a1_, a2_, a3_}, lev_] := PShow[{
	PTree[a1, {a2, a3}, lev],
	PTree[a2, {a3, a1}, lev],
	PTree[a3, {a1, a2}, lev]}]

trinest[N[{0, 2 Pi / 3, 4 Pi / 3}], 5]

Table[trinest[N[{0,foo[x] Pi/3,(x+1) 2 Pi/3}],5],{x,.025,.975,.05}]

Now we make a nifty animation.

foo[x_] := 1 + (2 x - x ^ 2 + 2 x ^ 3) / 3

Export[gifs<>"poincare.gif",Table[trinest[N[{0,foo[x] Pi/3,(x+1) 2 Pi/3}],5],{x,.025,.975,.05}]
]

Do[Do[trinest[N[{0-(x+rr) 2 Pi/3,foo[x] Pi/3-(x+rr) 2 Pi/3,(x+1) 2 Pi/3-(x+rr) 2 Pi/3}],5],{x,.025,.975,.05}],{rr,0,2}]