# The envelope of a set of translated and rotated ellipses

I achieve a dynamic graphics by using Manipulate as follows:

Manipulate[
ParametricPlot[
RotationMatrix[β].{a + c Cos[Θ], b + d Sin[Θ]}, {Θ, 0, 2 π},
PlotRange -> {{-15, 15}, {-15, 15}}],
{{a, 1}, 0, 5, 1, Appearance -> "Labeled"},
{b, 0, 6, 1}, {c, 1, 5, 1},
{d, 2, 6, 1}, {β, 0, π, 1}]


To see the dynamic region, I do the following operation:

Table[
ParametricPlot[
RotationMatrix[β].{a + c Cos[Θ], b + d Sin[Θ]}, {Θ, 0, 2 π},
PlotRange -> {{-15, 15}, {-15, 15}}],
{a, 0, 5, 1},
{b, 0, 6, 1}, {c, 1, 5, 1},
{d, 2, 6, 1}, {β, 0, π, 1}]// Flatten // Show


In addition, I noticed that

ParametricPlot[
r^2 { Sqrt[t] Cos[t], Sin[t]}, {t, 0, 3 π/2}, {r, 1, 2}]


can give a region of a dynamic graphic. However, it cannot work when the parameters exceed 2

### Question

Is it possible to achieve the envelope line of a set of dynamic graphs ? It is my first time to think out this question and I have no idea.

• You have an envelope of parametrically-defined curves; as noted here or here (en Français, sorry), you can derive the envelope's parametric equations by eliminating the free parameter from the parametric equations and the determinant of its partial derivatives. – J. M. will be back soon May 16 '15 at 6:41
• @Guesswhoitis. Thanks for your reference:-) – xyz May 16 '15 at 13:59
• @Guesswhoitis. The problem, as I see it, is that the free parameters are discrete. If they were continuous, the bounding curve would be simply a circle. – bbgodfrey May 16 '15 at 14:37
• @bbgodfrey, true; that makes computing an explicit representation of the envelope harder. – J. M. will be back soon May 16 '15 at 14:43

This problem can be simplified substantially by noting that only the largest ellipses contribute to the boundary of the second figure in the question. So, for instance,

Table[ParametricPlot[RotationMatrix[β].{a + 5 Cos[Θ], b + 6 Sin[Θ]}, {Θ, 0, 2 Pi},
PlotRange -> {{-15, 15}, {-15, 15}}], {a, 0, 5, 1}, {b, 1, 6, 1}, {β, 0, Pi, 1}]
// Flatten // Show


Furthermore, this plot is seen to be the composite of four objects,

Table[ParametricPlot[{a + 5 Cos[Θ], b + 6 Sin[Θ]}, {Θ, 0, 2 Pi},
PlotRange -> {{-15, 15}, {-15, 15}}], {a, -2.5, 2.5, 1}, {b, -2.5, 2.5, 1}]
// Flatten // Show


each one displaced by the average values of a and b, {2.5, 3.0} in this case, and rotated by the four values of β.

Continuation

The region corresponding to the previous plot is approximately (exactly in the limit of continuous a and b) is

r = RegionUnion[Flatten[{
Table[Ellipsoid[{a, b}, {5, 6}], {a, -2.5, 2.5, 5}, {b, -2.5, 2.5, 5}],
Rectangle[{-2.5, -8.5}, {2.5, 8.5}], Rectangle[{-7.5, -2.5}, {7.5, 2.5}]}]];
RegionPlot[r, PlotRange -> {{-15, 15}, {-15, 15}}]


This region then is translated by {2.5, 3.0} and rotated by β.

t = TransformedRegion[r, TranslationTransform[{2.5, 3}]];
s = RegionUnion[Table[TransformedRegion[t, RotationTransform[β]], {β, 0, Pi, 1}]];


The boundary of s is the desired surface.

u = RegionBoundary[s];
RegionPlot[u, PlotRange -> {{-15, 15}, {-15, 15}}]
DeleteCases[%, Line[{_, _}] | Point[__], Infinity]


The last line of code eliminates most spurious points and point-like lines that mysteriously (to me) otherwise appear.

Warning: Trying to plot s itself promptly devoured all the memory on my PC.

• This is very elegant. I had been thinking about this problem since the question came out, but I had gotten nowhere. Thanks for putting me out of my misery! (+1) – MarcoB May 16 '15 at 22:11

The general idea is the same as bbgodfrey's so most credits for him, the approach is slightly different, perhaps more automatic.

We start by converting OP's parametric expression to cartesian:

eq = #.# &@{Cos[Θ], Sin[Θ]} /. Solve[
Thread[{x, y} == RotationMatrix[β].{a + c Cos[Θ], b + d Sin[Θ]}],
{Cos[Θ], Sin[Θ]}
][[1]] // Simplify


(regions = Table[
ImplicitRegion[eq <= 1, {x, y}],
{a, 0, 5, 1}, {b, 0, 6, 1}, {c, 5, 5, 1}, {d, 6, 6, 1}, {β, 0, π, 1}
] // Flatten // N);
(*only the biggest c and d as noticed by bbdogfrey*)

RegionUnion[regions] // DiscretizeRegion[#, AccuracyGoal -> 3] & //
RegionBoundary // AbsoluteTiming


• Kuba, elegant solution. Well done. Do you understand why using DiscretizeRegion[#]] & // RegionBoundary  decreases running time by orders of magnitude, compared to RegionBoundary // RegionPlot? – bbgodfrey May 17 '15 at 0:42
• Shutao Tang, although I cannot speak for Kuba, I would note that DiscretizeRegion is new to Mathematica 10. – bbgodfrey May 17 '15 at 0:44
• @bbgodfrey I don't know, I'm not so much experienced in Regions. :/ – Kuba May 17 '15 at 6:45
• @ShutaoTang Yes, this is V10 solution. You could try to mimic this. Plot filled ellipses, extract polygons, find here a function to merge polygons (it is somewhere, I don't know where). Fold this operation on a list of ellipses and you have a solution. Probably, haven;t tested it and don't have time :/ – Kuba May 17 '15 at 6:47
• @Kuba, Thanks very much sincerely:-) – xyz May 17 '15 at 6:51

Here is an approach came from this answer and bbgodfrey's answer. In addition, it is very fast.

s =
DiscretizeGraphics@
Graphics[Polygon /@
Table[Table[{a + 5 Cos[theta], b + 6 Sin[theta]},
{theta, 0, 2 Pi, 0.02 Pi}], {a, -2.5, 2.5, 1}, {b, -2.5, 2.5, 1}]]


t = TransformedRegion[s, TranslationTransform[{2.5, 3}]];
RegionBoundary@
RegionUnion[
Table[TransformedRegion[t, RotationTransform[beta]], {beta, 0, Pi, 1}]]