Mathematica：多项式实根的分支点

Question

我正在对以下示例函数

中的“渐变极值”进行强力搜索

fv[{x_, y_}] = ((y - (x/4)^2)^2 + 1/(4 (1 + (x - 1)^2)))/2;

这涉及找到以下零

gecond = With[{g = D[fv[{x, y}], {{x, y}}], h = D[fv[{x, y}], {{x, y}, 2}]},
 g.RotationMatrix[Pi/2].h.g == 0]

Reduce对我来说很开心：

geyvals = y /. Cases[List@ToRules@Reduce[gecond, {x, y}], {y -> _}];

geyvals是三次多项式的三个根，但表达式有点大。

现在我的问题：对于x的不同值，这些根的不同数量是真实的，我想挑选解决方案分支的x的值，以便拼凑起来沿谷底的梯度极值（fv）。在目前的情况下，由于多项式只是立方体，我可以手工完成 - 但我正在寻找一种让Mathematica为我做的简单方法吗？

编辑：澄清：渐变极值只是背景 - 而且是设置难题的简单方法。我对这个问题的具体解决方案不是那么感兴趣，因为在一般的切换方式中找到多项式根的分支点。在下面添加了一个工作方法的答案。

编辑2 ：由于看起来实际问题比根分支更有趣：rcollyer建议直接在ContourPlot上使用gecond来获取渐变极值。为了完成这一点，我们需要分离山谷和山脊，这是通过观察垂直于梯度的Hessian的特征值来完成的。将“valleynes”作为RegionFunction进行检查，我们只剩下谷线：

valleycond = With[{
    g = D[fv[{x, y}], {{x, y}}], 
    h = D[fv[{x, y}], {{x, y}, 2}]},
  g.RotationMatrix[Pi/2].h.RotationMatrix[-Pi/2].g >= 0];
gbuf["gevalley"]=ContourPlot[gecond // Evaluate, {x, -2, 4}, {y, -.5, 1.2},
   RegionFunction -> Function[{x, y}, Evaluate@valleycond], 
   PlotPoints -> 41];

这给出了谷底线。包括一些轮廓和鞍点：

fvSaddlept = {x, y} /. First@Solve[Thread[D[fv[{x, y}], {{x, y}}] == {0, 0}]]
gbuf["contours"] = ContourPlot[fv[{x, y}],
   {x, -2, 4}, {y, -.7, 1.5}, PlotRange -> {0, 1/2},
   Contours -> fv@fvSaddlept (Range[6]/3 - .01),
   PlotPoints -> 41, AspectRatio -> Automatic, ContourShading -> None];
gbuf["saddle"] = Graphics[{Red, Point[fvSaddlept]}];
Show[gbuf /@ {"contours", "saddle", "gevalley"}]

我们最终得到了这样的情节：

Answer 1

不确定这个（迟来的）是否有帮助，但似乎你对判别点感兴趣，也就是说，多项式和导数（wrt y）都消失了。您可以为{x，y}解决此系统，并丢弃复杂的解决方案，如下所示。

fv[{x_, y_}] = ((y - (x/4)^2)^2 + 1/(4 (1 + (x - 1)^2)))/2;

gecond = With[{g = D[fv[{x, y}], {{x, y}}], 
   h = D[fv[{x, y}], {{x, y}, 2}]}, g.RotationMatrix[Pi/2].h.g]

In[14]:= Cases[{x, y} /. 
  NSolve[{gecond, D[gecond, y]} == 0, {x, y}], {_Real, _Real}]

Out[14]= {{-0.0158768, -15.2464}, {1.05635, -0.963629}, {1., 
  0.0625}, {1., 0.0625}}

Answer 2

如果您只想绘制结果，请在渐变上使用StreamPlot[]：

grad = D[fv[{x, y}], {{x, y}}];
StreamPlot[grad, {x, -5, 5}, {y, -5, 5}, 
           RegionFunction -> Function[{x, y}, fv[{x, y}] < 1],
           StreamScale -> 1]

您可能不得不使用绘图的精度，StreamStyle和RegionFunction来完善它。特别有用的是使用谷底解决方案以编程方式种子StreamPoints。

Answer 3

已更新：见下文。

我首先通过可视化根部的虚部来解决这个问题：

这会立即告诉你三件事：1）第一根总是真实的，2）第二根是共轭对，3）有一个接近于零的小区域，其中所有三个都是真实的。另外，请注意，排除项只会消除x=0处的奇异点，我们可以看到放大时的原因：

然后我们可以使用EvalutionMonitor直接生成根列表：

Map[Module[{f, fcn = #1}, 
            f[x_] := Im[fcn];
            Reap[Plot[f[x], {x, 0, 1.5}, 
                  Exclusions -> {True, f[x] == 1, f[x] == -1}, 
                  EvaluationMonitor :> Sow[{x, f[x]}][[2, 1]] // 
            SortBy[#, First] &];]
   ]&, geyvals]

（注意，Part规范有点奇怪，Reap会返回List中第二项所播种的List，因此会导致一个嵌套列表。另外，Plot不会以简单的方式对点进行采样，因此需要SortBy。）可能有一个更优雅的路径来确定最后两个根变得复杂的位置，但是因为它们的虚部是分段连续的，所以它似乎更容易暴力。

编辑：既然您已经提到过想要一个自动方法来生成某些根变得复杂的地方，那么我一直在探索在y -> p + I q中替换时会发生什么。现在假设x是真实的，但您已经在解决方案中做到了这一点。具体来说，我做了以下

In[1] := poly = g.RotationMatrix[Pi/2].h.g /. {y -> p + I q} // ComplexExpand;
In[2] := {pr,pi} = poly /. Complex[a_, b_] :> a + z b & // CoefficientList[#, z] & //
         Simplify[#, {x, p, q} \[Element] Reals]&;

其中第二步允许我隔离等式的实部和虚部并将它们彼此独立地简化。使用通用二维多项式f + d x + a x^2 + e y + 2 c x y + b y^2做同样的事情，但同时使x和y复杂化;我注意到Im[poly] = Im[x] D[poly, Im[x]] + Im[y] D[poly,[y]]，这也适用于你的等式。通过使x成为真实，poly的虚部变为q次x，p和q的某些函数。因此，设置q=0始终会Im[poly] == 0。但是，这并没有告诉我们任何新的东西。但是，如果我们

In[3] := qvals = Cases[List@ToRules@RReduce[ pi == 0 && q != 0, {x,p,q}], 
          {q -> a_}:> a];

我们为q提供了几个涉及x和p的公式。对于x和p的某些值，这些公式可能是虚数，我们可以使用Reduce来确定Re[qvals] == 0的位置。换句话说，我们希望y的“虚构”部分是真实的，这可以通过允许q为零或纯虚构来实现。绘制Re[q]==0区域并通过

覆盖梯度极值线

With[{rngs = Sequence[{x,-2,2},{y,-10,10}]},
Show@{
 RegionPlot[Evaluate[Thread[Re[qvals]==0]/.p-> y], rngs],
 ContourPlot[g.RotationMatrix[Pi/2].h.g==0,rngs 
      ContourStyle -> {Darker@Red,Dashed}]}]

给出

确认了前两个图中显示3个真实根的区域。

Answer 4

结束了尝试自己，因为目标确实要做到'放手'。我会暂时搁置这个问题，看看是否有人找到了更好的方法。

下面的代码使用二分法来括住CountRoots更改值的点。这适用于我的情况（在x = 0时发现奇点是纯粹的运气）：

In[214]:= findRootBranches[Function[x, Evaluate@geyvals[[1, 1]]], {-5, 5}]
Out[214]= {{{-5., -0.0158768}, 1}, {{-0.0158768, -5.96046*10^-9}, 3}, {{0., 0.}, 2}, {{5.96046*10^-9, 1.05635}, 3}, {{1.05635, 5.}, 1}}

实现：

Options[findRootBranches] = {
   AccuracyGoal -> $MachinePrecision/2,
   "SamplePoints" -> 100};

findRootBranches::usage = 
  "findRootBranches[f,{x0,x1}]: Find the the points in [x0,x1] \
  where the number of real roots of a polynomial changes.
  Returns list of {<interval>,<root count>} pairs.
  f: Real -> Polynomial as pure function, e.g f=Function[x,#^2-x&]." ; 

findRootBranches[f_, {xa_, xb_}, OptionsPattern[]] := Module[
  {bisect, y, rootCount, acc = 10^-OptionValue[AccuracyGoal]},
  rootCount[x_] := {x, CountRoots[f[x][y], y]};

  (* Define a ecursive bisector w/ automatic subdivision *)
  bisect[{{x1_, n1_}, {x2_, n2_}} /; Abs[x1 - x2] > acc] := 
   Module[{x3, n3},
    {x3, n3} = rootCount[(x1 + x2)/2];
    Which[
     n1 == n3, bisect[{{x3, n3}, {x2, n2}}],
     n2 == n3, bisect[{{x1, n1}, {x3, n3}}],
     True, {bisect[{{x1, n1}, {x3, n3}}], 
      bisect[{{x3, n3}, {x2, n2}}]}]];

  (* Find initial brackets and bisect *)
  Module[{xn, samplepoints, brackets},
   samplepoints = N@With[{sp = OptionValue["SamplePoints"]},
      If[NumberQ[sp], xa + (xb - xa) Range[0, sp]/sp, Union[{xa, xb}, sp]]];
   (* Start by counting roots at initial sample points *)
   xn = rootCount /@ samplepoints;
   (* Then, identify and refine the brackets *)
   brackets = Flatten[bisect /@ 
      Cases[Partition[xn, 2, 1], {{_, a_}, {_, b_}} /; a != b]];
   (* Reinclude the endpoints and partition into same-rootcount segments: *)
   With[{allpts = Join[{First@xn}, 
       Flatten[brackets /. bisect -> List, 2], {Last@xn}]},
    {#1, Last[#2]} & @@@ Transpose /@ Partition[allpts, 2]
    ]]]