(* rules for rendering 2D spherical geometry either by stereographic projection to the plane or using 3D graphics *) BeginPackage["Spherical`", "Sphere`", "Orthogonalize`"] ResolveSpherical ResolveSpherical3D Begin["`private`"] (* stuff for drawing 3D pictures in spherical geometry *) ResolveSpherical3D = Join[{ Point[x_]:> Point[x], Line[{a_,b_}]:> Block[{c = ArcCos[a.b], n, bb}, n = Floor[20 c/Pi] + 1; bb = Orthonormal[{a, b}][[2]]; Line[Table[a Cos[x] + bb Sin[x], {x, 0, c, c/n}]]], Circle[v_,r_]:> (Circle[Cos[r]*unit[v], Sin[r], unit[v]] /. ResolveCircle3D), Disk[v_,r_]:> (Disk[Cos[r]*unit[v], Sin[r], unit[v]] /. ResolveCircle3D)}, ResolveSpheres] (* stuff for drawing spherical geometry stereographically projected *) ResolveSpherical = { Text[t_, x_]:> Text[t,sproj[x]], Line[{a_, b_}]:> parc[a,b], (ob:Circle|Disk)[{h__,v_}, r_]:> Block[ {m = -(Cos[r] - v)/((1 - v Cos[r])^2 - {h}.{h} Sin[r]^2)}, ob[m {h}, Abs[m Sin[r]]]], Point[v_]:> Point[sproj[v]]} (* arc on sphere projected to plane *) parc[x1_,y1_]:= Block[{c, x, y, n, r, ax, ay}, {x, y} = sproj /@ {x1, y1}; n = unit[Cross[x1,y1]]//N; If[x===spole, Return[Line[{y, 3 y}]]]; If[y===spole, Return[Line[{x, 3 x}]]]; If[Abs[n[[-1]]]<.01, Return[Line[{x,y}]]]; c = Drop[n,-1]/n[[-1]]; r = 1/Abs[n[[-1]]]; {ax, ay} = If[n[[-1]]>0., {angle[x-c],angle[y-c]}, {angle[y-c],angle[x-c]}]; If[ax>ay, ay += 2 N[Pi]]; Circle[c, r, {ax,ay}]] (* stereographic projection from the sphere to the plane *) sproj[{x1_,x2_,x3_}]:= If[x3==-1,spole,{x1,x2}/(1 + x3)] Cross[x_,y_] := RotateLeft[RotateLeft[y] x - RotateLeft[x] y] angle[x_]:= Arg[x.{1,I}] End[] EndPackage[]