Circumscribing a Quartic Curve

Ideas
,
1

Suppose I want to find the smallest circle, centered at the origin, which circumscribes a Piriform curve
( Piriform Curve -- from Wolfram MathWorld ),
defined by piri[ { x, y} ] == 0 where

piri[{x_, y_}] = x^3 (2 - x) - y^2;

by shifting the curve’s center along the x-axis. This involves minimizing the maximum distance from the origin to the shifted curve. The maximum distance as a function of the shift can be calculated as follows:

f[x0_] = 
 MaxValue[{Sqrt[x^2 + y^2], piri[{x - x0, y}] == 0}, {x, y}];

The result is a Piecewise function containing Root functions and cannot be analytically minimized, but is equal to -x0 for x0 <= 1/27 (-17 - 7 Sqrt[7]) and larger values for x0 greater than that value, as shown in the following plot

Plot[f[x0], {x0, -2, 0}]

piriform.jpg
piriform.jpg360×235 5.6 KB

Therefore the minimization is obtained at that value (approximately -1.3)

The result can be visualized as

Show[ContourPlot[
  piri[{x - 1/27 (-17 - 7 Sqrt[7]), y}] == 0, {x, -2.5, 
   2.5}, {y, -2.5, 2.5}], 
 Graphics @ Circle[{0, 0}, 1/27 (-17 - 7 Sqrt[7])]]

piriform1.jpg
piriform1.jpg360×360 9.4 KB

2

State e.g.

In[120]:= Clear[\[ScriptCapitalR]]
With[{a = 2, b = 3},
 \[ScriptCapitalR] = ImplicitRegion[ a^4  y^2 - b^2 x^3 (2 a - x) < 0, {x, y}]
 ]
Out[121]= ImplicitRegion[-9 (4 - x) x^3 + 16 y^2 < 0, {x, y}]

and give it to FindRoot

In[162]:= FindRoot[Area[RegionIntersection[\[ScriptCapitalR], Disk[{x, 0}, x]]] - Area[\[ScriptCapitalR]], {x, 1, 0, 6}]
During evaluation of In[162]:= Area::nmet: Unable to compute the area of region RegionIntersection[Disk[{x,0},x],ImplicitRegion[-9 (4-x) x^3+16 y^2<0,{x,y}]]. >>
During evaluation of In[162]:= FindRoot::jsing: Encountered a singular Jacobian at the point {x} = {4.05281}. Try perturbing the initial point(s). >>
Out[162]= {x -> 4.05281}

In[163]:= RegionPlot[{\[ScriptCapitalR], Disk[{x, 0}, x] /. %} ]

the function is not ideal for FindRoot because it becomes constant zero for x equal to or greater than the searched x and FindRoot complains about that, nevertheless

comm581638.PNG
comm581638.PNG754×517 21.9 KB

1 Like
3

That’s an interesting approach. I’ve been trying to define a constraint for ellipse packing that prevents their overlap, but it didn’t occur to me to use the area of the region intersection.

4

Another approach; define

    In[85]:= Clear[\[ScriptCapitalR]]
     With[{a = 2, b = 3},
       \[ScriptCapitalR] = ImplicitRegion[ a^4  y^2 - b^2 x^3 (2 a - x) < 0, {x, y}]
     ]
    Out[86]= ImplicitRegion[-9 (4 - x) x^3 + 16 y^2 < 0, {x, y}]
    
    In[77]:= Clear[f]
    f[a_?NumericQ, b_?NumericQ, z_?NumericQ] := Length[
       FindInstance[a^4  y^2 - b^2 x^3 (2 a - x) == 0 && (x - z)^2 + y^2 - z^2 == 0, {x, y}, Reals, 8]
     ] /; UnsameQ[x, z] && UnsameQ[y, z]

and plot

RegionPlot[{\[ScriptCapitalR], Disk[{x, 0}, x] /. x -> NIntegrate[Boole[f[2, 3, z] > 1], {z, 0, 5}]}]

comm581638_2.PNG
comm581638_2.PNG685×461 18.3 KB

No error messages anymore, but one has to choose two constants: an upper bound for the intersections and an upper bound for the numerical integration which has the only purpose to find out the jumping point from 5 intersections through 3 into 1 intersection.