The envelope of a set of translated and rotated ellipses
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.
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
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}]]