# 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[]^2 + vec[]^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[#[], #[], 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/2), 0}, {Sqrt/2, 1/2, 0}, {0, 0, 1}}]
TransformationFunction[{
{1/2, -(Sqrt/2), 1/2 - Sqrt/2},
{Sqrt/2, 1/2, 1/2 + Sqrt/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? – rm -rf 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