Send/Receive
This one is fairly simple: form the latitude/longitude grid where the "north" and "south" poles are the points $(0,1,0)$ and $(0,-1,0)$, rotate the longitudes and simultaneously push the latitudes down, then stereographically project the whole thing to the plane. The motion makes the most sense in modified spherical coordinates (swapping the roles of the $y$- and $z$-axes), and I probably could have used some version of CoordinateTransform[]
to translate from spherical to rectangular coordinates if I hadn't just converted it in my head.
Some messing around with Blend[]
and VertexColors
gives the final continuous gradient of colors.
Here's the code:
Stereo[{x_, y_, z_}] := {x/(1 - z), y/(1 - z)};
With[{n = 15, cols = RGBColor /@ {"#FF7A5A", "#50E3C2", "#432160"}},
Manipulate[
Graphics[{
Thickness[.004],
Table[
{Line[
Table[Stereo[{Cos[? + s] Sin[t], Cos[t], Sin[? + s] Sin[t]}], {t, 0, ?, ?/100}],
VertexColors -> Table[Blend[cols[[;; 2]], a], {a, 0, 1, 1/101}]]},
{?, 0, 2 ? - ?/n, ?/n}],
Table[
{Blend[cols[[;; 2]], Mod[(?/2 + s)/(?), ?]],
Line[
Table[
Stereo[{Sin[?/2 + s] Cos[t], Cos[?/2 + s], Sin[?/2 + s] Sin[t]}],
{t, 0, 2 ?, 2 ?/100}]]},
{?, 0, 2 ? - 2 ?/n, 2 ?/n}],
cols[[1]], Disk[{0, 1}, .02], cols[[2]], Disk[{0, -1}, .02]},
PlotRange -> 2, ImageSize -> 540, Background -> cols[[-1]]],
{s, 0., ?/n}]
]