The envelope of a set of translated and rotated ellipses

Question

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.

Answer 1

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.

Answer 2

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

Answer 3

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