用Manipulate控制测量零套解决方案。案例研究 [英] Controlling measure zero sets of solutions with Manipulate. A case study

查看：138
本文介绍了用Manipulate控制测量零套解决方案。案例研究的处理方法，对大家解决问题具有一定的参考价值，需要的朋友们下面随着小编来一起学习吧！

问题描述

为了解决这个问题，我们从下面的玩具模型问题开始，这里只是一个案例研究：假设在飞机上有两个圆圈（其中心（ c1和c2）和半径（r1和r2））以及正数r3，找出半径为r3的所有圆（即所有点c3均为半径为r3的圆的中心）切线（外部和内部）圆。



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



我稍微修改了Jaime Rangel-Mondragon在 Wolfram Demonstration Project ，但它的核心是类似的：

 操作[{c1，a，c2，b} = pts; 
 {r1，r2} = Map [Norm，{a  -  c1，b  -  c2}]; 
 
w = [
 Solve [{radius [{x，y}  -  c1] ^ 2 ==（r + k r1）^ 2，
 radius [{x， y} -c2] ^ 2 ==（r + l r2）^ 2} 
] //安静，
 {k，-1,1,2}，{l，-1,1， 2} 
]; 
 w =选择[
 Cases [Flatten [{{x，y}，r} /）。 w，2]，
 {{_Real，_Real}，_Real} 
]，
 Last [＃]> 0& 
]; 
 [
 {{Opacity [0.35]，EdgeForm [Thin]，Gray，
 Disk [c1，r1]，Disk [c2，r2]}，
 {EdgeForm [厚]，深色[蓝色，.5]，
圈[[第一[＃]，最后[＃]]& / @ w} 
}，
 PlotRange  - > 8，ImageSize  - > {915，915} 
]，
无 - > {{pts，{{-3,0}，{1,0}，{3,0}，{7,0}}}，
 {-8，-8}，{8,8}， Locator}，
 {{r，0.3，r3}，0，8}，
 TrackedSymbols  - >真，
初始化：> （半径[z_]：= Sqrt [zz]）
]

在一般情况下，我们有偶数个解0,2,4,6,8，而奇数解1,3,5,7的情况例外 - 它们在控制范围方面为零。因此，改变 Manipulate c1，r1，c2，r2，r3 可以发现跟踪更加困难有奇数圈的情况。

可以在基本层面修改上述方法：为c3纯粹象征性地求解方程，并重新设计 Manipulate 结构，强调改变解决方案的数量。如果我没有错， Solve 只能用 Locator 在 Manipulate ，但是这里 Locator 似乎对控制 c1，r1，c2，r2 的简单性至关重要以及整个实现。

让我们来陈述这些问题：

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

2。是否有任何方法可以使 Solve 找到基础方程的精确解？

（我发现Daniel Lichtblau的答案是问题2的最佳方法，但在这种情况下，似乎仍然存在一个基本需求，即在使用Manipulate时强调测量零套解决方案的一般技术） / strong>



在处理确切的解决方案时，这些考虑因素并不重要

例如解决[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 =表[Solve [{radius [{x，y}  -  {x1，y1}] ^ 2 ==（r + k r1）^ 2，
半径[{x，y}  -  {x2，y2}] ^ 2 ==（r + l r2）^ 2}]，
 {k，-1,1,2}，{ 1，2}]; 
 
 w =选择[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 是一个强大的工具，不仅是一个玩具，它的掌握可能非常有用。在认真研究中出现的问题经常是至关重要的，例如：研究非线性微分方程的解，其解中奇异性的出现，动态系统的定性行为，分岔，突变理论中的现象等等。 
解决方案
由于这是一个度量零集合，因此需要一定粒度的工具通常会遇到问题。也许更好的办法是明确地寻找奇点轨迹，其中解决方案具有多重性或以其他方式偏离附近的解决方案行为。它将是判别式的一部分。特别是，您可以通过将您定义的多项式设置为零并同时使雅可比行列式为零来获取相关部分。  
 
 
这是你的例子。我将最终（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 = 
表[展开[中心[[j]]，半径[[3]] + k *半径[[j]]，x，y]]，{j，2}] 
 
 Out [18] = {x ^ 2 + y ^ 2  -  2 xc [1,1] + c [1,1] ^ 2  -  2 yc [1,2] + 
c [1,2] ^ 2  -  k ^ 2 r [1] ^ 2  -  2 kr [1] r [3]  -  r [3] ^ 2，
x ^ 2 + y ^ 2  -  2 xc [2 ，1] + c [2,1] ^ 2  -  2 yc [2,2] + c [2,2] ^ 2  -  
k ^ 2 r [2] ^ 2  -  2 kr [2] r [ 3]  -  r [3] ^ 2} 
  
我们将删除k ，把其余部分平方，删除部分的正方形，并将两者等同。我们也用统一代替k。
 
 
  p2 = polys  -  k *系数[polys，k]; 
 polys2 =展开[p2 ^ 2  - （k *系数[polys，k]）^ 2] /。 k  - > 1; 
  
我们现在得到雅可比行列式的行列式并将其添加到brew中。
  discriminationm = Det [D [polys2，＃]& / @ {x，y}]; 
 
 allrelations =加入[polys2，{discriminationm]]; 
  
现在设置中心，如前所述（可以从一开始就这样做，人们会想到）。 
  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 [b] 
 
 
  gb = GroebnerBasis [2]，r [3]参数空间，它决定了我们解决方案的多样性。 ar2，半径，{x，y}，
 MonomialOrder  - > Elimination Orders] 
 
 {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} 
  
所有正确的，那么我们现在有多项式定义参数空间中的轨迹，其中解集可能变得愚蠢。关掉这一套，他们不应该有多重性，真正的计数应该永远是平等的。该集合与真实空间的交集将是半径参数的三维空间中的二维表面。它将把具有0,2,4,6或8个实际解决方案的区域彼此隔开。 
 
 
最后，我会指出在这个例子中，有问题可以很好地融入飞机的产品。我猜从几何角度来看，这并不令人感到意外。
 因子[gb [[1]]] 
 $ （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] ）
  
 
To address the question we start with the following toy model problem being here just a case study: 



Given two circles on a plane (its centers (c1 and c2) and radii (r1 and r2)) as well as a positive number r3,  find all circles with radii = r3 (i.e all points c3 being centers of circles with radii = r3) tangent  (externally and internally) to given two circles.



In general, depending on Circle[c1,r1], Circle[c2,r2] and r3 there are 0,1,2,...8 possible solutions.  A typical case with 8 solutions : 
 



I slightly modified a neat Mathematica implementation by Jaime Rangel-Mondragon on Wolfram Demonstration Project, but its core is similar: 
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])
         ]

We can easily conclude that in a generic case we have an even number of solutions 0,2,4,6,8 while cases with an odd number of solutions 1,3,5,7 are exceptional - they are of zero measure in terms of control ranges. Thus changing in Manipulate c1, r1, c2, r2, r3 one can observe that it is much more difficult to track cases with an odd number of circles. 



One could modify on a basic level the above approach : solving purely symbolically equations for c3 as well as redesignig Manipulate structure with an emphasis on changing number of solutions.  If I'm not wrong Solve can work only numerically with Locator in Manipulate, however here Locator seems to be crucial for simplicity of controlling  c1, r1, c2, r2 as well as for the whole implementation.

 Let's state the questions,  : 



1.  How can we force Manipulate to track seamlessly cases with an odd number of solutions (circles) ?



2. Is there any way to make Solve to find exact solutions of the underlying equations?



( I find the answer by Daniel Lichtblau to be the best approach to the question 2, but it seems in this instance there is still an essential need for sketching of a general technique of emphasizing measure zero sets of solutions while working with Manipulate )  



These considerations are of less importance while dealing with exact solutions



For example Solve[x^2 - 3 == 0, x] yields {{x -> -Sqrt[3]}, {x -> Sqrt[3]}} 
while in case from the above of  slightly more difficult equations extracted from Manipulate setting the following arguments : 
 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];

to :
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 &]

we get two solutions : 
{{{1.26795, -3.38871*10^-8}, 0.267949}, {{1.26795, 3.38871*10^-8}, 0.267949}}

similarly under the same arguments and equations, putting : 
r = 2 - Sqrt[3]; 

we get no solutions :  {} 



but in fact there is exactly one solution which we would like to emphasize:
{ {3 -  Sqrt[3], 0 }, 2 -  Sqrt[3] }

In fact, passing to  Graphics such a small difference between two different  solutions and the uniqe one is indistinguishable, however working with Manipulate we cannot track carefully with a desired accuracy merging of two circles and usually the last observed configuration when lowering r3 before vanishing all solutions (reminding so-called structural instability) looks like this : 




Manipulate is rather a powerful tool, not only a toy, and its mastering could be very useful. The considered issues when appearing in a serious research are frequently critical, for example: in  studying solutions of nonlinear differential equations, occurence of singularities in its solutions, qualitative behavior of dynamical systems, bifurcations, phenomena in Catastrophe theory and so on.  
 解决方案 
As this is a measure zero set, tools that require some granularity will generally have trouble with the concept. Perhaps better is to look for the singularity locus explicitly, where solutions have multiplicity or in other ways depart from the nearby solution behavior(s). It will be a part of the discriminant variety. In particular, you can grab the relevant part by setting your defining polynomials to zero and simultaneously making the Jacobian determinant zero. 



Here is your example. I will eventually (wlog) put one center at the origin and the other at (1,0).
centers = Array[c, {2, 2}];
radii = Array[r, 3];
circ[cen_, rad_, x_, y_] := ({x, y} - cen).({x, y} - cen) - rad^2

I'll use your 'k' for both polynomials. Your formulation has pairs (k,l) where each is +-1. We can just use k, arrange by squaring to get a polynomial in k^2, and replace that with 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}

We'll remove the part that is linear in k, square the rest, square that removed part, and equate the two. We also then replace k with unity.
p2 = polys - k*Coefficient[polys, k];
polys2 = Expand[p2^2 - (k*Coefficient[polys, k])^2] /. k -> 1;

We now get the determinant of the Jacobian and add that to the brew.
discrim = Det[D[polys2, #] & /@ {x, y}];

allrelations = Join[polys2, {discrim}];

Now set the centers as noted earlier (could have done this from the beginning, one would suppose).
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}

We now eliminate x and y to get the locus in r[1],r[2],r[3] parameter space that determines where we'll have multiplicity in our solutions.
 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}

If I did this all correctly, then we now have the polynomial defining the locus in parameter space where solution sets can get silly. Off this set they should never have multiplicity, and real counts should always be even. The intersection of this set with real space will be a 2d surface in the 3d space of the radii parameters. It will separate regions that have 0, 2, 4, 6, or 8 real solutions from one another.



Last, I'll point out that in this example the variety in question reduces nicely into a product of planes. I guess from a geometric view this is not too surprising.
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])



                        
这篇关于用Manipulate控制测量零套解决方案。案例研究的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
查看全文
相关文章
其他开发最新文章
热门教程
热门工具
登录 关闭
扫码关注1秒登录
发送“验证码”获取 | 15天全站免登陆