# Non-geometric transformation of Graphics3D primitives

I want to apply non-geometric transformations to polygons etc, the goal is to have a Manipulate objects that behaves like that famous möbius transform video.

Since I was unable to apply non-geometric transformation to a polygon I went ahead and created a bunch of points in the plane and did appropriate transforms to them

(* plane region *)
region = {-1, 1};
d = 0.07;
(* Some points in plane *)
pts = Flatten[Table[{xi, yi, 0},
{xi, First@region, Last@region, d},
{yi, First@region, Last@region, d}]
, 1];
col = ColorData["Rainbow"] /@ Rescale[pts[[All, 1]], region];
(** Projections from plane to sphere on line going through north pole \
of sphere centered at {0, 0, 1} **)

(* Plane to sphere *)
f[vec_] := With[{t = 4/(4 + vec[[1]]^2 + vec[[2]]^2)}, vec*t + (1 - t) {0, 0, 2}]
(* Sphere to plane *)
g[vec_] := With[{t = -(2/(-2 + Last@vec))}, vec*t + (1 - t) {0, 0, 2}]

rt = RotationTransform[2.1, {0, 1, 0}, {0, 0, 1}];
Graphics3D[{
{Black, Opacity[0.3], Sphere[{0, 0, 1}]},
Point[(rt@f@# &) /@ pts, VertexColors -> col],
Point[((g@rt@f@# &) /@ pts), VertexColors -> col]
},
PlotRange -> {{-10, 10}, {-10, 10}, {0, 2}}]


I wish that I could instead do something like:

Graphics3D[{
{Black, Opacity[0.3], Sphere[{0, 0, 1}]},
SomeTransformation[Polygon[{ {-1, -1, 0}, {-1, 1, 0}, {1, 1, 0}, {1, -1, 0}}], rt@f@#&],
SomeTransformation[Polygon[{ {-1, -1, 0}, {-1, 1, 0}, {1, 1, 0}, {1, -1, 0}}], g@rt@f@#&]
]


And end up with a smooth output, not just a few points here and there.

Is there already a function like this that I have missed?

If not are there other ways to arrive at the same result?

-
Perhaps of use: How can I find the vertexes of a Polygon? – Yves Klett Dec 27 '12 at 12:53
If you use discrete point transformations with the methods below then to get smooth curves you will have to up the number of points defining your (e.g.) Polygon outlines. – Yves Klett Dec 27 '12 at 19:05

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

-
Now all we need is some Pink Floyd and LSD to go with it... – R. M. Dec 27 '12 at 14:17
Also a lot of fun: stanwagon.com/public/ARCHIVE/QUADRATICCAMERA/… – Yves Klett Dec 27 '12 at 18:56
@rm-rf you go to the wrong sort of parties ... :) – cormullion Dec 27 '12 at 22:50
Since you didn't add the link for the Mona Lisa image, I looked for another one and found that this works quite well, too: Escher's Hand with reflecting sphere – Jens Dec 28 '12 at 4:24

Using parametrized surfaces it all becomes quite simple

\[Sigma][u_, v_] := {u, v, 0};

Manipulate[
(* Rotations *)
rtx = RotationTransform[\[Phi], {1, 0, 0}, {0, 0, 1}];
rty = RotationTransform[\[Theta], {0, 1, 0}, {0, 0, 1}];
rtz = RotationTransform[\[Tau], {0, 0, 1}, {0, 0, 1}];
rt = rtz@rty@rtx@# &;

Show[
ParametricPlot3D[{g@rt@f@\[Sigma][u, v], rt@f@\[Sigma][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@\[Sigma][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]}}]
], {\[Theta], 0, 2 Pi}, {\[Phi], 0, 2 Pi}, {\[Tau], 0, 2 Pi}]


Update Fixed problem with north pole being covered

Compiling the functions give better interactivity

Clear[\[Theta], \[Phi], \[Tau]]
rtx = RotationTransform[\[Phi], {1, 0, 0}, {0, 0, 1}];
rty = RotationTransform[\[Theta], {0, 1, 0}, {0, 0, 1}];
rtz = RotationTransform[\[Tau], {0, 0, 1}, {0, 0, 1}];
rt = rtz@rty@rtx@# &;

tosphere = Compile[{u, v, \[Theta], \[Phi], \[Tau]},
Evaluate[FullSimplify[rt@f@\[Sigma][u, v], _ \[Element] Reals]]
, CompilationTarget -> "C",
RuntimeOptions -> "Speed"];
toplane = Compile[{ u, v, \[Theta], \[Phi], \[Tau]},
Evaluate[FullSimplify[g@rt@f@\[Sigma][u, v], _ \[Element] Reals]]
, CompilationTarget -> "C",
RuntimeOptions -> "Speed"];

Manipulate[
Show[
ParametricPlot3D[{toplane[u, v, \[Theta], \[Phi], \[Tau]],
tosphere[u, v, \[Theta], \[Phi], \[Tau]]},
{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, \[Theta], \[Phi], \[Tau]] < 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]}}]
], {\[Theta], 0, 2 Pi}, {\[Phi], 0, 2 Pi}, {\[Tau], 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}
}]
*)

-
I thought the whole point of the question was to do non geometric transformations (possibly non-linear)? Does GeometricTransformation take arbitrary functions? – R. M. Dec 27 '12 at 16:42
@rm-rf it takes whatever can be turned into a TransformationFunction, so within the scope of a Möbius transform, then yes it can as those are called LinearFractionalTransform in mma. – rcollyer Dec 27 '12 at 16:44
Sadly if the TransformationFunction returned by LinearFractionalTransform is not affine GeometricTransformation gives the GeometricTransformation::nonaffine error – ssch Dec 27 '12 at 18:56
And FindGeometricTransform gives quite big alignment error for the transformations in question @rm-rf see above comment – ssch Dec 27 '12 at 18:59
@ssch well that sucks. I would have thought it could handle any TransformationFunction, otherwise I would not have suggested it. – rcollyer Dec 28 '12 at 3:06