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...

mona lisa overdrive

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}]

output

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}
}]
*)

Tags:

Graphics