1
$\begingroup$

I have a custom curve set, that self-intersects, but has a limited value set. As you can see in the attached picture, there is an area in the middle, that remains untouched by the curves. My question would be if anyone knows how I could get Mathematica to calculate the area of the middle area? Also if there was a way to get the area/radius of the greatest inscribable and smallest enclosing circle that would just make my day! Thanks in advance.

CLARIFICATION: The values of "c" I'm trying to make this work for are between 0<c<1. Also when I mean the enter image description heresmallest enclosing circle I'm talking about the shape that remains untouched inside, not the entire curve including the outside self-intersecting bits (I know the entire outer enclosing diameter is 2r+R)

The code and image of the central area I'm trying to find:

pathRot[r_, R_, c_, \[Phi]_, x_, y_] := {Cos[\[Phi]] (r + 
   R + (r) Cos[c \[Phi]]) - (r) Sin[\[Phi]] Sin[c \[Phi]] + 
x, (r + R + (r) Cos[c \[Phi]]) Sin[\[Phi]] + (r) Cos[\[Phi]] Sin[
  c \[Phi]] + y};
Manipulate[
ParametricPlot[
pathRot[r, R, c, \[Phi], x, y], {\[Phi], 0, \[Phi]max}, 
ColorFunction -> (ColorData["Rainbow"][#3] &), 
PlotLegends -> 
BarLegend[{"Rainbow", {0, \[Phi]max}}, 
LegendLabel -> Style[\[Phi], 14]], Frame -> True, 
FrameLabel -> (Tooltip @@@ 
 Transpose[{Style[#, 14] & /@ {"x", "y"}, 
   pathRot[r, R, c, \[Phi], x, y]}]), 
AspectRatio -> True], {{\[Phi]max, 2 Pi}, 2 Pi, 6 Pi, Pi,
Appearance -> "Labeled"}, {{r, 1}, 1, 10, 0.05, 
Appearance -> "Labeled"}, {{R, 1}, 1, 10, 0.05, 
Appearance -> "Labeled"}, {{c, 1}, 1, 100, 0.5, 
Appearance -> "Labeled"},
{{x, 1}, 1, 100, 0.5, Appearance -> "Labeled"},
{{y, 1}, 1, 100, 0.5, Appearance -> "Labeled"},
SynchronousUpdating -> True, 
TrackedSymbols :> {\[Phi]max, r, R, c, x, y}]

enter image description here

$\endgroup$
5
  • $\begingroup$ Welcome to the Mathematica Stack Exchange. Please include Mathematica code that can be copied, pasted and executed in our own notebook sessions. Copy code directly from your input cell, click the Edit button under your post and format as code using the { } icon in the Edit window. Thanks. $\endgroup$
    – Syed
    Nov 25, 2023 at 14:41
  • $\begingroup$ You should remove x and y, they just change the center of the whole curve and needlessly complicate the mathematics. $\endgroup$
    – flinty
    Nov 25, 2023 at 14:56
  • $\begingroup$ In the specific case where the interior forms a spiky hexagon star like shape, such as r=1,R=1/2,c=6, if you somehow knew the ϕ values for the innermost intersections then you could form an integral with an indicator function i.e Boole which is 1 for the ranges of ϕ corresponding to the arcs of the star, and zero elsewhere. I doubt this integral has a nice closed form, and this method does not generalize well at all. $\endgroup$
    – flinty
    Nov 25, 2023 at 15:26
  • $\begingroup$ Oh yeah, I only added x and y to center it off because I tried to export it to another app that had trouble with the axes intersecting in the middle, but it should have no effect on the area really. $\endgroup$ Nov 25, 2023 at 15:26
  • $\begingroup$ If I correctly understand you question, the radius of the greatest inscribed circle can be found as Minimize[{(Cos[\[Phi]] (r + R + (r) Cos[c \[Phi]]) - (r) Sin[\[Phi]] Sin[ c \[Phi]])^2 + ((r + R + (r) Cos[c \[Phi]]) Sin[\[Phi]] + (r) Cos[\[Phi]] Sin[ c \[Phi]])^2, \[Phi] >= 0 && \[Phi] <= 2*Pi && r >= 1 && r <= 10 && R >= 1 && R <= 10 && c >= 1 && c <= 100}, {\[Phi], c, r, R}] which results in {1, {\[Phi] -> (2 \[Pi])/29, c -> 29/2, r -> 1, R -> 1}}. $\endgroup$
    – user64494
    Nov 25, 2023 at 16:10

2 Answers 2

2
$\begingroup$
$Version

(* "13.3.1 for Mac OS X ARM (64-bit) (July 24, 2023)" *)

Clear["Global`*"]

pathRot[r_, R_, c_, ϕ_, x_, 
   y_] := {Cos[ϕ] (r + R + r Cos[c ϕ]) - 
    r Sin[ϕ] Sin[
      c ϕ], (r + R + r Cos[c ϕ]) Sin[ϕ] + 
    r Cos[ϕ] Sin[c ϕ]};

EDIT: Added Normal after plt in definition of allPts so that Mathematica versions that generate a GraphicsComplex for plt will execute properly.

Manipulate[
 Module[
  {plt, center, inr, innerCircle, outr, outerCircle, ϕmax, c},
  c = Rationalize[cv];
  ϕmax = Denominator[c]*2 Pi;
  (* ϕmax is set to close the curve without overlap *)
  plt = ParametricPlot[
    pathRot[r, R, c, ϕ, x, y], {ϕ, 0, ϕmax},
    ColorFunction -> (ColorData["Rainbow"][#3] &),
    PlotLegends -> Placed[
      BarLegend[{"Rainbow", {0, ϕmax}},
       LegendLabel -> Style[ϕ, 14],
       LegendMarkerSize -> {380, 15},
       LegendLayout -> "Row"],
      Below],
    Axes -> axes,
    Frame -> True,
    FrameLabel -> (Tooltip @@@
       Transpose[{Style[#, 14] & /@ {"x", "y"},
         pathRot[r, R, c, ϕ, x, y]}]),
    AspectRatio -> True];
  allPts = Flatten[Cases[plt//Normal, Line[pts_] :> pts, Infinity], 1];
  center = {0, 0};
  innerCircle = Circle[center,
    inr = Min[EuclideanDistance[center, #] & /@ allPts]];
  inLbl = StringForm["inner circle\nradius = ``\n" <>
     "area = ``", NumberForm[inr, {5, 3}], 
    NumberForm[Pi*inr^2, {5, 3}]];
  outerCircle = Circle[center,
    outr = Max[EuclideanDistance[center, #] & /@ allPts]];
  outLbl = StringForm["outer circle\nradius = ``\n" <>
     "area = ``", NumberForm[outr, {5, 3}], 
    NumberForm[Pi*outr^2, {5, 3}]];
  Legended[
   Show[{plt,
     If[inner, Graphics[{Magenta, Dashed, innerCircle}], Nothing],
     If[outer, 
      Graphics[{Gray, AbsoluteThickness[2], Dashed, outerCircle}], 
      Nothing]},
    PlotRange -> All],
   If[inner && outer, 
    LineLegend[{Directive[Magenta, Dashed], 
      Directive[Gray, AbsoluteThickness[2], Dashed]},
     {inLbl, outLbl}],
    If[inner,
     LineLegend[{Directive[Magenta, Dashed]}, {inLbl}],
     If[outer,
      LineLegend[{Directive[Gray, AbsoluteThickness[2], 
         Dashed]}, {outLbl}], {}]]]]],
 {{cv, 1.25, "c"}, 1.25, 100, 0.25, Appearance -> "Labeled"},
 {{r, 1}, 1, 10, 0.05, Appearance -> "Labeled"},
 {{R, 1}, 1, 10, 0.05, Appearance -> "Labeled"},
 Delimiter,
 Row[{
   Control[{{axes, False}, {True, False}}],
   Spacer[50],
   Control[{{inner, True, "inner circle"}, {True, False}}],
   Spacer[50],
   Control[{{outer, True, "outer circle"}, {True, False}}]}],
 SynchronousUpdating -> False,
 TrackedSymbols :> {cv, r, R, axes, inner, outer}]

enter image description here

$\endgroup$
6
  • $\begingroup$ This looks great, but when I try to run your code on my machine I get "Radius DirectedInfinity[-1] should be a positive number or pair of positive numbers, or a Scaled or Offset form." Any idea? $\endgroup$ Nov 26, 2023 at 11:39
  • $\begingroup$ I copied the above code into a notebook and it evaluated without any problems. Did you try restarting Mathematica? What Mathematica version are you using? What OS are you on? Did you get any output other than the error message? If so, what? $\endgroup$
    – Bob Hanlon
    Nov 26, 2023 at 15:09
  • $\begingroup$ The code works to me in 13.3.1 on Windows 10. $\endgroup$
    – user64494
    Nov 26, 2023 at 15:14
  • $\begingroup$ I'm running 13.2.1 on MacOS Catalina. I get the original curve, but not the inscribable/encompassing circles. It also says the radius and areas of the circles are infinite. $\endgroup$ Nov 26, 2023 at 15:53
  • $\begingroup$ See edit. Should now work with your version. $\endgroup$
    – Bob Hanlon
    Nov 26, 2023 at 16:16
3
$\begingroup$

Create a ParametricRegion

reg[r_, R_, c_, \[Phi]max_ ] = 
ParametricRegion[{Cos[\[Phi]] (r +R + (r) Cos[c \[Phi]]) - (r) Sin[\[Phi]] Sin[c \[Phi]] , (r +  R + (r) Cos[c \[Phi]]) Sin[\[Phi]] + (r) Cos[\[Phi]] Sin[c \[Phi]] }
, {{\[Phi], 0, \[Phi]max}}];



With[{r = 1, R = Pi, c = 7, \[Phi]max = 3 Pi}, 
mini = NMinimize[x . x, x \[Element] reg[r, R, c, \[Phi]max]];
maxi = NMaximize[x . x, x \[Element] reg[r, R, c, \[Phi]max] ];
Show[Region[reg[r, R, c, \[Phi]max ]], 
Graphics[{Circle[{0, 0}, Sqrt[mini[[1]]]],Circle[{0, 0},Sqrt[maxi[[1]]]]}]]
]

enter image description here

$\endgroup$

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.