I'm trying to make a RecurrenceTable with conditionals in Mathematica, and the recursive stuff is working right, but it won't evaluate it completely.
In:= RecurrenceTable[{x[n] == If[Mod[n, 2] == 0, x[n - 1], y[n - 1]],
y[n] == If[Mod[n, 2] == 0, R x[n - 1] (1 - x[n - 1]), y[n - 1]],
x[1] == x0, y[1] == 0}, {x, y}, {n, 1, 10}]
Out:= {{0.25, 0.}, {x[1], 3 (1 - x[1]) x[1]}, {y[2], y[2]}, {x[3],
3 (1 - x[3]) x[3]}, {y[4], y[4]}, {x[5], 3 (1 - x[5]) x[5]}, {y[6],
y[6]}, {x[7], 3 (1 - x[7]) x[7]}, {y[8], y[8]}, {x[9],
3 (1 - x[9]) x[9]}}
These are the right results, but I need it to be in numeric form, i.e. {{0.25, 0.}, {0.25, 0.5625} ...
Is there a way to do this? Thanks!
Typically, you should use Piecewise for mathematical functions, and reserve If for programming flow.
You can convert many If statements using PiecewiseExpand:
If[Mod[n, 2] == 0, x[n - 1], y[n - 1]] // PiecewiseExpand
If[Mod[n, 2] == 0, r*x[n - 1] (1 - x[n - 1]), y[n - 1]] // PiecewiseExpand
The final code may look something like this:
r = 3;
x0 = 0.25;
RecurrenceTable[
{x[n] == Piecewise[{{x[n - 1], Mod[n, 2] == 0}}, y[n - 1]],
y[n] == Piecewise[{{r*x[n - 1] (1 - x[n - 1]), Mod[n, 2] == 0}}, y[n - 1]],
x[1] == x0,
y[1] == 0},
{x, y},
{n, 10}
]
{{0.25, 0.}, {0.25, 0.5625}, {0.5625, 0.5625}, {0.5625,
0.738281}, {0.738281, 0.738281}, {0.738281, 0.579666}, {0.579666,
0.579666}, {0.579666, 0.73096}, {0.73096, 0.73096}, {0.73096, 0.589973}}
A couple of related points:
It is best not to use capital letters for your symbol names, as these may conflict with built-in functions.
You may consider Divisible[n, 2] in place of Mod[n, 2] == 0 if you wish.
RecurrenceTable[{
x[n] == Boole[ Mod[n,2] == 0 ] x[n-1] +
Boole[ Mod[n,2] != 0 ] y[n-1],
y[n] == Boole[ Mod[n,2] == 0 ] 3 x[n-1] (1-x[n-1]) +
Boole[ Mod[n,2] != 0 ] y[n-1],
x[1] == .25, y[1] == 0},
{x, y}, {n, 1, 10}]
with edits R = 3 and x0 = .25 gives the output you expect.
Related
I want to plot this equation
Plot[Tan[\[Alpha] Sqrt[\[Beta]^2 - 1]] == ( 0.2 Sqrt[1 - k^2 \[Beta]^2])/Sqrt[\[Beta]^2 - 1], k = 0.75, {{\[Alpha], 0, 1.4}, {\[Beta], 0, 17}}]
but I get this error
"Options expected (instead of {{[Alpha],0,1.4},{[Beta],0,17}}) \
beyond position 2 in Plot"An option must be a rule or a list of rules.
ContourPlot[
{Tan[α Sqrt[β^2 - 1]] == (0.2 Sqrt[1 - k^2 β^2])/Sqrt[β^2 - 1], k = 0.75},
{α, 0, 1.4}, {β, 0, 17}, PlotRange -> {Automatic, {1, 1.5}},
FrameLabel -> Automatic, BaseStyle -> 14]
For example
k = 0.75;
sol = FullSimplify[NSolve[
Tan[α Sqrt[β^2 - 1]] == (0.2 Sqrt[1 - k^2 β^2])/Sqrt[β^2 - 1], α]];
When β is 1.25
sol /. β -> 1.25
{{α -> 0.1233747751953911}}
Plotting with the solution sol
expr = sol[[1, 1, 2]];
out = Cases[Table[{expr, β}, {β, 1, 1.5, 0.001}], {_Real, _}];
ListPlot[out, Frame -> True, FrameLabel -> {"α", "β"}, BaseStyle -> 14]
I would like to solve the system A*B=I for the elements of B in terms of the elements of A.
A and B are square, the elements of A and B don't commute (i.e. A[1,1]*B[1,1]=/=B[1,1]*A[1,1]), and A and B are of size nxn.
Here is what I've tried so far:
In[16]:= n = 2;
In[34]:= Reduce[Flatten[Table[
Sum[A[i, j] ** B[j, k], {j, 1, n}] == KroneckerDelta[i, k], {i, 1,
n}, {k, 1, n}]], {B[1, 1]}]
During evaluation of In[34]:= Reduce::nsmet: This system cannot be solved with the methods available to Reduce.
Out[34]= Reduce[{A[1, 1] ** B[1, 1] + A[1, 2] ** B[2, 1] == 1,
A[1, 1] ** B[1, 2] + A[1, 2] ** B[2, 2] == 0,
A[2, 1] ** B[1, 1] + A[2, 2] ** B[2, 1] == 0,
A[2, 1] ** B[1, 2] + A[2, 2] ** B[2, 2] == 1}, {B[1, 1]}]
Could you please let me know how I can fix this code to make it work? If n=2, the solution should be one of the either one of last 2 equations here:
http://www.math.chalmers.se/~rootzen/highdimensional/blockmatrixinverse.pdf
I have this matrix
a = {{2, -2, -4}, {-2, 5, -2}, {-4, -2, 2}}
I then solved an equation with one missing entry. The equation is of the form
Inverse[p].a.p == q
where p is the 3x3 matrix with the missing entry (x5) and q is a given 3x3 matrix.
Solve[Inverse[( {
{1/Sqrt[5], 4/(3 Sqrt[5]), -2/3},
{-2/Sqrt[5], 2/(3 Sqrt[5]), -2/6},
{0, x5, -2/3}
} )].a.( {
{1/Sqrt[5], 4/(3 Sqrt[5]), -2/3},
{-2/Sqrt[5], 2/(3 Sqrt[5]), -2/6},
{0, x5, -2/3}
} ) == ( {
{6, 0, 0},
{0, 6, 0},
{0, 0, -3}
} )]
Mathematica can solve this easily and I get x5 -> -(Sqrt[5]/3) as the result.
However if I check it, the result ist very weird:
In[2]:= Inverse[( {
{1/Sqrt[5], 4/(3 Sqrt[5]), -2/3},
{-2/Sqrt[5], 2/(3 Sqrt[5]), -2/6},
{0, -Sqrt[5]/3, -2/3}
} )].a.( {
{1/Sqrt[5], 4/(3 Sqrt[5]), -2/3},
{-2/Sqrt[5], 2/(3 Sqrt[5]), -2/6},
{0, -Sqrt[5]/3, -2/3}
} )
Out[2]= {{6/5 - (2 (-(2/Sqrt[5]) - 2 Sqrt[5]))/Sqrt[5],
8/5 + (2 (-(2/Sqrt[5]) - 2 Sqrt[5]))/(3 Sqrt[5]), -(4/Sqrt[5]) +
1/3 (2/Sqrt[5] + 2 Sqrt[5])}, {-((
2 (-(8/(3 Sqrt[5])) + (4 Sqrt[5])/3))/Sqrt[5]) + (
4/(3 Sqrt[5]) + (4 Sqrt[5])/3)/Sqrt[5],
10/3 + (2 (-(8/(3 Sqrt[5])) + (4 Sqrt[5])/3))/(3 Sqrt[5]) + (
4 (4/(3 Sqrt[5]) + (4 Sqrt[5])/3))/(3 Sqrt[5]), (4 Sqrt[5])/3 +
1/3 (8/(3 Sqrt[5]) - (4 Sqrt[5])/3) -
2/3 (4/(3 Sqrt[5]) + (4 Sqrt[5])/3)}, {0, 0, -3}}
the expected result should be
( {
{6, 0, 0},
{0, 6, 0},
{0, 0, -3}
} )
like in the equation. If I calculate this by hand I get this result. What am I missing here?
Just Simplify or Expand the results.
Here is an example:
In[1]:= a = {{2, -2, -4}, {-2, 5, -2}, {-4, -2, 2}}
Out[1]= {{2, -2, -4}, {-2, 5, -2}, {-4, -2, 2}}
In[2]:= p = {{1/Sqrt[5], 4/(3 Sqrt[5]), -(2/3)}, {-(2/Sqrt[5]), 2/(
3 Sqrt[5]), -(2/6)}, {0, x5, -(2/3)}}
Out[2]= {{1/Sqrt[5], 4/(3 Sqrt[5]), -(2/3)}, {-(2/Sqrt[5]), 2/(
3 Sqrt[5]), -(1/3)}, {0, x5, -(2/3)}}
In[3]:= sol =
Solve[Inverse[p].a.p == {{6, 0, 0}, {0, 6, 0}, {0, 0, -3}}]
Out[3]= {{x5 -> -(Sqrt[5]/3)}}
In[4]:= Inverse[p].a.p /. sol[[1]]
Out[4]= <big output removed>
In[5]:= Simplify[%]
Out[5]= {{6, 0, 0}, {0, 6, 0}, {0, 0, -3}}
Expand would work too in place of Simplify. Expressions in terms of roots and fractions can often be written in several ways, and it's not immediately obvious if two expression are equivalent just by looking at them. You have to explicitly ask Mathematica to transform them, for example expr = 13/(2 Sqrt[3]) - 4/3 and Together[expr].
What is quite strange though, is that Solve does not work if you use the standard syntax and give variables explicitly:
In[6]:= Solve[Inverse[p].a.p == {{6, 0, 0}, {0, 6, 0}, {0, 0, -3}}, x5]
Out[6]= {}
In[7]:= Solve[
Inverse[p].a.p == {{6, 0, 0}, {0, 6, 0}, {0, 0, -3}}, x5,
VerifySolutions -> False]
Out[7]= {}
Can anyone explain why? NSolve works as expected.
In[8]:= NSolve[
Inverse[p].a.p == {{6, 0, 0}, {0, 6, 0}, {0, 0, -3}}, x5]
Out[8]= {{x5 -> -0.745356}}
Remove["Global`*"];
a = {{2, -2, -4}, {-2, 5, -2}, {-4, -2, 2}};
p = {{1/Sqrt[5], 4/(3 Sqrt[5]), -2/3}, {-2/Sqrt[5],
2/(3 Sqrt[5]), -2/6}, {0, x, -2/3}};
pInv = Inverse[p];
lhs = pInv.a.p;
q = {6, 6, -3};
eqs = N#Expand#
Map[Total[lhs[[#, All]]] - q[[#]] == 0 &, Range[Length[q]]]
Here are the 3 equations all in x. (3 equations, ONE unknown!)
-6. - 2.66667/(-0.444444 + 0.745356 x) + (4.47214 x)/(-0.444444 + 0.745356 x) ==
0.,
-6. - 2.66667/(-0.444444 + 0.745356 x) + (4.47214 x)/(-0.444444 + 0.745356 x) == 0.,
3. - 0.654283/(-0.444444 + 0.745356 x) -(1.5694 x)/(-0.444444 + 0.745356 x) + (
4.47214 x^2)/(-0.444444 + 0.745356 x) == 0.
first solve numerically
Map[NSolve[eqs[[#]],x]&,Range[3]]
Out[465]= {{{x->0.}},{{x->0.}},{{x->-0.745356}}}
To get Solve to accept x, First do not do Numerical, leave it symbolic:
eqs = Expand# Map[Total[lhs[[#, All]]] - q[[#]] == 0 &, Range[Length[q]]]
which gives
{-6 - 8/(3 (-(4/9) + (Sqrt[5] x)/3)) + (2 Sqrt[5] x)/(-(4/9) + (Sqrt[5] x)/3) ==
0,
-6 - 8/(3 (-(4/9) + (Sqrt[5] x)/3)) + (2 Sqrt[5] x)/(-(4/9) + (Sqrt[5] x)/3) == 0,
3 + 4/(3 (-(4/9) + (Sqrt[5] x)/3)) - (8 Sqrt[5])/(9 (-(4/9) + (Sqrt[5] x)/3))
+ (2 x)/(3 (-(4/9) + (Sqrt[5] x)/3)) - (
Sqrt[5] x)/(-(4/9) + (Sqrt[5] x)/3) + (
2 Sqrt[5] x^2)/(-(4/9) + (Sqrt[5] x)/3) == 0}
Now use Solve, with explicit x in there, now it is ok
Map[Solve[eqs[[#]], x] &, Range[3]]
{{{}}, {{}}, {{x -> -(Sqrt[5]/3)}}}
--Nasser
Given the following code:
s := NDSolve[{x''[t] == -x[t], x[0] == 1, x'[0] == 1}, x, {t, 0, 5 }]
Plot[Evaluate[{x[t]} /. s], {t, 0, 3}]
This plots the solution to the differential equation. How would I numerically solve for a zero of x[t] where t ranges between 0 and 3?
The original question was answered by #rcollyer. I am answering the question you posted in your first comment to rcollyer's answer:
But what if instead our s is "s := NDSolve[{x'[t]^2 == -x[t]^3 - x[t] + 1, x[0] == 0.5}, x, {t, 0, 5}]" Then the FindRoot function just gives back an error while the plot shows that there is a zero around 0.6 or so.
So:
s = NDSolve[{x'[t]^2 == -x[t]^3 - x[t] + 1, x[0] == 0.5},
x, {t, 0, 1}, Method -> "StiffnessSwitching"];
Plot[Evaluate[{x[t]} /. s], {t, 0, 1}]
FindRoot[x[t] /. s[[1]], {t, 0, 1}]
{t -> 0.60527}
Edit
Answering rcollyer's comment, the "second line" comes from the squared derivative, as in:
s = NDSolve[{x'[t]^2 == Sin[t], x[0] == 0.5}, x[t], {t, 0, Pi}];
Plot[Evaluate[{x[t]} /. s], {t, 0, Pi}]
Coming from:
DSolve[{x'[t]^2 == Sin[t]}, x[t], t]
(*
{{x[t] -> C[1] - 2 EllipticE[1/2 (Pi/2 - t), 2]},
{x[t] -> C[1] + 2 EllipticE[1/2 (Pi/2 - t), 2]}}
*)
FindRoot works
In[1]:= FindRoot[x[t] /. s, {t, 0, 3}]
Out[1]:= {t -> 2.35619}
I have to minimize a bunch of functions of n variables that can take values from an integer range.
The functions have the general form:
f[{s1_,... sn_}]:= Kxy KroneckerDelta[sx,sy] + Kwz KroneckerDelta[sw,sz] +/- ..
Where the Kmn are also integers.
As an example,
f[{s1_, s2_, s3_, s4_, s5_}:= KroneckerDelta[s1, s2] - KroneckerDelta[s1, s4] +
KroneckerDelta[s1, s5] + KroneckerDelta[s3, s4] +
KroneckerDelta[s3, s5] + KroneckerDelta[s4, s5];
Where the si_ must be in Range[3].
I can bruteforce easily, for example:
rulez = Table[s[i] -> #[[i]], {i, 5}] & /# Tuples[Range[3], 5];
k1 = f[Table[s[i], {i, 5}]] /. rulez;
{Min[k1], Tuples[Range[3], 5][[#]] & /# Position[k1, Min[k1]]}
(*
->
{-1,{{{1, 2, 2, 1, 3}}, {{1, 2, 3, 1, 2}}, {{1, 3, 2, 1, 3}}, {{1, 3, 3, 1, 2}},
{{2, 1, 1, 2, 3}}, {{2, 1, 3, 2, 1}}, {{2, 3, 1, 2, 3}}, {{2, 3, 3, 2, 1}},
{{3, 1, 1, 3, 2}}, {{3, 1, 2, 3, 1}}, {{3, 2, 1, 3, 2}}, {{3, 2, 2, 3, 1}}}}
*)
Obviously, that seems to take forever for large sets of variables and larger value ranges.
I tried Minimize[ ], but get results that don't satisfy the conditions (!):
Minimize[{f[Table[s[i], {i, 5}]], And ## Table[1 <= s[i] <= 3, {i, 5}]},
Table[s[i], {i, 5}], Integers]
(*
-> {2, {s[1] -> 0, s[2] -> 0, s[3] -> 0, s[4] -> 0, s[5] -> 0}}
*)
Or in other cases, it just fails:
g[{s1_, s2_, s3_, s4_, s5_}]:= KroneckerDelta[s1, s3] - KroneckerDelta[s1, s4] +
KroneckerDelta[s1, s5] + KroneckerDelta[s3, s4] +
KroneckerDelta[s3, s5] + KroneckerDelta[s4, s5];
Minimize[{g[Table[s[i], {i, 5}]], And ## Table[1 <= s[i] <= 3, {i, 5}]},
Table[s[i], {i, 5}], Integers]
(*
->
During evaluation of In[168]:= Minimize::infeas: There are no values of
{s[1],s[2],s[3],s[4],s[5]} for which the constraints 1<=s[1]<=3&&1<=s[2]<=3&&
1<=s[3]<=3&&1<=s[4]<=3&&1<=s[5]<=3 are satisfied and the objective function
KroneckerDelta[s[1],s[3]]-KroneckerDelta[s[1],s[4]]+KroneckerDelta[s[1],s[5]]+
KroneckerDelta[s[3],s[4]]+KroneckerDelta[s[3],s[5]]+KroneckerDelta[s[4],s[5]]
is real valued. >>
Out[169]= {\[Infinity], s[1]->Indeterminate, s[2]->Indeterminate,
s[3]->Indeterminate, s[4]->Indeterminate,
s[5]->Indeterminate}}
*)
So the question is twofold:
Why does Minimize[ ] fail?, and What is the better way to tackle this kind of problems with mathematica?
Edit
Just to emphasize, the first question is:
Why does Minimize[ ] fail?
Not that the other part is less important, but I am trying to learn when to invest my time in lurking with Minimize[ ], and when I shouldn't.
The problem seems to be related to the KroneckerDelta. If I define a function that is equivalent as long as integers are input it works (or at least it looks like it):
In[177]:= kd[x_, y_] := Round[10^-(x - y)^2]
In[179]:=
g[{s1_, s2_, s3_, s4_, s5_}] :=
kd[s1, s3] - kd[s1, s4] + kd[s1, s5] + kd[s3, s4] + kd[s3, s5] +
kd[s4, s5];
Minimize[{g[{s1, s2, s3, s4, s5}],
And ## Map[1 <= # <= 3 &, {s1, s2, s3, s4, s5}]}, {s1, s2, s3, s4,
s5}, Integers]
Out[180]= {-1, {s1 -> 1, s2 -> 1, s3 -> 2, s4 -> 1, s5 -> 3}}
You can set it up as an integer linear programming problem, and send it to Minimize in that form. I show one way to do this below. The Kronecker deltas are now just integer variables constrained between 0 and 1, with certain relations that force k[i,j] to be 1 when s[i]==s[j] and zero otherwise (this uses the coefficient signs and the max coefficient value).
I show the full set of constraints below, along with the expression we'll minimize.
highval = 3;
list = {{1, 2}, {1, 4}, {1, 5}, {3, 4}, {3, 5}, {4, 5}};
coeffs = {1, -1, 1, 1, 1, 1};
v1list = Apply[k, list, 1];
expr = coeffs.v1list
v2list = Map[s, Range[5]];
allvars = Flatten[{v1list, v2list}];
c1 = Map[0 <= # <= 1 &, v1list];
c2 = Map[1 <= # <= highval &, v2list];
c3 = Map[# <= 0 &,
Sign[coeffs]*
Map[{highval*(# - 1) - (s[#[[1]]] - s[#[[2]]]),
highval*(# - 1) - (s[#[[2]]] - s[#[[1]]])} &, v1list], {2}];
c4 = Element[allvars, Integers];
constraints = Flatten[{c1, c2, c3}]
k[1, 2] - k[1, 4] + k[1, 5] + k[3, 4] + k[3, 5] + k[4, 5]
{0 <= k[1, 2] <= 1, 0 <= k[1, 4] <= 1, 0 <= k[1, 5] <= 1, 0 <= k[3, 4] <= 1,
0 <= k[3, 5] <= 1, 0 <= k[4, 5] <= 1,
1 <= s[1] <= 3, 1 <= s[2] <= 3, 1 <= s[3] <= 3, 1 <= s[4] <= 3, 1 <= s[5] <= 3,
3*(-1 + k[1, 2]) - s[1] + s[2] <= 0, 3*(-1 + k[1, 2]) + s[1] - s[2] <= 0,
-3*(-1 + k[1, 4]) + s[1] - s[4] <= 0,-3*(-1 + k[1, 4]) - s[1] + s[4] <= 0,
3*(-1 + k[1, 5]) - s[1] + s[5] <= 0, 3*(-1 + k[1, 5]) + s[1] - s[5] <= 0,
3*(-1 + k[3, 4]) - s[3] + s[4] <= 0, 3*(-1 + k[3, 4]) + s[3] - s[4] <= 0,
3*(-1 + k[3, 5]) - s[3] + s[5] <= 0, 3*(-1 + k[3, 5]) + s[3] - s[5] <= 0,
3*(-1 + k[4, 5]) - s[4] + s[5] <= 0, 3*(-1 + k[4, 5]) + s[4] - s[5] <= 0}
Now just call Minimize, specifying Integers as domain.
Minimize[{expr, constraints}, allvars, Integers]
Out[235]= {-1, {k[1, 2] -> 0, k[1, 4] -> 1, k[1, 5] -> 0,
k[3, 4] -> 0, k[3, 5] -> 0, k[4, 5] -> 0,
s[1] -> 2, s[2] -> 2, s[3] -> 2, s[4] -> 2, s[5] -> 2}}
Daniel Lichtblau
Wolfram Research