Non-geometric transformation of Graphics3D primitives
I understand that it's better to use 3D vector primitives than images at certain stages of the process. Eventually, though, everything gets rasterized, so you could just use ImageTransformation
for a quick fix...
Manipulate[
compiledFunction = Compile[{{x, _Real}, {y, _Real}, {fg, _Real}},
Module[{r = x + I y},
r = r + fg / r - fg;
{Re[r], Im[r] }]
];
ImageTransformation[img,
compiledFunction[#[[1]], #[[2]], s] &,
DataRange -> {{-1, 1}, {-1, 1}}, Padding -> "Reversed"],
{s, -3, 3, .1}]
Using parametrized surfaces it all becomes quite simple
σ[u_, v_] := {u, v, 0};
Manipulate[
(* Rotations *)
rtx = RotationTransform[ϕ, {1, 0, 0}, {0, 0, 1}];
rty = RotationTransform[θ, {0, 1, 0}, {0, 0, 1}];
rtz = RotationTransform[τ, {0, 0, 1}, {0, 0, 1}];
rt = rtz@rty@rtx@# &;
Show[
ParametricPlot3D[{g@rt@f@σ[u, v], rt@f@σ[u, v]},
{u, -1, 1}, {v, -1, 1},
ColorFunction -> Function[{x, y, z, u, v},
ColorData["Rainbow"][Rescale[u, {-1, 1}]]],
RegionFunction -> Function[{x, y, z, u, v}, Last@rt@f@σ[u, v] < 1.999],
ColorFunctionScaling -> False,
PlotRange -> {{-5, 5}, {-5, 5}, {-0.001, 2}},
Mesh -> 5],
Graphics3D[{
{Point[{0, 0, 2}]},
{Gray, Opacity[0.7], Sphere[{0, 0, 1}, 0.99]}}]
], {θ, 0, 2 Pi}, {ϕ, 0, 2 Pi}, {τ, 0, 2 Pi}]
Update Fixed problem with north pole being covered
Compiling the functions give better interactivity
Clear[θ, ϕ, τ]
rtx = RotationTransform[ϕ, {1, 0, 0}, {0, 0, 1}];
rty = RotationTransform[θ, {0, 1, 0}, {0, 0, 1}];
rtz = RotationTransform[τ, {0, 0, 1}, {0, 0, 1}];
rt = rtz@rty@rtx@# &;
tosphere = Compile[{u, v, θ, ϕ, τ},
Evaluate[FullSimplify[rt@f@σ[u, v], _ ∈ Reals]]
, CompilationTarget -> "C",
RuntimeOptions -> "Speed"];
toplane = Compile[{ u, v, θ, ϕ, τ},
Evaluate[FullSimplify[g@rt@f@σ[u, v], _ ∈ Reals]]
, CompilationTarget -> "C",
RuntimeOptions -> "Speed"];
Manipulate[
Show[
ParametricPlot3D[{toplane[u, v, θ, ϕ, τ],
tosphere[u, v, θ, ϕ, τ]},
{u, -1, 1}, {v, -1, 1},
ColorFunction -> Function[{x, y, z, u, v}, ColorData["Rainbow"][Rescale[u, {-1, 1}]]],
RegionFunction -> Function[{x, y, z, u, v}, Last@tosphere[u, v, θ, ϕ, τ] < 1.999],
ColorFunctionScaling -> False,
PlotRange -> {{-5, 5}, {-5, 5}, {-0.001, 2}},
Mesh -> 5,
PerformanceGoal -> "Quality"],
Graphics3D[{
{Point[{0, 0, 2}]},
{Gray, Opacity[0.7], Sphere[{0, 0, 1}, 0.99]}}]
], {θ, 0, 2 Pi}, {ϕ, 0, 2 Pi}, {τ, 0, 2 Pi}]
What you are looking for is GeometricTransformation
, specifically the first form
GeometricTransformation[g, tfun]
where g
is a graphics primitive (like Polygon
) and tfun
is a TransformationFunction
. You will have to figure out how to turn f
and g
into an AffineTransform
or even more likely a LinearFractionalTransform
, but composing them with the rotation is easy:
t = LinearFractionalTransform[{{1, 0, 1}, {0, 1, 1}, {1, 1, 1}}]
q = RotationTransform[Pi/3]
Composition[q, t]
(*
TransformationFunction[{{1, 0, 1}, {0, 1, 1}, {1, 1, 1}}]
TransformationFunction[{{1/2, -(Sqrt[3]/2), 0}, {Sqrt[3]/2, 1/2, 0}, {0, 0, 1}}]
TransformationFunction[{
{1/2, -(Sqrt[3]/2), 1/2 - Sqrt[3]/2},
{Sqrt[3]/2, 1/2, 1/2 + Sqrt[3]/2}, {1, 1, 1}
}]
*)