使用 Manipulate 控制测量零组解决方案。案例研究

Question

为了解决这个问题，我们从以下玩具模型问题开始，这里只是一个案例研究：

给定平面上的两个圆（其中心（c1 和 c2）和半径（r1 和 r2））以及一个正数 r3，找到所有半径 = r3 的圆（即所有点 c3 都是中心半径 = r3) 与给定两个圆相切（外部和内部）的圆。

一般来说，取决于Circle[c1,r1], Circle[c2,r2] and r3，有 0,1,2,...8 种可能的解决方案。典型案例有8个解决方案：

我稍微修改了 Jaime Rangel-Mondragon 在Wolfram Demonstration Project 上的一个简洁的 Mathematica 实现，但它的核心是相似的：

Manipulate[{c1, a, c2, b} = pts;
           {r1, r2} = Map[Norm, {a - c1, b - c2}];

            w = Table[
                       Solve[{radius[{x, y} - c1]^2 == (r + k r1)^2, 
                              radius[{x, y} - c2]^2 == (r + l r2)^2}
                            ] // Quiet, 
                       {k, -1, 1, 2}, {l, -1, 1, 2}
                    ];
            w = Select[
                       Cases[Flatten[{{x, y}, r} /. w, 2],
                             {{_Real, _Real}, _Real}
                            ], 
                       Last[#] > 0 &
                     ];
           Graphics[
                    {{Opacity[0.35], EdgeForm[Thin], Gray,
                                                      Disk[c1, r1], Disk[c2, r2]},      
                     {EdgeForm[Thick], Darker[Blue,.5],
                                                   Circle[First[#], Last[#]]& /@ w}
                    },
                       PlotRange -> 8, ImageSize -> {915, 915}
                   ],
           "None" -> {{pts, {{-3, 0}, {1, 0}, {3, 0}, {7, 0}}},
                      {-8, -8}, {8, 8}, Locator}, 
           {{r, 0.3, "r3"}, 0, 8}, 
           TrackedSymbols -> True,
           Initialization :> (radius[z_] := Sqrt[z.z])
         ]

我们可以很容易地得出结论，在一般情况下，我们有偶数个解决方案 0,2,4,6,8，而具有奇数个解决方案 1,3,5,7 的情况是例外的 - 它们为零在控制范围方面进行测量。因此，Manipulatec1, r1, c2, r2, r3 的变化可以观察到，跟踪具有奇数个圆圈的案例要困难得多。

可以在基本层面上修改上述方法：求解 c3 的纯符号方程以及重新设计 Manipulate 结构，重点是改变解的数量。如果我没记错的话Solve 只能在数字上与Manipulate 中的Locator 一起工作，但是这里Locator 似乎对于控制c1, r1, c2, r2 以及整个实现的简单性至关重要。
让我们陈述问题，：

1.我们如何强制 Manipulate 无缝跟踪具有奇数个解决方案（圆圈）的案例？

2。有没有办法让Solve 找到底层方程的精确解？

（我发现 Daniel Lichtblau 的答案是解决问题 2 的最佳方法，但在这种情况下，似乎仍然有必要绘制一种强调测量零组解决方案的一般技术，同时使用 Manipulate )

在处理精确解决方案时，这些考虑因素不太重要

例如 Solve[x^2 - 3 == 0, x] 产生 {{x -> -Sqrt[3]}, {x -> Sqrt[3]}} 而从上面的情况下，从Manipulate 中提取的稍微困难的方程设置以下参数：

 c1 = {-Sqrt[3], 0};  a = {1, 0};  c2 = {6 - Sqrt[3], 0};  b = {7, 0};     
 {r1, r2} = Map[ Norm, {a - c1, b - c2 }];  
  r = 2.0 - Sqrt[3];

到：

w = Table[Solve[{radius[{x, y} - {x1, y1}]^2 == (r + k r1)^2, 
                 radius[{x, y} - {x2, y2}]^2 == (r + l r2)^2}],
          {k, -1, 1, 2}, {l, -1, 1, 2}];

w = Select[ Cases[ Flatten[ {{x, y}, r} /. w, 2], {{_Real, _Real}, _Real}],    
            Last[#] > 0 &]

我们有两个解决方案：

{{{1.26795, -3.38871*10^-8}, 0.267949}, {{1.26795, 3.38871*10^-8}, 0.267949}}

类似地在相同的参数和方程下，放置：

r = 2 - Sqrt[3]; 

我们没有解决方案： {}

但实际上我们要强调的解决方案只有一个：

{ {3 -  Sqrt[3], 0 }, 2 -  Sqrt[3] }

事实上，传递给Graphics 两种不同解决方案和唯一的解决方案之间如此小的差异是无法区分的，但是使用Manipulate 时，我们无法以期望的精度仔细跟踪两个圆的合并，通常是最后观察到的配置在消除所有解决方案之前降低r3（提醒所谓的结构不稳定性）看起来像这样：

Manipulate 是一个相当强大的工具，不仅仅是一个玩具，掌握它可能会非常有用。在严肃的研究中出现的考虑问题往往是至关重要的，例如：研究非线性微分方程的解、解中奇异性的出现、动力系统的定性行为、分岔、突变理论中的现象等等。

Answer 1

由于这是一个零度量集，因此需要一定粒度的工具通常会在这个概念上遇到问题。也许更好的是明确地寻找奇点轨迹，其中解决方案具有多重性或以其他方式偏离附近的解决方案行为。它将成为判别式的一部分。特别是，您可以通过将定义多项式设置为零并同时使雅可比行列式为零来获取相关部分。

这是您的示例。我最终会（wlog）将一个中心放在原点，另一个放在（1,0）。

centers = Array[c, {2, 2}];
radii = Array[r, 3];
circ[cen_, rad_, x_, y_] := ({x, y} - cen).({x, y} - cen) - rad^2

我会将你的“k”用于两个多项式。您的公式有对 (k,l)，其中每个都是 +-1。我们可以只使用 k，通过平方排列得到 k^2 中的多项式，并将其替换为 1。

 polys = 
 Table[Expand[
   circ[centers[[j]], radii[[3]] + k*radii[[j]], x, y]], {j, 2}]

Out[18]= {x^2 + y^2 - 2 x c[1, 1] + c[1, 1]^2 - 2 y c[1, 2] + 
  c[1, 2]^2 - k^2 r[1]^2 - 2 k r[1] r[3] - r[3]^2, 
 x^2 + y^2 - 2 x c[2, 1] + c[2, 1]^2 - 2 y c[2, 2] + c[2, 2]^2 - 
  k^2 r[2]^2 - 2 k r[2] r[3] - r[3]^2}

我们将删除 k 中的线性部分，将其余部分平方，将删除的部分平方，然后将两者等同起来。然后我们还将 k 替换为 unity。

p2 = polys - k*Coefficient[polys, k];
polys2 = Expand[p2^2 - (k*Coefficient[polys, k])^2] /. k -> 1;

我们现在得到雅可比行列式并将其添加到 brew 中。

discrim = Det[D[polys2, #] & /@ {x, y}];

allrelations = Join[polys2, {discrim}];

现在像前面提到的那样设置中心（可以从一开始就这样做，有人会假设）。

ar2 = 
 allrelations /. {c[1, 1] -> 0, c[1, 2] -> 0, c[2, 1] -> 0, 
   c[2, 2] -> 0}

Out[38]= {x^4 + 2 x^2 y^2 + y^4 - 2 x^2 r[1]^2 - 2 y^2 r[1]^2 + 
  r[1]^4 - 2 x^2 r[3]^2 - 2 y^2 r[3]^2 - 2 r[1]^2 r[3]^2 + r[3]^4, 
 x^4 + 2 x^2 y^2 + y^4 - 2 x^2 r[2]^2 - 2 y^2 r[2]^2 + r[2]^4 - 
  2 x^2 r[3]^2 - 2 y^2 r[3]^2 - 2 r[2]^2 r[3]^2 + r[3]^4, 0}

我们现在消除 x 和 y 以获得 r[1],r[2],r[3] 参数空间中的轨迹，该轨迹决定了我们在解决方案中的多重性。

 gb = GroebnerBasis[ar2, radii, {x, y}, 
   MonomialOrder -> EliminationOrder]

{r[1]^6 - 3 r[1]^4 r[2]^2 + 3 r[1]^2 r[2]^4 - r[2]^6 - 
   8 r[1]^4 r[3]^2 + 8 r[2]^4 r[3]^2 + 16 r[1]^2 r[3]^4 - 
   16 r[2]^2 r[3]^4}

如果我做的这一切都是正确的，那么我们现在有多项式定义参数空间中的轨迹，解决方案集可能会变得愚蠢。在这个集合之外，它们永远不应该有多重性，并且实际计数应该始终是偶数。该集合与真实空间的交集将是半径参数的 3d 空间中的 2d 表面。它将具有 0、2、4、6 或 8 个实解的区域彼此分开。

最后，我要指出，在这个例子中，所讨论的多样性很好地减少为平面的产品。我想从几何的角度来看，这并不奇怪。

Factor[gb[[1]]]

Out[43]= (r[1] - r[2]) (r[1] + r[2]) (r[1] - r[2] - 2 r[3]) (r[1] + 
   r[2] - 2 r[3]) (r[1] - r[2] + 2 r[3]) (r[1] + r[2] + 2 r[3])