Related
I was playing with the (beautiful) polynomial x^4 - 10x^2 + 1.
Look what happens:
In[46]:= f[x_] := x^4 - 10x^2 + 1
a = Sqrt[2];
b = Sqrt[3];
Simplify[f[ a + b]]
Simplify[f[ a - b]]
Simplify[f[-a + b]]
Simplify[f[-a - b]]
Out[49]= 0
Out[50]= 0
Out[51]= 0
Out[52]= 0
In[53]:= Solve[f[x] == 0, x]
Out[53]= {{x->-Sqrt[5-2 Sqrt[6]]},{x->Sqrt[5-2 Sqrt[6]]},{x->-Sqrt[5+2 Sqrt[6]]},{x->Sqrt[5+2 Sqrt[6]]}}
In[54]:= Simplify[Solve[f[x] == 0, x]]
Out[54]= {{x->-Sqrt[5-2 Sqrt[6]]},{x->Sqrt[5-2 Sqrt[6]]},{x->-Sqrt[5+2 Sqrt[6]]},{x->Sqrt[5+2 Sqrt[6]]}}
In[55]:= FullSimplify[Solve[f[x] == 0, x]]
Out[55]= {{x->Sqrt[2]-Sqrt[3]},{x->Sqrt[5-2 Sqrt[6]]},{x->-Sqrt[5+2 Sqrt[6]]},{x->Sqrt[2]+Sqrt[3]}}
Sqrt[5-2 Sqrt[6]] is equal to Sqrt[3]-Sqrt[2].
However, Mathematica's FullSimplify does not simplify Sqrt[5-2 Sqrt[6]].
Question: Should I use other more specialized functions to algebraically solve the equation? If so, which one?
Indeed, Solve doesn't simplify all roots to the max:
A FullSimplify postprocessing step simplifies two roots and leaves two others untouched:
Same initially happens with Roots:
Strange enough, now FullSimplify simplifies all roots:
The reason for this is, I assume, that for the default ComplexityFunction some of the solutions written above in nested radicals are in a sense simpler than the others.
BTW FunctionExpand knows how to deal with those radicals:
FullSimplify[ Solve[x^4-10x^2+1==0,x]
,
ComplexityFunction ->
(StringLength[ToString[
InputForm[#1]]] & )]
gives
{{x -> Sqrt[2] - Sqrt[3]}, {x -> -Sqrt[2] + Sqrt[3]}, {x -> -Sqrt[2] -
Sqrt[3]}, {x -> Sqrt[2] + Sqrt[3]}}
I had a math problem I solved like this:
In[1]:= Solve[2x(a-x)==0, x]
Out[1]= {{x->0}, {x->a}}
In[2]:= Integrate[2x(a-x), {x,0,a}]
Out[2]= (a^3)/3
In[3]:= Solve[(a^3)/3==a, a]
Out[3]= {{a->0}, {a->-Sqrt[3]}, {a->Sqrt[3]}}
My question is if I could rewrite this to compute it in one step, rather than having to manually input the result from the previous line. I could easily replace the integral used in step three with the Integrate command from step two. But what I can't figure out is how I would use the result from step 1 as the limits of integration in the integral.
You could combine step 1 and 2 by doing something like
Integrate[2 x (a - x), {x, ##}] & ## (x /. Solve[2 x (a - x) == 0, x]);
If you agree to delegate the choice of the (positive oriented) domain to Integrate, by means of using Clip or Boole:
In[77]:= Solve[
Integrate[
Clip[2 x (a - x), {0, Infinity}], {x, -Infinity, Infinity}] == a, a]
Out[77]= {{a -> 0}, {a -> Sqrt[3]}}
or
In[81]:= Solve[
Integrate[
2 x (a - x) Boole[2 x (a - x) > 0], {x, -Infinity, Infinity}] ==
a, a]
Out[81]= {{a -> 0}, {a -> Sqrt[3]}}
The reason only non-negative roots are found, is that Integrate will integrate from the smallest root to the largest root, i.e. from {x,0,a} for positive a and {x,a,0} for negative a.
I have a function, let's say for example,
D[x^2*Exp[x^2], {x, 6}] /. x -> 0
And I want to replace 6 by a general integer n,
Or cases like the following:
Limit[Limit[D[D[x /((-1 + x) (1 - y) (-1 + x + x y)), {x, 3}], {y, 5}], {x -> 0}], {y -> 0}]
And I want to replace 3 and 5 by a general integer m and n respectively.
How to solve these two kinds of problems in general in mma?
Many thanks.
Can use SeriesCoefficient, sometimes.
InputForm[n! * SeriesCoefficient[x^2*Exp[x^2], {x,0,n}]]
Out[21]//InputForm=
n!*Piecewise[{{Gamma[n/2]^(-1), Mod[n, 2] == 0 && n >= 2}}, 0]
InputForm[mncoeff = m!*n! *
SeriesCoefficient[x/((-1+x)*(1-y)*(-1+x+x*y)), {x,0,m}, {y,0,n}]]
Out[22]//InputForm=
m!*n!*Piecewise[{{-1 + Binomial[m, 1 + n]*Hypergeometric2F1[1, -1 - n, m - n,
-1], m >= 1 && n > -1}}, 0]
Good luck extracting limits for m, n integer, in this second case.
Daniel Lichtblau
Wolfram Research
No sure if this is what you want, but you may try:
D[x^2*Exp[x^2], {x, n}] /. n -> 4 /. x -> 0
Another way:
f[x0_, n_] := n! SeriesCoefficient[x^2*Exp[x^2], {x, x0, n}]
f[0,4]
24
And of course, in the same line, for your other question:
f[m_, n_] :=
Limit[Limit[
D[D[x/((-1 + x) (1 - y) (-1 + x + x y)), {x, m}], {y, n}], {x ->
0}], {y -> 0}]
These answers don't give you an explicit form for the derivatives, though.
Still early days with Mathematica so please forgive what is probably a very obvious question. I am trying to generate some parametric plots. I have:
ParametricPlot[{
(a + b) Cos[t] - h Cos[(a + b)/b t],
(a + b) Sin[t] - h Sin[(a + b)/b t]},
{t, 0, 2 \[Pi]}, PlotRange -> All] /. {a -> 2, b -> 1, h -> 1}
No joy: the replacement rules are not applied and a, b and h remain undefined.
If I instead do:
Hold#ParametricPlot[{
(a + b) Cos[t] - h Cos[(a + b)/b t],
(a + b) Sin[t] - h Sin[(a + b)/b t]},
{t, 0, 2 \[Pi]}, PlotRange -> All] /. {a -> 2, b -> 1, h -> 1}
it looks like the rules ARE working, as confirmed by the output:
Hold[ParametricPlot[{(2 + 1) Cos[t] -
1 Cos[(2 + 1) t], (2 + 1) Sin[t] - 1 Sin[(2 + 1) t]}, {t, 0,
2 \[Pi]}, PlotRange -> All]]
Which is what I'd expect. Take the Hold off, though, and the ParametricPlot doesn't work. There's nothing wrong with the equations or the ParametricPlot itself, though, because I tried setting values for a, b and h in a separate expression (a=2; b=1; h=1) and I get my pretty double cardoid out as expected.
So, what am I doing wrong with ReplaceAll and why are the transformation rules not working? This is another fundamentally important aspect of MMA that my OOP-ruined brain isn't understanding.
I tried reading up on ReplaceAll and ParametricPlot and the closest clue I found was that "ParametricPlot has attribute HoldAll and evaluates f only after assigning specific numerical values to variables" which didn't help much or I wouldn't be here.
Thanks.
Mathematica evaluates each head without holding attributes by first evaluating head of each subexpression. Since ReplaceAll doesn't have holding attributes, ParametricPlot becomes Graphics before replacement
To see the expression tree, do
ParametricPlot[{(a + b) Cos[t] - h Cos[(a + b)/b t], (a + b) Sin[t] -
h Sin[(a + b)/b t]}, {t, 0, 2 \[Pi]},
PlotRange -> All] /. {a -> 2, b -> 1, h -> 1} // Hold // TreeForm
From that tree you can see that your command is the same as doing
temp1=ParametricPlot[{(a + b) Cos[t] - h Cos[(a + b)/b t], (a + b) Sin[t] -
h Sin[(a + b)/b t]}, {t, 0, 2 \[Pi]},
PlotRange -> All]
temp2={a -> 2, b -> 1, h -> 1}
temp1/.temp2
Look at FullForm[temp1] to confirm that there's no a or b in that expression.
If you set ReplaceAll to HoldFirst, that prevents ParametricPlot from being evaluated before ReplaceAll, and result is what you expected. In this case, ReplaceAll evaluates to expression with head ParametricPlot, and only at that point ParametricPlot is evaluated. Make sure to reset the attributes back because changing behavior of built-in commands can have unexpected side-effects.
SetAttributes[ReplaceAll, HoldFirst];
ParametricPlot[{(a + b) Cos[t] - h Cos[(a + b)/b t], (a + b) Sin[t] -
h Sin[(a + b)/b t]}, {t, 0, 2 \[Pi]},
PlotRange -> All] /. {a -> 2, b -> 1, h -> 1}
ClearAttributes[ReplaceAll, HoldFirst]
A useful trick when needing to evaluate arguments passed to function with HoldAll is to do operations on an expression with List head, and substitute ParametricPlot in the end, for instance
ParametricPlot ## ({{(a + b) Cos[t] -
h Cos[(a + b)/b t], (a + b) Sin[t] - h Sin[(a + b)/b t]}, {t, 0,
2 \[Pi]}, PlotRange -> All} /. {a -> 2, b -> 1, h -> 1})
The best way for using local variables in Mathematica is Module[]:
Module[{a = 2, b = 1, h = 1},
ParametricPlot[{(a + b) Cos[t] - h Cos[(a + b)/b t], (a + b) Sin[t] - h Sin[(a + b)/b t]},
{t, 0, 2 \[Pi]},
PlotRange -> All]]
This way a, b, and h do not get assigned values in the Global context but only inside the Module. If you still want to use replacement rules you just have to ReleaseHold after you have done the replacement:
ReleaseHold[
Hold#ParametricPlot[{(a + b) Cos[t] - h Cos[(a + b)/b t], (a + b) Sin[t] - h Sin[(a + b)/b t]},
{t, 0, 2 \[Pi]},
PlotRange -> All] /. {a -> 2, b -> 1, h -> 1}]
EDIT: As to why this happens. The way I understand it, HoldAll prevents the arguments of the function from being modified by any rules (internal or explicit). What your Hold does, is place the entire function on hold (not just the arguments), and the replacement rule gets applied after the function has gone through evaluation (which it didn't so there is still something there to replace) and HoldAll is no longer valid.
In[1] := Hold[a /. a -> 5]
Out[1] := Hold[a /. a -> 5]
In[2] := Hold[a] /. a -> 5
Out[2] := Hold[5]
Of course, Hold also has HoldAll as an attribute, so this doen't explain why ParametricPlot's HoldAll is different. :-(
EDIT2: I used Trace to look at what happens, and it seems like ReplaceAll gets applied only at the very end, when ParametricPlot has already turned into a graphical object (and does not contain a, b, or h anymore). In the case of Hold[a] /. a -> 5 the hold evaluates to Hold[a] and the replacement rule can then be successfully applied.
That is the way ReplaceAll always work.
See for example:
In[10]:= (a/a) /. a -> 0
Out[10]= 1
Clearly the replacement is done AFTER the evaluation, because if you do:
In[11]:= a = 0; a/a
During evaluation of In[11]:= Power::infy: Infinite expression 1/0 encountered. >>
During evaluation of In[11]:= Infinity::indet: Indeterminate expression 0 ComplexInfinity encountered. >>
Out[12]= Indeterminate
Now, is a matter of inserting the replacement at the level you want it to operate. As the result of a Plot is basically an Image with the numeric coordinates already "solved", you want to put those coordinates in before the plot is calculated. In your case:
ParametricPlot[
{(a + b) Cos[t] - h Cos[(a + b)/b t], (a + b) Sin[t] - h Sin[(a + b)/b t]}
/. {a -> 2, b -> 1, h -> 1},
{t, 0, 2 \[Pi]},
PlotRange -> All
]
This is not an answer as such, just a comment on using Module with Plot.
If I proceed as follows
f[t_] := {(a + b) Cos[t] - h Cos[(a + b)/b t], (a + b) Sin[t] -
h Sin[(a + b)/b t]}
The following will NOT work
Method 1:
Module[{a = 2, b = 1, h = 1},
ParametricPlot[f[t], {t, 0, 2 \[Pi]}, PlotRange -> All]]
Method 2:
Module[{a = 2, b = 1, h = 1},
ParametricPlot[Evaluate[f[t]], {t, 0, 2 \[Pi]}, PlotRange -> All]]
The following does work (Method 3)
ParametricPlot[
Module[{a = 2, b = 1, h = 1}, Evaluate[f[t]]], {t, 0, 2 \[Pi]},
PlotRange -> All]
as does the method described above (method 4)
Module[{a = 2, b = 1, h = 1},
ParametricPlot[{(a + b) Cos[t] - h Cos[(a + b)/b t], (a + b) Sin[t] - h Sin[(a + b)/b t]},
{t, 0, 2 \[Pi]},
PlotRange -> All]]
Can anyone explain why method 4 works but method 2 doesn't? (The same applies to With, which I find more intuitive to Module).
For what its worth, I would generate the original parametric plot using replacement rules as follows:
ParametricPlot[
Evaluate[{(a + b) Cos[t] - h Cos[(a + b)/b t], (a + b) Sin[t] -
h Sin[(a + b)/b t]}] /. {a -> 2, b -> 1, h -> 1}, {t, 0,
2 \[Pi]}, PlotRange -> All]
EDIT
f[x_] := (a x)/(b + x);
With[{a = 10, b = 100}, Plot[Evaluate[f[x]], {x, 0, 100}]]
With[{a = 10, b = 100}, Plot[(a x)/(b + x), {x, 0, 100}]]
Plot[With[{a = 10, b = 100}, Evaluate[f[x]]], {x, 0, 100}]
Plot[Evaluate[f[x]] /. {a -> 10, b -> 100}, {x, 0, 100}]
Method 1 (of Edit) does not work (because 'Plot' treats the variable x as local, effectively using Block'?)
It seems to me that it is absolutely clear to anyone, even those with a rudimentary knowledge of Mathematica, what is going on with Method 2, showing the power and ease-of-use of Mathematica. When the equations become more complex, is it advantageous to define them separately. It is now not so clear that Method 3 must be used instead of Method 1. (Method 4, of course, is probably the best of all.)
I am doing a brute force search for "gradient extremals" on the following example function
fv[{x_, y_}] = ((y - (x/4)^2)^2 + 1/(4 (1 + (x - 1)^2)))/2;
This involves finding the following zeros
gecond = With[{g = D[fv[{x, y}], {{x, y}}], h = D[fv[{x, y}], {{x, y}, 2}]},
g.RotationMatrix[Pi/2].h.g == 0]
Which Reduce happily does for me:
geyvals = y /. Cases[List#ToRules#Reduce[gecond, {x, y}], {y -> _}];
geyvals is the three roots of a cubic polynomial, but the expression is a bit large to put here.
Now to my question: For different values of x, different numbers of these roots are real, and I would like to pick out the values of x where the solutions branch in order to piece together the gradient extremals along the valley floor (of fv). In the present case, since the polynomial is only cubic, I could probably do it by hand -- but I am looking for a simple way of having Mathematica do it for me?
Edit: To clarify: The gradient extremals stuff is just background -- and a simple way to set up a hard problem. I am not so interested in the specific solution to this problem as in a general hand-off way of spotting the branch points for polynomial roots. Have added an answer below with a working approach.
Edit 2: Since it seems that the actual problem is much more fun than root branching: rcollyer suggests using ContourPlot directly on gecond to get the gradient extremals. To make this complete we need to separate valleys and ridges, which is done by looking at the eigenvalue of the Hessian perpendicular to the gradient. Putting a check for "valleynes" in as a RegionFunction we are left with only the valley line:
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];
Which gives just the valley floor line. Including some contours and the saddle point:
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"}]
We end up with a plot like this:
Not sure if this (belatedly) helps, but it seems you are interested in discriminant points, that is, where both polynomial and derivative (wrt y) vanish. You can solve this system for {x,y} and throw away complex solutions as below.
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}}
If you only want to plot the result then use StreamPlot[] on the gradients:
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]
You may have to fiddle around with the plot's precision, StreamStyle, and the RegionFunction to get it perfect. Especially useful would be using the solution for the valley floor to seed StreamPoints programmatically.
Updated: see below.
I'd approach this first by visualizing the imaginary parts of the roots:
This tells you three things immediately: 1) the first root is always real, 2) the second two are the conjugate pairs, and 3) there is a small region near zero in which all three are real. Additionally, note that the exclusions only got rid of the singular point at x=0, and we can see why when we zoom in:
We can then use the EvalutionMonitor to generate the list of roots directly:
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]
(Note, the Part specification is a little odd, Reap returns a List of what is sown as the second item in a List, so this results in a nested list. Also, Plot doesn't sample the points in a straightforward manner, so SortBy is needed.) There may be a more elegant route to determine where the last two roots become complex, but since their imaginary parts are piecewise continuous, it just seemed easier to brute force it.
Edit: Since you've mentioned that you want an automatic method for generating where some of the roots become complex, I've been exploring what happens when you substitute in y -> p + I q. Now this assumes that x is real, but you've already done that in your solution. Specifically, I do the following
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]&;
where the second step allows me to isolate the real and imaginary parts of the equation and simplify them independent of each other. Doing this same thing with the generic 2D polynomial, f + d x + a x^2 + e y + 2 c x y + b y^2, but making both x and y complex; I noted that Im[poly] = Im[x] D[poly, Im[x]] + Im[y] D[poly,[y]], and this may hold for your equation, also. By making x real, the imaginary part of poly becomes q times some function of x, p, and q. So, setting q=0 always gives Im[poly] == 0. But, that does not tell us anything new. However, if we
In[3] := qvals = Cases[List#ToRules#RReduce[ pi == 0 && q != 0, {x,p,q}],
{q -> a_}:> a];
we get several formulas for q involving x and p. For some values of x and p, those formulas may be imaginary, and we can use Reduce to determine where Re[qvals] == 0. In other words, we want the "imaginary" part of y to be real and this can be accomplished by allowing q to be zero or purely imaginary. Plotting the region where Re[q]==0 and overlaying the gradient extremal lines via
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}]}]
gives
which confirms the regions in the first two plots showing the 3 real roots.
Ended up trying myself since the goal really was to do it 'hands off'. I'll leave the question open for a good while to see if anybody finds a better way.
The code below uses bisection to bracket the points where CountRoots changes value. This works for my case (spotting the singularity at x=0 is pure luck):
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}}
Implementation:
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]
]]]