General solution of the Toeplitz' conjecture - wolfram-mathematica

Toeplitz' conjecture: Every continuous simple closed curve in the plane contains four points that are the vertices of a square.
I tried to find the general solution for (almost) any curve f(x,y)=0.
For instance :
(-1 + x^2 + y^2)^3 - x^2*y^3 = 0
ContourPlot[(-1 + x^2 + y^2)^3 == x^2*y^3, {x, -1.4, 1.4}, {y, -1.3, 1.5},
Frame -> False, PlotPoints -> 200]
There are three general conditions to find vertices of a square:
Coordinates of vertices are (p1,k1),(p2,k2),(p3,k3),(p4,k4)
Let
g[x_, y_] := (x^2 + y^2 - 1)^3 - x^2 y^3
1.. Vertex coordinates satisfy heart equation g(x,y)=0
eq1 = g[p1, k1] == 0;
eq2 = g[p2, k2] == 0;
eq3 = g[p3, k3] == 0;
eq4 = g[p4, k4] == 0;
2.. All sides have equal length.
eq5 =
EuclideanDistance[{p1, k1}, {p2, k2}] ==
EuclideanDistance[{p2, k2}, {p3, k3}] ==
EuclideanDistance[{p3, k3}, {p4, k4}] ==
EuclideanDistance[{p1, k1}, {p4, k4}];
3.. Every interior angle is a right angle
angle1 = VectorAngle[{p4 - p1, k4 - k1}, {p2 - p1, k2 - k1}] == Pi/2;
angle2 = VectorAngle[{p1 - p2, k1 - k2}, {p3 - p2, k3 - k2}] == Pi/2;
angle3 = VectorAngle[{p4 - p3, k4 - k3}, {p2 - p3, k2 - k3}] == Pi/2;
I have 8 equations and 8 variables and I want to find a numerical solutions by using Mathematica
I tried :
NSolve[eq1 && eq2 && eq3 && eq4 && eq5 && angle1 && angle2 && angle3,
{p1, p2, p3, p4, k1, k2, k3, k4}]
or
FindRoot[{eq1 && eq2 && eq3 && eq4 && eq5 && angle1 && angle2 && angle3},
{{p1, 1}, {k1, 1}, {p2, 1}, {k2, 1}, {p3, 1}, {k3,1}, {p4, 1}, {k4, 1}}]
But there is no answer ...


Once you have chosen two points, the positions of the two others follows.
If you know the curve by parametric equations, two points are obtained from two values of the parameter. Hence you have a system of two equations (expressing that the points are on the curve) in two unknowns.
If you don't have the parametric equations, then it is four equations in four unknowns.

Related

Mathematica's error by solving an ODE

I would know what is the problem with this Mathematica's code. Is there anyone that can give me an explanation of the bug, and also that can tell me how to improve the code?
V[x_, y_, z_] := x^2 + y - z;
m = 10;
DSolve[m*x''[t] == -Grad[V[x, y, z], {x, y, z}]*x[t], x[t], t]
Model of a particle in a potential-field. In this model we consider a particle as being a point of mass which describes a trajectory in space which is modeled by a function giving its coordinates in space as a function of time. The potential field is given by a function V : R^3 → R and the trajectory is a solution of the differential equation
Note this model assumes the particle is a point mass, which is certainly known to be false in many cases in which we use this model; for example, as a model of planetary motion.
Actual equation:

First: don't trust Wikipedia. It good for some basic knowledge, but for something specific better use some field-specific sources.
The correct equation is:
And the correct code:
V[x_, y_, z_] := x^2 + y - z;
m = 10;
DSolve[m*{x''[t], y''[t], z''[t]} ==
-(Grad[V[x, y, z], {x, y, z}] /. {x -> x[t], y -> y[t], z -> z[t]})
, {x[t], y[t], z[t]}, t]
Solution:
{{x[t] -> C[1] Cos[t/Sqrt[5]] + C[2] Sin[t/Sqrt[5]],
y[t] -> -(t^2/20) + C[3] + t C[4],
z[t] -> t^2/20 + C[5] + t C[6]}}

Given an increasing polynomial, how do you efficiently find x values for fixed intervals of y?

Problem: Given a polynomial of degree n (with coefficients a0 through an-1) that is guaranteed to be increasing from x = 0 to xmax, what is the most efficient algorithm to find the first m points with equally-spaced y values (i.e. yi - yi-1 == c, for all i)?
Example: If I want the spacing to be c = 1, and my polynomial is f(x) = x^2, then the first three points would be at y=1 (x=1), y=2 (x~=1.4142), and y=3 (x~=1.7321).
I'm not sure if it will be significant, but my specific problem involves the cube of a polynomial with given coefficients. My intuition tells me that the most efficient solution should be the same, but I'm not sure.
I'm encountering this working through the problems in the ACM's problem set for the 2012 World Finals (problem B), so this is mostly because I'm curious.
Edit: I'm not sure if this should go on the Math SE?

You can find an X for a given Y using a binary search. It's logarithmic time complexity, proportional to the size of the range of x values, divided by your error tolerance.
def solveForX(polyFunc, minX, maxX, y, epsilon):
midX = (minX + maxX) / 2.0
if abs(polyFunc(midX) - y) < epsilon:
return midX
if polyFunc(midX) > y:
return solveForX(polyFunc, minX, midX, y, epsilon)
else:
return solveForX(polyFunc, midX, maxX, y, epsilon)
print solveForX(lambda x: x*x, 0, 100, 2, 0.01)
output:
1.416015625
Edit: to expand on an idea in the comments, if you know you will be searching for multiple X values, it's possible to narrow down the [minX, maxX] search range.
def solveForManyXs(polyFunc, minX, maxX, ys, epsilon):
if len(ys) == 0:
return []
midIdx = len(ys) / 2
midY = ys[midIdx]
midX = solveForX(polyFunc, minX, maxX, midY, epsilon)
lowYs = ys[:midIdx]
highYs = ys[midIdx+1:]
return solveForManyXs(polyFunc, minX, midX, lowYs, epsilon) + \
[midX] + \
solveForManyXs(polyFunc, midX, maxX, highYs, epsilon)
ys = [1, 2, 3]
print solveForManyXs(lambda x: x*x, 0, 100, ys, 0.01)
output:
[1.0000884532928467, 1.41448974609375, 1.7318960977718234]

Mathematica: Tangent of Two Curves

I asked this question yesterday but not sure if I made clear what I was looking for. Say I have two curves defined as f[x_]:=... and g[x_]:=... as shown below. I want to use Mathematica to determine the abscissa intersection of the tangent to both curves and store value for each curve separately. Perhaps this is really a trivial task, but I do appreciate the help. I am an intermediate with Mathematica but this is one I haven't been able to find a solution to elsewhere.

f[x_] := x^2
g[x_] := (x - 2)^2 + 3
sol = Solve[(f[x1] - g[x2])/(x1 - x2) == f'[x1] == g'[x2], {x1, x2}, Reals]
(* ==> {{x1 -> 3/4, x2 -> 11/4}} *)
eqns = FlattenAt[{f[x], g[x], f'[x1] x + g[x2] - f'[x1] x2 /. sol}, 3];
Plot[eqns, {x, -2, 4}, Frame -> True, Axes -> None]
Please note that there will be many functions f and g for which you won't find a solution in this way. In that case you will have to resort to numerical problem solving methods.

You just need so solve a system of simultaneous equations:
The common tangent line is y = a x + b.
The common slope is a = f'(x1) = g'(x2)
The common points are a x0 + b = f(x0) and a x1 + b = g(x1).
Depending on the nature of the functions f and g this may have no, one, or many solutions.

FindRoot vs Solve, NSolve and Reduce

First some non-essential context for fun. My real question is far below. Please don't touch the dial.
I'm playing with the new probabilistic functions of Mathematica 8. Goal is to do a simple power analysis. The power of an experiment is 1 minus the probability of a type II error (i.e., anouncing 'no effect', whereas there is an effect in reality).
As an example I chose an experiment to determine whether a coin is fair. Suppose the probability to throw tails is given by b (a fair coin has b=0.5), then the power to determine that the coin is biased for an experiment with n coin flips is given by
1 - Probability[-in <= x - n/2 <= in, x \[Distributed] BinomialDistribution[n, b]]
with in the size of the deviation from the expected mean for a fair coin that I an willing to call not suspicious (in is chosen so that for a fair coin flipped n times the number of tails will be about 95% of the time within mean +/- in ; this, BTW, determines the size of the type I error, the probability to incorrectly claim the existence of an effect).
Mathematica nicely draws a plot of the calculated power:
n = 40;
in = 6;
Plot[1-Probability[-in<=x-n/2<=in,x \[Distributed] BinomialDistribution[n, b]], {b, 0, 1},
Epilog -> Line[{{0, 0.85}, {1, 0.85}}], Frame -> True,
FrameLabel -> {"P(tail)", "Power", "", ""},
BaseStyle -> {FontFamily -> "Arial", FontSize -> 16,
FontWeight -> Bold}, ImageSize -> 500]
I drew a line at a power of 85%, which is generally considered to be a reasonable amount of power. Now, all I want is the points where the power curve intersects with this line. This tells me the minimum bias the coin must have so that I have a reasonable expectation to find it in an experiment with 40 flips.
So, I tried:
In[47]:= Solve[ Probability[-in <= x - n/2 <= in,
x \[Distributed] BinomialDistribution[n, b]] == 0.15 &&
0 <= b <= 1, b]
Out[47]= {{b -> 0.75}}
This fails miserably, because for b = 0.75 the power is:
In[54]:= 1 - Probability[-in <= x - n/2 <= in, x \[Distributed] BinomialDistribution[n, 0.75]]
Out[54]= 0.896768
NSolve finds the same result. Reducedoes the following:
In[55]:= res = Reduce[Probability[-in <= x - n/2 <= in,
x \[Distributed] BinomialDistribution[n, b]] == 0.15 &&
0 <= b <= 1, b, Reals]
Out[55]= b == 0.265122 || b == 0.73635 || b == 0.801548 ||
b == 0.825269 || b == 0.844398 || b == 0.894066 || b == 0.932018 ||
b == 0.957616 || b == 0.987099
In[56]:= 1 -Probability[-in <= x - n/2 <= in,
x \[Distributed] BinomialDistribution[n, b]] /. {ToRules[res]}
Out[56]= {0.85, 0.855032, 0.981807, 0.994014, 0.99799, 0.999965, 1., 1., 1.}
So, Reduce manages to find the two solutions, but it finds quite a few others that are dead wrong.
FindRoot works best here:
In[57]:= FindRoot[{Probability[-in <= x - n/2 <= in,
x \[Distributed] BinomialDistribution[n, b]] - 0.15`}, {b, 0.2, 0, 0.5}]
FindRoot[{Probability[-in <= x - n/2 <= in,
x \[Distributed] BinomialDistribution[n, b]] - 0.15`}, {b, 0.8, 0.5, 1}]
Out[57]= {b -> 0.265122}
Out[58]= {b -> 0.734878}
OK, long introduction. My question is: why do Solve, NSolve, and Reduce fail so miserably (and silently!) here? IMHO, it can't be numerical accuracy since the power values found for the various solutions seem to be correct (they lie perfectly on the power curve) and are considerably removed from the real solution.
For the mma8-deprived Mr.Wizard: The expression for the power is a heavy one:
In[42]:= Probability[-in <= x - n/2 <= in,
x \[Distributed] BinomialDistribution[n, b]]
Out[42]= 23206929840 (1 - b)^26 b^14 + 40225345056 (1 - b)^25 b^15 +
62852101650 (1 - b)^24 b^16 + 88732378800 (1 - b)^23 b^17 +
113380261800 (1 - b)^22 b^18 + 131282408400 (1 - b)^21 b^19 +
137846528820 (1 - b)^20 b^20 + 131282408400 (1 - b)^19 b^21 +
113380261800 (1 - b)^18 b^22 + 88732378800 (1 - b)^17 b^23 +
62852101650 (1 - b)^16 b^24 + 40225345056 (1 - b)^15 b^25 +
23206929840 (1 - b)^14 b^26
and I wouldn't have expected Solve to handle this, but I had high hopes for NSolve and Reduce. Note that for n=30, in=5 Solve, NSolve, Reduce and FindRoot all find the same, correct solutions (of course, the polynomial order is lower there).

I think the problem is just the numeric instablitity of finding roots to high order polynomials:
In[1]:= n=40; in=6;
p[b_]:= Probability[-in<=x-n/2<=in,
x\[Distributed]BinomialDistribution[n,b]]
In[3]:= Solve[p[b]==0.15 && 0<=b<=1, b, MaxExtraConditions->0]
1-p[b]/.%
Out[3]= {{b->0.75}}
Out[4]= {0.896768}
In[5]:= Solve[p[b]==0.15 && 0<=b<=1, b, MaxExtraConditions->1]
1-p[b]/.%
Out[5]= {{b->0.265122},{b->0.736383},{b->0.801116},{b->0.825711},{b->0.845658},{b->0.889992},{b->0.931526},{b->0.958879},{b->0.986398}}
Out[6]= {0.85,0.855143,0.981474,0.994151,0.998143,0.999946,1.,1.,1.}
In[7]:= Solve[p[b]==3/20 && 0<=b<=1, b, MaxExtraConditions->0]//Short
1-p[b]/.%//N
Out[7]//Short= {{b->Root[-1+<<39>>+108299005920 #1^40&,2]},{b->Root[<<1>>&,3]}}
Out[8]= {0.85,0.85}
In[9]:= Solve[p[b]==0.15`100 && 0<=b<=1, b, MaxExtraConditions->0]//N
1-p[b]/.%
Out[9]= {{b->0.265122},{b->0.734878}}
Out[10]= {0.85,0.85}
(n.b. MaxExtraConditions->0 is actually the default option, so it could have been left out of the above.)
Both Solve and Reduce are simply generating Root objects
and when given inexact coefficients, they are automatically numerically evaluated.
If you look at the (shortened) output Out[7] then you'll see the Root of the full 40th order polynomial:
In[12]:= Expand#(20/3 p[b] - 1)
Out[12]= -1 + 154712865600 b^14 - 3754365538560 b^15 + 43996471155000 b^16 -
331267547520000 b^17 + 1798966820560000 b^18 -
7498851167808000 b^19 + 24933680132961600 b^20 -
67846748661120000 b^21 + 153811663157880000 b^22 -
294248399084640000 b^23 + 479379683508726000 b^24 -
669388358063093760 b^25 + 804553314979680000 b^26 -
834351666126339200 b^27 + 747086226686186400 b^28 -
577064755104364800 b^29 + 383524395817442880 b^30 -
218363285636496000 b^31 + 105832631433929400 b^32 -
43287834659596800 b^33 + 14776188957129600 b^34 -
4150451102878080 b^35 + 942502182076000 b^36 -
168946449235200 b^37 + 22970789150400 b^38 -
2165980118400 b^39 + 108299005920 b^40
In[13]:= Plot[%, {b, -1/10, 11/10}, WorkingPrecision -> 100]
From this graph you can confirm that the zeros are at (approx)
{{b -> 0.265122}, {b -> 0.734878}}.
But, to get the flat parts on the right hand side of the bump requires lots of numerical cancellations. Here's what it looks like without the explicit WorkingPrecision option:
This graph makes it clear why Reduce (or Solve with MaxConditions->1, see In[5] above) finds (from left to right) the first solution properly and the second solution almost correctly, followed by a whole load of crud.

Different numeric methods will fare differently when handling this.
(1) The ones that find all polynomial roots have the most difficult job, in that they may need to deal with deflated polynomials. FindRoot is off the hook there.
(2) The polynomial is a perturbation of one with substantial multiplicity. I would expect numeric methods to have trouble.
(3) The roots are all within 1-2 orders of magnitude in size. SO this is not so far from generally "bad" polynomials with roots around the unit circle.
(4) Most difficult is handling Solve[numeric eqn and ineq]. This must combine inequality solving methods (i.e. cylindrical decomposition) with machine arithmetic. Expect little mercy. Okay, this is univariate, so it amounts to Sturm sequences or Descartes' Rule of Signs. Still not numerically well behaved.
Here are some experiments using various method settings.
n = 40; in = 6;
p[b_] := Probability[-in <= x - n/2 <= in,
x \[Distributed] BinomialDistribution[n, b]]
r1 = NRoots[p[b] == .15, b, Method -> "JenkinsTraub"];
r2 = NRoots[p[b] == .15, b, Method -> "Aberth"];
r3 = NRoots[p[b] == .15, b, Method -> "CompanionMatrix"];
r4 = NSolve[p[b] == .15, b];
r5 = Solve[p[b] == 0.15, b];
r6 = Solve[p[b] == 0.15 && Element[b, Reals], b];
r7 = N[Solve[p[b] == 15/100 && Element[b, Reals], b]];
r8 = N[Solve[p[b] == 15/100, b]];
Sort[Cases[b /. {ToRules[r1]}, _Real]]
Sort[Cases[b /. {ToRules[r2]}, _Real]]
Sort[Cases[b /. {ToRules[r3]}, _Real]]
Sort[Cases[b /. r4, _Real]]
Sort[Cases[b /. r5, _Real]]
Sort[Cases[b /. r6, _Real]]
Sort[Cases[b /. r7, _Real]]
Sort[Cases[b /. r8, _Real]]
{-0.128504, 0.265122, 0.728, 1.1807, 1.20794, 1.22063}
{-0.128504, 0.265122, 0.736383, 0.801116, 0.825711, 0.845658, \
0.889992, 0.931526, 0.958879, 0.986398, 1.06506, 1.08208, 1.18361, \
1.19648, 1.24659, 1.25157}
{-0.128504, 0.265122, 0.733751, 0.834331, 0.834331, 0.879148, \
0.879148, 0.910323, 0.97317, 0.97317, 1.08099, 1.08099, 1.17529, \
1.17529, 1.23052, 1.23052}
{-0.128504, 0.265122, 0.736383, 0.801116, 0.825711, 0.845658, \
0.889992, 0.931526, 0.958879, 0.986398, 1.06506, 1.08208, 1.18361, \
1.19648, 1.24659, 1.25157}
{-0.128504, 0.265122, 0.736383, 0.801116, 0.825711, 0.845658, \
0.889992, 0.931526, 0.958879, 0.986398, 1.06506, 1.08208, 1.18361, \
1.19648, 1.24659, 1.25157}
{-0.128504, 0.75}
{-0.128504, 0.265122, 0.734878, 1.1285}
{-0.128504, 0.265122, 0.734878, 1.1285}
It looks like NSolve is using NRoots with Aberth's method, and Solve might just be calling NSolve.
The distinct solution sets seem to be all over the map. Actually many of the numeric ones that claim to be real (but aren't) might not be so bad. I'll compare magnitudes of one such set vs a set formed from numericizing exact root objects (a generally safe process).
mags4 = Sort[Abs[b /. r4]]
Out[77]= {0.128504, 0.129867, 0.129867, 0.13413, 0.13413, 0.141881, \
0.141881, 0.154398, 0.154398, 0.174443, 0.174443, 0.209069, 0.209069, \
0.265122, 0.543986, 0.543986, 0.575831, 0.575831, 0.685011, 0.685011, \
0.736383, 0.801116, 0.825711, 0.845658, 0.889992, 0.902725, 0.902725, \
0.931526, 0.958879, 0.986398, 1.06506, 1.08208, 1.18361, 1.19648, \
1.24659, 1.25157, 1.44617, 1.44617, 4.25448, 4.25448}
mags8 = Sort[Abs[b /. r8]]
Out[78]= {0.128504, 0.129867, 0.129867, 0.13413, 0.13413, 0.141881, \
0.141881, 0.154398, 0.154398, 0.174443, 0.174443, 0.209069, 0.209069, \
0.265122, 0.543985, 0.543985, 0.575831, 0.575831, 0.685011, 0.685011, \
0.734878, 0.854255, 0.854255, 0.902725, 0.902725, 0.94963, 0.94963, \
1.01802, 1.01802, 1.06769, 1.06769, 1.10183, 1.10183, 1.12188, \
1.12188, 1.1285, 1.44617, 1.44617, 4.25448, 4.25448}
Chop[mags4 - mags8, 10^(-6)]
Out[82]= {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, \
0.00150522, -0.0531384, -0.0285437, -0.0570674, -0.0127339, \
-0.0469044, -0.0469044, -0.0864986, -0.0591449, -0.0812974, \
-0.00263812, -0.0197501, 0.0817724, 0.0745959, 0.124706, 0.123065, 0, \
0, 0, 0}
Daniel Lichtblau

Well, not a proper answer, but an interesting observation. Solve[ ] has the same behavior than Reduce[ ] when the magic (aka MaxExtraConditions) option is used:
n=40;
in=6;
Solve[Probability[-in<=x-n/2<=in,
x\[Distributed]BinomialDistribution[n,b]]==0.15 &&
0<=b<=1,b, MaxExtraConditions->1]
{{b -> 0.265122}, {b -> 0.736488}, {b -> 0.80151}, {b -> 0.825884},
{b -> 0.84573}, {b -> 0.890444}, {b -> 0.931972}, {b -> 0.960252},
{b -> 0.985554}}

Converting vector equation to a list of equations in Mathematica

Due to DSolve syntax, systems of differential equations have to be given as lists of equations and not as a vector equation (Unlike Solve, which accepts both).
So my simple question is how to convert a vector equation such as:
{f'[t],g'[t]}=={{a,b},{c,d}}.{f[t],g[t]}
To list of equations:
{f'[t]==a*f[t]+b*g[t],g'[t]==c*f[t]+d*g[t]}
I think I knew once the answer, but I can't find it now and I think it could benefit others as well.

Try using Thread:
Thread[{f'[t], g'[t]} == {{a, b}, {c, d}}.{f[t], g[t]}]
(* {f'[t] == a f[t] + b g[t], g'[t] == c f[t] + d g[t] *)
It takes the equality operator == and applies it to each item within a list with the same Head.

The standard answer to this question is that which Brett presented,
i.e., using Thread.
However, I find that for use in DSolve, NDSolve, etc... the command LogicalExpand is better.
eqn = {f'[t], g'[t]} == {{a, b}, {c, d}}.{f[t], g[t]};
LogicalExpand[eqn]
(* f'[t] == a f[t] + b g[t] && g'[t] == c f[t] + d g[t] *)
It doesn't convert a vector equation to a list, but it is more useful since it automatically flattens out matrix/tensor equations and combinations of vector equations.
For example, if you wanted to add initial conditions to the above differential equation, you'd use
init = {f[0], g[0]} == {f0, g0};
LogicalExpand[eqn && init]
(* f[0] == f0 && g[0] == g0 &&
f'[t] == a f[t] + b g[t] && g'[t] == c f[t] + d g[t] *)
An example of a matrix equation is
mEqn = Array[a, {2, 2}] == Partition[Range[4], 2];
Using Thread here is awkward, you need to apply it multiple times and Flatten the result. Using LogicalExpand is easy
LogicalExpand[mEqn]
(* a[1, 1] == 1 && a[1, 2] == 2 && a[2, 1] == 3 && a[2, 2] == 4 *)

Resources