13
$\begingroup$

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

output

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?

How about for more advanced transformations?

$\endgroup$
2
  • $\begingroup$ Perhaps of use: How can I find the vertexes of a Polygon? $\endgroup$
    – Yves Klett
    Dec 27, 2012 at 12:53
  • $\begingroup$ 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. $\endgroup$
    – Yves Klett
    Dec 27, 2012 at 19:05

3 Answers 3

15
$\begingroup$

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}]
$\endgroup$
4
  • 4
    $\begingroup$ Now all we need is some Pink Floyd and LSD to go with it... $\endgroup$
    – rm -rf
    Dec 27, 2012 at 14:17
  • 1
    $\begingroup$ Also a lot of fun: stanwagon.com/public/ARCHIVE/QUADRATICCAMERA/… $\endgroup$
    – Yves Klett
    Dec 27, 2012 at 18:56
  • $\begingroup$ @rm-rf you go to the wrong sort of parties ... :) $\endgroup$
    – cormullion
    Dec 27, 2012 at 22:50
  • $\begingroup$ 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 $\endgroup$
    – Jens
    Dec 28, 2012 at 4:24
13
$\begingroup$

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}]
$\endgroup$
4
$\begingroup$

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}
}]
*)
$\endgroup$
5
  • $\begingroup$ I thought the whole point of the question was to do non geometric transformations (possibly non-linear)? Does GeometricTransformation take arbitrary functions? $\endgroup$
    – rm -rf
    Dec 27, 2012 at 16:42
  • $\begingroup$ @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. $\endgroup$
    – rcollyer
    Dec 27, 2012 at 16:44
  • $\begingroup$ Sadly if the TransformationFunction returned by LinearFractionalTransform is not affine GeometricTransformation gives the GeometricTransformation::nonaffine error $\endgroup$
    – ssch
    Dec 27, 2012 at 18:56
  • $\begingroup$ And FindGeometricTransform gives quite big alignment error for the transformations in question @rm-rf see above comment $\endgroup$
    – ssch
    Dec 27, 2012 at 18:59
  • $\begingroup$ @ssch well that sucks. I would have thought it could handle any TransformationFunction, otherwise I would not have suggested it. $\endgroup$
    – rcollyer
    Dec 28, 2012 at 3:06

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.