rieman-sphere.wls

(* Projection from the sphere to the plane *)
stereo = Compile[{{xyz, _Real, 1}, {XYZ, _Real, 1}}, Module[{
     r = Sqrt[(xyz[[1]] - XYZ[[1]])^2 + (xyz[[2]] - XYZ[[2]])^2],
     theta = ArcTan[(xyz[[1]] - XYZ[[1]]), (xyz[[2]] - XYZ[[2]])]},
    {(r (1 + xyz[[3]]))/(1 - XYZ[[3]] + xyz[[3]]) Cos[theta + Pi] + xyz[[1]],
     (r (1 + xyz[[3]]))/(1 - XYZ[[3]] + xyz[[3]]) Sin[theta + Pi] + xyz[[2]], 0}]];

(* Projection from the plane to the sphere *)
stereoInv = Compile[{{pq, _Real, 1}, {xyz, _Real, 1}},
   {2 pq[[1]], 2 pq[[2]], 
    pq[[1]]^2 + pq[[2]]^2 - 1}/(pq[[1]]^2 + pq[[2]]^2 + 1) + xyz];

(* The initial grid in the xy-plane *)
gridSpan = 1.2; step = 0.2;
plotSpan = 12;
xGrid = Table[{x, y, 0}, {y, -gridSpan, gridSpan, step}, 
  {x, -gridSpan, gridSpan, step/10}];
yGrid = Table[{x, y, 0}, {x, -gridSpan, gridSpan, step}, 
  {y, -gridSpan, 
    gridSpan, step/10}];
grid = Join[xGrid, yGrid];
(* {0,0} is problematic. *)
grid = DeleteCases[grid, {_?(NumericQ[#] &), _, _}?(Norm[#] < 0.0001 &), Infinity];

(* The initial grid in the xy-plane *)
gridSpan = 1.2; step = 0.2;
plotSpan = 12;
xGrid = Table[{x, y, 0}, {y, -gridSpan, gridSpan, step}, 
  {x, -gridSpan, gridSpan, step/10}];
yGrid = Table[{x, y, 0}, {x, -gridSpan, gridSpan, step}, 
  {y, -gridSpan, 
    gridSpan, step/10}];
grid = Join[xGrid, yGrid];
(* {0,0} is problematic. *)
grid = DeleteCases[grid, {_?(NumericQ[#] &), _, _}?(Norm[#] < 0.0001 &), Infinity];

mtrPic[phi_, theta_, vp_, showSphere_, xy_, z_] := Module[{warpedGrid},
   Quiet[warpedGrid = Normal[Rotate[
       Rotate[Line[Map[stereoInv[#, Flatten[{xy, z}]] &, grid, {2}]],
        theta, {0, 0, 1}, Flatten[{xy, 0}]], 
       phi, {-Sin[theta], Cos[theta], 0}, Flatten[{xy, z}]]];
    Graphics3D[{
      If[showSphere === True,
       {{Opacity[0.8], Sphere[Flatten[{xy, z}]]}, warpedGrid}, {}],
      {Map[stereo[Flatten[{xy, z}], #] &, warpedGrid, {3}]},
      {Opacity[0.5], 
       Polygon[plotSpan {{-1, -1, 0}, {1, -1, 0}, {1, 1, 0}, {-1, 1, 0}}]},
      {Specularity[White, 20], ColorData["StarryNightColors"][1],
       Tube[{{-12, 0, 0}, {12, 0, 0}}, 0.02],
       Tube[{{0, -12, 0}, {0, 12, 0}}, 0.02],
       Tube[{{0, 0, 0}, {0, 0, 3.8}}, 0.02],
       Cone[{{0, 0, 3.7}, {0, 0, 4}}, 0.1]}
      }, ImageSize -> 500, ViewPoint -> vp, 
     ViewAngle -> 30 Degree, Boxed -> False, 
     PlotRange -> {plotSpan {-1, 1}, plotSpan {-1, 1}, {-1, 4}}],
    Power::infy]
   ];


Manipulate[mtrPic[phi, theta, vp, showSphere, xy, z],
 {{phi, 0}, 0, Pi}, {{theta, 0}, -Pi, Pi},
 {{vp, {1.77141, -2.5135, 1.4121}/4, "view point"},
  {{1.77141, -2.5135, 1.4121}/4 -> "perspective", {0, 0, 2} -> "ortho"}},
 {{showSphere, True, "show sphere"}, {True, False}},
 {{xy, {0, 0}}, (plotSpan - 1) {-1, -1}, (plotSpan - 1) {1, 1}, 
  ControlPlacement -> Left},
 {{z, 1}, 0, 3, VerticalSlider, ControlPlacement -> Left},
 TrackedSymbols -> {phi, theta, vp, xy, z, showSphere},
 SaveDefinitions -> True]