I need to write a function for finding n-th Pell number.
This is recurrence relation for Pell numbers.
P[0]=0, P[1]=1
P[n+1] = 2P[n] + P[nô€€€-1]; n>=1;
I did that this way:
P[n_] :=
If[n >= 1,
Return[2*P[n - 1] + P[n - 2]]];
It worked, but it has to be optimized for n>=50 so those can be calculated in relatively short time, and this one doesn't work fast.
Memoization is good. Or could do
pell[n_] =
RSolveValue[{p[n] == 2*p[n - 1] + p[n - 2], p[0] == 0, p[1] == 1},
p[n], n]
(* Out[4308]= -(((1 - Sqrt[2])^n - (1 + Sqrt[2])^n)/(2 Sqrt[2])) *)
Or
pell2[n_] := MatrixPower[{{2, 1}, {1, 0}}, n, {0, 1}][[1]]
There are close formulas for all the Pell and Nacci numbers. Here is the close formula for the Pell numbers you are looking for:
from __future__ import division #if you are using python 2.x
from math import sqrt
Pell = 1 + sqrt(2)
pell = 1 - sqrt(2)
for i in range(1,50):
print (Pell**i - pell**i)/(Pell-pell)
Related
The following code gives me the first k eigenvalues of a certain big matrix. Because of the symmetries of the matrix, the eigenvalues are in pairs, one positive and the other negative, with the same absolute value. This is indeed the case if I run the code with the exact matrices, without using the sparse version. However when I make them sparse, the resulting eigenvalues appear to lose the sign information, as now the pairs can be both negative, or both positive, depending on the number I put on "nspins" (which controls the size of the matrix). The variable "sparse" controls whether I use sparse matrices or not.
This issue gives me considerable trouble. Can anybody tell me why the sparse version of the computation gives wrong signs, and how to fix it?
sparse = 1; (*Parameter that controls whether I will use sparse \
matrices, 0 means not sparse, 1 means sparse*)
(*Base matrices of my big matrix*)
ox = N[{{0, 1}, {1, 0}}];
oz = N[{{1, 0}, {0, -1}}];
id = N[{{1, 0}, {0, 1}}];
(*Transformation into sparse whether desired*)
If[sparse == 1,
ox = SparseArray[ox];
oz = SparseArray[oz];
id = SparseArray[id];
]
(*Dimension of the big matrix, must be even*)
nspins = 8;
(*Number of eigenvalues computed*)
neigenv = 4;
(*Algorithm to create big matrices*)
Do[
Do[
If[j == i, mata = ox; matc = oz;, mata = id; matc = id;];
If[j == 1,
o[1, i] = mata;
o[3, i] = matc;
,
o[1, i] = KroneckerProduct[o[1, i], mata];
o[3, i] = KroneckerProduct[o[3, i], matc];
];
, {j, 1, nspins}];
, {i, 1, nspins}];
(*Sum of big matrices*)
ham = Sum[o[1, i].o[1, i + 1], {i, 1, nspins - 1}] +
o[1, nspins].o[1, 1] + 0.5*Sum[o[3, i], {i, 1, nspins}];
(*Print the desired eigenvalues*)
Do[Print [Eigenvalues[ham, k][[k]]], {k, 1, neigenv}];
please can you help me with creation of function in Wolfram Mathematica for magic square. I must create function MagicSquare[n_], which output is sqare matrix of first n^2 integers, and sum of these integers in every column, every row, and on diagonals must be the same. Please help me, I try this for a days and I failed. I need this for my school assignment.
Here is a simple brute-force approach. Note the check value m is the magic constant.
(Setting the random values to the array variables makes nifty use of HoldFirst.)
n = 3;
m = n (n^2 + 1)/2;
check = {0};
While[Unequal[Union[check], {m}],
Clear[s];
x = Table[s[i, j], {i, 1, n}, {j, 1, n}];
d1 = Diagonal[x];
d2 = Diagonal[Reverse[x]];
cols = Transpose[x];
vars = Flatten[x];
rand = RandomSample[Range[n^2], n^2];
MapThread[Function[{v, r}, v = r, HoldFirst], {vars, rand}];
check = Total /# Join[x, cols, {d1, d2}]];
MatrixForm[x]
8 3 4
1 5 9
6 7 2
Here is another brute force approach that works for n=3 ..
n = 3
m = n (n^2 + 1) /2
Select[
Partition[# , n] & /#
Permutations[Range[n^2]],
(Union #(Total /# # )) == {m} &&
(Union #(Total /# Transpose[#] )) == {m} &&
Total#Diagonal[#] == m &&
Total#Diagonal[Reverse##] == m & ][[1]] // MatrixForm
This has the advantage of immediately producing an out of memory error for larger n, while Chris' will run approximately forever. :)
In an interview today, I was given this sequence, which is sort of a modified Fibonacci:
1, 1, 2, 4, 6, 13, 19, 42, 61, 135, ...,
I was asked to write a function to return the number at place n.
So, if n = 4, the function should return 4, n = 6 return 13, etc.
As I'm sure you already noticed, the difference is that even items equal the previous 4 items, while odd items equal the previous 2.
It isn't a problem if you use recursion. That's what I did, but it's not the approach I would have liked.
The Fibonacci calculation goes something like this (in PHP):
$n = 17;
$phi = (1 + sqrt(5)) / 2;
$u = (pow($phi, $n) - pow(1 - $phi, $n)) / sqrt(5);
$u being, in this case, 1597.
However, I have no idea how to solve it with a modified version of a Fibonacci sequence like this one.
If I understand you correctly, you want to compute efficiently [i.e. in O( log(n) )] sequence defined as:
a[2n + 5] = a[2n + 4] + a[2n + 3] + a[2n + 2] + a[2n + 1]
a[2n + 2] = a[2n + 1] + a[2n]
Let's define two new sequences. First one will correspond to the values of a on even positions, the second one to the values on even positions:
b[n] = a[2n]
c[n] = a[2n + 1]
Now we have:
c[n] = b[n] + c[n - 1] + b[n - 1] + c[n - 2]
b[n] = c[n - 1] + b[n - 1]
Subtracting the second equation from the first we get (after some transformation):
b[n] = ( c[n] - c[n-1] ) /2
Next substitute this formula into first equation to get formula for c:
c[n] = 2 c[n-1] + c[n-2]
Notice that this equation involves only elements from c. Therefore now it is possible to compute elements of c, using techniques described here. By transforming equations a little bit further you will be able to compute b efficiently as well.
Like every sequence defined by a linear recurrence with constant coefficients, the Fibonacci numbers have a closed-form solution.
http://en.wikipedia.org/wiki/Fibonacci_number#Closed-form_expression
However, I do not know how to create a closed form expression for this particular sequence.
What I can add is that you can solve Fibonacci or any similar sequence without recursion, e.g.:
http://forum.codecall.net/topic/41540-fibonacci-with-no-recursion-for-fun/
So you can solve the problem using a loop rather than the stack.
Background. I want to print a table of convergents for 31^(1/2). I made the following recursive definition of the table. ( Exchange 31^(1/2) with the golden ratio and the table below would contain the Fibonacci series ).
cf := ContinuedFraction
tf := TableForm
p[-1] = 0; p[0] = 1; q[-1] = 1; q[0] = 0;
a[k_] := cf[Sqrt[31], k][[k]]
p[k_] := a[k]*p[k - 1] + p[k - 2]
q[k_] := a[k]*q[k - 1] + q[k - 2]
s[n_] := Timing[Table[{k, a[k], p[k], q[k]}, {k, 8, 8 n, 8}]] // tf
Timing increases exponentially fast. I had to alt+. (abort) for s[4].
Question: How to improve ( mathematica ) performance when dealing with recursive functions?
From a quick (not thorough, to admit it) look at your code, it looks like both p and q are defined recursively in terms of two previous values. This means that to calculate the nth value of p, ~2^n evaluations are needed (every step doubles the number). So yes, complexity is exponential, regardless of Mathematica or any other language being used.
If you insist on using a recursive formulation of the problem (e.g. for simplicity), then the simplest way to reduce the performance penalty is using memoization, i.e. doing something like
p[k_] := p[k] = a[k]*p[k - 1] + p[k - 2]
Don't forget to Clear[p] before any redefinition.
In short, memoization means having the function remember the computation result for each input, so subsequent evaluations are faster. It's very likely faster, but more complicated, to compute two values (p_(n+1) and p_(n)) from two previous values (p_(n) and p_(n-1)), then the complexity will be linear instead of exponential.
I hope this helps. I don't have Mathematica here to test right now.
Here is a small further refinement. Since this is a quadratic irrational you can also compute the a[k] coefficients more directly.
In[499]:= Clear[a, p, q, cf]
cf = ContinuedFraction[Sqrt[31]];
cf2len = Length[cf[[2]]];
a[1] = cf[[1]];
a[k_] := cf[[2, Mod[k - 1, cf2len, 1]]]
p[-1] = 0; p[0] = 1; q[-1] = 1; q[0] = 0;
p[k_] := p[k] = a[k]*p[k - 1] + p[k - 2]
q[k_] := q[k] = a[k]*q[k - 1] + q[k - 2]
s[n_] := Timing[Table[{k, a[k], p[k], q[k]}, {k, 8, 8 n, 8}];]
In[508]:= s[1000]
Out[508]= {0.12, Null}
In[509]:= Clear[a, p, q, cf]
cf := ContinuedFraction
p[-1] = 0; p[0] = 1; q[-1] = 1; q[0] = 0;
a[k_] := a[k] = cf[Sqrt[31], k][[k]]
p[k_] := p[k] = a[k]*p[k - 1] + p[k - 2]
q[k_] := q[k] = a[k]*q[k - 1] + q[k - 2]
s[n_] := Timing[Table[{k, a[k], p[k], q[k]}, {k, 8, 8 n, 8}];]
In[516]:= s[1000]
Out[516]= {6.08, Null}
Also you can get a[k] in closed form, though it is not terribly pretty.
In[586]:= Clear[a];
asoln[k_] =
FullSimplify[
a[k] /. First[
RSolve[Join[
Table[a[k] == cf[[2, Mod[k - 1, cf2len, 1]]], {k,
cf2len}], {a[k] == a[k - 8]}], a[k], k]], Assumptions -> k > 0]
Out[587]= (1/(8*Sqrt[2]))*(4*(Cos[(k*Pi)/4] + Sin[(k*Pi)/4])*
(-2*Sqrt[2] + (5 + 2*Sqrt[2])*Sin[(k*Pi)/2]) +
Sqrt[2]*(25 - 9*Cos[k*Pi] + 26*Sin[(k*Pi)/2] - 9*I*Sin[k*Pi]))
Offhand I do not know whether this can be used to get a direct solution for p[k] and q[k]. RSolve seems unable to do that.
--- edit ---
As others have mentioned, it can be cleaner to just build the list from first to last. Here is the handling of p[k], using memoization as above vs NestList.
Clear[a, p, q, cf]
cf = ContinuedFraction[Sqrt[31]];
cf2len = Length[cf[[2]]];
a[1] = cf[[1]];
a[k_] := cf[[2, Mod[k - 1, cf2len, 1]]]
p[-1] = 0; p[0] = 1;
p[k_] := p[k] = a[k]*p[k - 1] + p[k - 2]
s[n_] := Timing[Table[p[k], {k, n}];]
In[10]:= s[100000]
Out[10]= {1.64, Null}
In[153]:= s2[n_] := Timing[ll = Module[{k = 0},
NestList[(k++; {#[[2]], a[k]*#[[2]] + #[[1]]}) &, {0, 1},
n]][[All, 2]];]
In[154]:= s2[100000]
Out[154]= {0.78, Null}
In addition to being somewhat faster, this second approach does not keep a large number of definitions around. And you do not really need them in order to generate more elements, because this iteration can be resumed using a pair from the last elements (make sure they start at 0 and 1 modulo 8).
I will mention that one can obtain a closed form for p[k]. I found it convenient to break the solution into 8 (that is, cf2len) pieces and link them via recurrences. The reasoning behind the scenes comes from basic generating function manipulation. I did some slightly special handling of one equation and one initial condition to finesse the fact that a[1] is not part of the repeating sequence.
In[194]:= func = Array[f, cf2len];
args = Through[func[n]];
firsteqns = {f[2][n] == a[2]*f[1][n] + f[cf2len][n - 1],
f[1][n] == a[9]*f[cf2len][n - 1] + f[cf2len - 1][n - 1]};
resteqns =
Table[f[j][n] == a[j]*f[j - 1][n] + f[j - 2][n], {j, 3, cf2len}];
inits = {f[8][0] == 1, f[1][1] == 5};
eqns = Join[firsteqns, resteqns, inits];
In[200]:=
soln = FullSimplify[args /. First[RSolve[eqns, args, n]],
Assumptions -> n > 0];
In[201]:= FullSimplify[Table[soln, {n, 1, 3}]]
Out[201]= {{5, 6, 11, 39, 206, 657, 863, 1520}, {16063, 17583, 33646,
118521, 626251, 1997274, 2623525, 4620799}, {48831515, 53452314,
102283829, 360303801, 1903802834, 6071712303, 7975515137,
14047227440}}
Quick check:
In[167]:= s2[16]; ll
Out[167]= {1, 5, 6, 11, 39, 206, 657, 863, 1520, 16063, 17583, 33646, \
118521, 626251, 1997274, 2623525, 4620799}
We can now define a function from this.
In[165]:=
p2[k_Integer] := soln[[Mod[k, cf2len, 1]]] /. n -> Ceiling[k/cf2len]
In[166]:= Simplify[p2[4]]
Out[166]= 39
I do not claim that this is particularly useful, just wanted to see if I could actually get something to work.
--- end edit ---
Daniel Lichtblau
I'm trying to use Mathematica's NDSolve[] to compute a geodesic along a sphere using the coupled ODE:
x" - (x" . x) x = 0
The problem is that I can only enter initial conditions for x(0) and x'(0) and the solver is happy with the solution where x" = 0. The problem is that my geodesic on the sphere has the initial condition that x"(0) = -x(0), which I have no idea how to tell mathematica. If I add this as a condition, it says I'm adding True to the list of conditions.
Here is my code:
s1 = NDSolve[{x1''[t] - (x1[t] * x1''[t] + x2[t] * x2''[t] + x3[t]*x3''[t]) * x1[t] == 0, x2''[t] - (x1[t] * x1''[t] + x2[t] * x2''[t] + x3[t]*x3''[t]) * x2[t] == 0, x3''[t] - (x1[t] * x1''[t] + x2[t] * x2''[t] + x3[t]*x3''[t]) * x3[t] == 0, x1[0] == 1, x2[0] == 0, x3[0] == 0, x1'[0] == 0, x2'[0] == 0, x3'[0] == 1} , { x1, x2, x3}, {t, -1, 1}][[1]]
I would like to modify this so that the initial acceleration is not zero but -x(0).
Thanks
Well, as the error message says -- NDSolve only accepts initial conditions for derivatives of orders strictly less than the maximal order appearing in the ODE.
I have a feeling this is more of a mathematics question. Mathematically, {x''[0]=-x0, x[0]==x0}, doesn't define a unique solution - you'd have to do something along the lines of {x0.x''[0]==-1, x[0]==x0, x'[0]-x0 x0.x'[0]==v0} for that to work out (NDSolve would still fail with the same error). You do realize you will just get a great circle on the unit sphere, right?
By the way, here is how I would have coded up your example:
x[t_] = Table[Subscript[x, j][t], {j, 3}];
s1 = NDSolve[Flatten[Thread /# #] &#{
x''[t] - (x''[t].x[t]) x[t] == {0, 0, 0},
x[0] == {1, 0, 0},
x'[0] == {0, 0, 1}
}, x[t], {t, -1, 1}]
I fixed this problem through a mathematical rearrangement rather than addressing my original issue:
Let V(t) be a vector field along x(t).
x . V = 0 implies d/dt (x . V) = (x' . V) + (x . V') = 0
So the equation D/dt V = V' - (x . V') x = V' + (x' . V) x holds
This means the geodesic equation becomes: x" + (x' . x') x = 0 and so it can be solved using the initial conditions I originally had.
Thanks a lot Janus for going through and pointing out the various problems I was having including horrible code layout, I learnt a lot through your re-writing as well.