Related
I derived a solution for a driven damped oscillator using the DSolve functionality of Wolfram Mathematica. I chose the following Ansatz:
DSolve[{
0 == -Fmax (1 - Cos[t]) + k x[t] +
d Derivative[1][x][t] +
m Derivative[2][x][t],
x[0] == xStart, x'[0] == vStart}, x[t], t]
Mathematica is able to solve this analytically and I can derive solutions if I pass parameters to the variables.
Anyhow, the derived solution fails at the moment, the given parameters for mass (m), spring constant (k) and dampening (d) fulfill the condition for aperiodic behavior
d=2*Sqrt[m*k]
due to the fact, that a division by zero occurs. The overall solution is given by a big fraction with a denominator containing the following factor
Sqrt[d^2 - 4 k m]
This factor becomes zero in case aperiodic conditions occur which leads to a devision by zero.
Now the fun starts ...
I case I pass the aperiodic conditions before giving the system to DSolve:
DSolve[{
0 == -Fmax (1 - Cos[t]) + k x[t] +
2 Sqrt[k m] Derivative[1][x][t] +
m Derivative[2][x][t],
x[0] == xStart, x'[0] == vStart}, x[t], t]
DSolve easily derives a working solution without dividing by zero.
It seems to me, as Mathematica is simplifying the more general solution, in a way that I can't use the aperiodic conditions anymore, even though there is a working solution for that case. My question is, can I somehow tell DSolve, to take into account the aperiodic conditions?
Sure, I can workaround the problem with Piecewise[], but for further calculations a general solution without Piecewise[] would be more suitable.
Thanks in advance for you time and help,
Greetings
Tschibi
I am a coding novice, attempting to use matlab to compute the sum of a madelung series expansion to a variable of my choice. I believe I have the basic theory down, but when I try to run my equation, matlab returns this error message:
Sum::vloc: The variable {j,4}\ {k,4} cannot be localized so that it can be assigned to numerical values.
Here's the code I'm trying to input:
M3 = -6 Sum[(-1)^j/j, {j, 4}]
-12 Sum[(-1)^(j + k)/(j^2 + k^2)^(1/2), {j, 4} {k, 4}]
-8 Sum[(-1)^(j + k + l)/(j^2 + k^2 + l^2)^(1/2), {j, 4} {k, 4} {l,4}]
The output is a fraction for the first sum, but the other two are in series notation with variables j and k. I would let get a single, real number output.
Any and all pointers are really appreciated! :)
PROBLEM RESOLVED!
I had carelessly forgot to place comas between the minimum and maximum terms of my separate variables. Thanks, all, for your consideration.
Given a set of numbers and a set of binary operations,
what is the fastest way to create random expression trees or exhaustively check every possible combination in Mathematica?
What I am trying to solve is given:
numbers={25,50,75,100,3,6} (* each can ONLY be used ONCE *)
operators={Plus,Subtract,Times,Divide} (* each can be used repeatedly *)
target=99
find expression trees that would evaluate to target.
I have two solutions whose performances I give for the case where expression trees contain exactly 4 of the numbers and 3 operators:
random sample & choice: ~25K trees / second
exhaustive scan: 806400 trees in ~2.15 seconds
(timed on a laptop with: Intel(R) Core(TM)2 Duo CPU T9300 # 2.50GHz, 3GB ram, no parallelization used yet but would be most welcome in answers)
My notebooks are a bit messy at the moment. So I would first love to pose the question and hope for original ideas and answers while I clean up my code for sharing.
Largest possible case is where every expression tree uses up all the (6) numbers and 'Length[numbers]-1' (5) operators.
Performance of methods in the largest case is:
random sample & choice: ~21K trees / second
exhaustive scan: 23224320 trees in ~100 seconds
Also I am using Mathematica 8.0.1 so I am more than all ears if there are any ways to do it in OpenCL or using compiled functions wiht CompilationTarget->"C", etc.
OK, this is not elegant or fast, and it's buggy, but it works (sometimes). It uses a monte carlo method, implementing the metropolis algorithm for a weight function that I (arbitrarily) selected just to see if this would work. This was some time ago for a similar problem; I suppose my mathematica skills have improved as it looks ugly now, but I have no time to fix it at the moment.
Execute this (it looks more reasonable when you paste it into a notebook):
ClearAll[swap];
swap[lst_, {p1_, p2_}] :=
ReplacePart[
lst, {p1 \[Rule] lst\[LeftDoubleBracket]p2\[RightDoubleBracket],
p2 \[Rule] lst\[LeftDoubleBracket]p1\[RightDoubleBracket]}]
ClearAll[evalops];
(*first element of opslst is Identity*)
evalops[opslst_, ord_, nums_] :=
Module[{curval}, curval = First#nums;
Do[curval =
opslst\[LeftDoubleBracket]p\[RightDoubleBracket][curval,
nums\[LeftDoubleBracket]ord\[LeftDoubleBracket]p\
\[RightDoubleBracket]\[RightDoubleBracket]], {p, 2, Length#nums}];
curval]
ClearAll[randomizeOrder];
randomizeOrder[ordlst_] :=
swap[ordlst, RandomInteger[{1, Length#ordlst}, 2]]
ClearAll[randomizeOps];
(*never touch the first element*)
randomizeOps[oplst_, allowedOps_] :=
ReplacePart[
oplst, {RandomInteger[{2, Length#oplst}] \[Rule] RandomChoice[ops]}]
ClearAll[takeMCstep];
takeMCstep[goal_, opslst_, ord_, nums_, allowedops_] :=
Module[{curres, newres, newops, neword, p},
curres = evalops[opslst, ord, nums];
newops = randomizeOps[opslst, allowedops];
neword = randomizeOrder[ord];
newres = evalops[newops, neword, nums];
Switch[Abs[newres - goal],
0, {newops,
neword}, _, (p = Abs[curres - goal]/Abs[newres - goal];
If[RandomReal[] < p, {newops, neword}, {opslst, ord}])]]
then to solve your actual problem, do
ops = {Times, Plus, Subtract, Divide}
nums = {25, 50, 75, 100, 3, 6}
ord = Range[Length#nums]
(*the first element is identity to simplify the logic later*)
oplist = {Identity}~Join~RandomChoice[ops, Length#nums - 1]
out = NestList[
takeMCstep[
99, #\[LeftDoubleBracket]1\[RightDoubleBracket], #\
\[LeftDoubleBracket]2\[RightDoubleBracket], nums, ops] &, {oplist,
ord}, 10000]
and then to see that it worked,
ev = Map[evalops[#\[LeftDoubleBracket]1\[RightDoubleBracket], #\
\[LeftDoubleBracket]2\[RightDoubleBracket], nums] &, out];
ev // Last // N
ev // ListPlot[#, PlotMarkers \[Rule] None] &
giving
thus, it obtained the correct order of operators and numbers after around 2000 tries.
As I said, it's ugly, inefficient, and badly programmed as it was a quick-and-dirty adaptation of a quick-and-dirty hack. If you're interested I can clean up and explain the code.
This was a fun question. Here's my full solution:
ExprEval[nums_, ops_] := Fold[
#2[[1]][#1, #2[[2]]] &,
First#nums,
Transpose[{ops, Rest#nums}]]
SymbolicEval[nums_, ops_] := ExprEval[nums, ToString /# ops]
GetExpression[nums_, ops_, target_] := Select[
Tuples[ops, Length#nums - 1],
(target == ExprEval[nums, #]) &]
Usage example:
nums = {-1, 1, 2, 3};
ops = {Plus, Subtract, Times, Divide};
solutions = GetExpression[nums, ops, 3]
ExprEval[nums, #] & /# solutions
SymbolicEval[nums, #] & /# solutions
Outputs:
{{Plus, Times, Plus}, {Plus, Divide, Plus}, {Subtract, Plus,
Plus}, {Times, Plus, Times}, {Divide, Plus, Times}}
{3, 3, 3, 3, 3}
{"Plus"["Times"["Plus"[-1, 1], 2], 3],
"Plus"["Divide"["Plus"[-1, 1], 2], 3],
"Plus"["Plus"["Subtract"[-1, 1], 2], 3],
"Times"["Plus"["Times"[-1, 1], 2], 3],
"Times"["Plus"["Divide"[-1, 1], 2], 3]}
How it works
The ExprEval function takes in the numbers and operations, and applies them using (I think) RPN:
ExprEval[{1, 2, 3}, {Plus, Times}] == (1 + 2) * 3
It does this by continually folding pairs of numbers using the appropriate operation.
Now that I have a way to evaluate an expression tree, I just needed to generate them. Using Tuples, I'm able to generate all the different operators that I would intersperse between the numbers.
Once you get all possible operations, I used Select to pick out the the ones that evaluate to the target number.
Drawbacks
The solution above is really slow. Generating all the possible tuples is exponential in time. If there are k operations and n numbers, it's on the order of O(k^n).
For n = 10, it took 6 seconds to complete on Win 7 x64, Core i7 860, 12 GB RAM. The timings of the runs match the theoretical time complexity almost exactly:
Red line is the theoretical, blue is experimental. The x-axis is size of the nums input and the y-axis is the time in seconds to enumerate all solutions.
The above solution also solves the problem using a functional programming style. It looks pretty, but the thing also sucks up a butt ton of memory since it's storing the full results at nearly every step.
It doesn't even make use of parallelization, and I'm not entirely certain how you would even parallelize the solution I produced.
Some limitations
Mr. Wizard brought to my attention that this code only solves for only particular set of solutions. Given some input such as {a, b, c, d, e, ... } it only permutes the operators in between the numbers. It doesn't permute the ordering of the numbers. If it were to permute the numbers as well, the time complexity would rise up to O(k^n * n!) where k is the number of operators and n is the length of the input number array.
The following will produce the set of solutions for any permutation of the input numbers and operators:
(* generates a lists of the form
{
{number permutation, {{op order 1}, {op order 2}, ... }
}, ...
}*)
GetAllExpressions[nums_, ops_, target_] :=
ParallelMap[{#, GetExpression[#, ops, target]} &,
Tuples[nums, Length#nums]]
The problem:
I am trying to solve this diffrential equation:
K[x_, x1_] := 1;
NDSolve[{A''[x] == Integrate[K[x, x1] A[x1], {x1, 0, 1}],
A[0] == 0, A'[1] == 1}, A[x], x]
and I'm getting errors (Function::slotn and NDSolve::ndnum)
(it should return a numeric function that is equal to 3/16 x^2 + 5/8 x)
I am looking for a way to solve this differential equation: Is there a way to write it in a better form, such that NDSolve will understand it? Is there another function or package that can help?
Note 1: In my full problem, K[x, x1] is not 1 -- it depends (in a complex way) on x and x1.
Note 2: Naively deriving the two sides of the equation with respect to x won't work, because the integral limits are definite.
My first impression:
It seems that Mathematica doesn't like me referencing a point in A[x] -- the same errors occur when I'm doing this simplified version:
NDSolve[{A''[x] == A[0.5], A[0] == 0, A'[1] == 1}, A[x], x]
(it should return a numeric function that is equal to 2/11 x^2 + 7/11 x)
In this case one can avoid this problem by analytically solving A''[x] == c, and then finding c, but in my first problem it seems to not work -- it only transform the differential equation to an integral one, which (N)DSolve doesn't solve afterwards.
I can suggest a way to reduce your equation to an integral equation, which can be solved numerically by approximating its kernel with a matrix, thereby reducing the integration to matrix multiplication.
First, it is clear that the equation can be integrated twice over x, first from 1 to x, and then from 0 to x, so that:
We can now discretize this equation, putting it on a equidistant grid:
Here, the A[x] becomes a vector, and the integrated kernel iniIntK becomes a matrix, while integration is replaced by a matrix multiplication. The problem is then reduced to a system of linear equations.
The easiest case (that I will consider here) is when the kernel iniIntK can be derived analytically - in this case this method will be quite fast. Here is the function to produce the integrated kernel as a pure function:
Clear[computeDoubleIntK]
computeDoubleIntK[kernelF_] :=
Block[{x, x1},
Function[
Evaluate[
Integrate[
Integrate[kernelF[y, x1], {y, 1, x}] /. x -> y, {y, 0, x}] /.
{x -> #1, x1 -> #2}]]];
In our case:
In[99]:= K[x_,x1_]:=1;
In[100]:= kernel = computeDoubleIntK[K]
Out[100]= -#1+#1^2/2&
Here is the function to produce the kernel matrix and the r.h,s vector:
computeDiscreteKernelMatrixAndRHS[intkernel_, a0_, aprime1_ ,
delta_, interval : {_, _}] :=
Module[{grid, rhs, matrix},
grid = Range[Sequence ## interval, delta];
rhs = a0 + aprime1*grid; (* constant plus a linear term *)
matrix =
IdentityMatrix[Length[grid]] - delta*Outer[intkernel, grid, grid];
{matrix, rhs}]
To give a very rough idea how this may look like (I use here delta = 1/2):
In[101]:= computeDiscreteKernelMatrixAndRHS[kernel,0,1,1/2,{0,1}]
Out[101]= {{{1,0,0},{3/16,19/16,3/16},{1/4,1/4,5/4}},{0,1/2,1}}
We now need to solve the linear equation, and interpolate the result, which is done by the following function:
Clear[computeSolution];
computeSolution[intkernel_, a0_, aprime1_ , delta_, interval : {_, _}] :=
With[{grid = Range[Sequence ## interval, delta]},
Interpolation#Transpose[{
grid,
LinearSolve ##
computeDiscreteKernelMatrixAndRHS[intkernel, a0, aprime1, delta,interval]
}]]
Here I will call it with a delta = 0.1:
In[90]:= solA = computeSolution[kernel,0,1,0.1,{0,1}]
Out[90]= InterpolatingFunction[{{0.,1.}},<>]
We now plot the result vs. the exact analytical solution found by #Sasha, as well as the error:
I intentionally chose delta large enough so the errors are visible. If you chose delta say 0.01, the plots will be visually identical. Of course, the price of taking smaller delta is the need to produce and solve larger matrices.
For kernels that can be obtained analytically, the main bottleneck will be in the LinearSolve, but in practice it is pretty fast (for matrices not too large). When kernels can not be integrated analytically, the main bottleneck will be in computing the kernel in many points (matrix creation. The matrix inverse has a larger asymptotic complexity, but this will start play a role for really large matrices - which are not necessary in this approach, since it can be combined with an iterative one - see below). You will typically define:
intK[x_?NumericQ, x1_?NumericQ] := NIntegrate[K[y, x1], {y, 1, x}]
intIntK[x_?NumericQ, x1_?NumericQ] := NIntegrate[intK[z, x1], {z, 0, x}]
As a way to speed it up in such cases, you can precompute the kernel intK on a grid and then interpolate, and the same for intIntK. This will however introduce additional errors, which you'll have to estimate (account for).
The grid itself needs not be equidistant (I just used it for simplicity), but may (and probably should) be adaptive, and generally non-uniform.
As a final illustration, consider an equation with a non-trivial but symbolically integrable kernel:
In[146]:= sinkern = computeDoubleIntK[50*Sin[Pi/2*(#1-#2)]&]
Out[146]= (100 (2 Sin[1/2 \[Pi] (-#1+#2)]+Sin[(\[Pi] #2)/2]
(-2+\[Pi] #1)))/\[Pi]^2&
In[157]:= solSin = computeSolution[sinkern,0,1,0.01,{0,1}]
Out[157]= InterpolatingFunction[{{0.,1.}},<>]
Here are some checks:
In[163]:= Chop[{solSin[0],solSin'[1]}]
Out[163]= {0,1.}
In[153]:=
diff[x_?NumericQ]:=
solSin''[x] - NIntegrate[50*Sin[Pi/2*(#1-#2)]&[x,x1]*solSin[x1],{x1,0,1}];
In[162]:= diff/#Range[0,1,0.1]
Out[162]= {-0.0675775,-0.0654974,-0.0632056,-0.0593575,-0.0540479,-0.0474074,
-0.0395995,-0.0308166,-0.0212749,-0.0112093,0.000369261}
To conclude, I just want to stress that one has to perform a careful error - estimation analysis for this method, which I did not do.
EDIT
You can also use this method to get the initial approximate solution, and then iteratively improve it using FixedPoint or other means - in this way you will have a relatively fast convergence and will be able to reach the required precision without the need to construct and solve huge matrices.
This is complementary to Leonid Shifrin's approach. We start with a linear function that interpolates the value and first derivative at the starting point. We use that in the integration with the given kernel function. We can then iterate, using each previous approximation in the integrated kernel that is used to make the next approximation.
I show an example below, using a more complicated kernel than just a constant function. I'll take it through two iterations and show tables of discrepancies.
kernel[x_, y_] := Sqrt[x]/(y^2 + 1/5)*Sin[x^2 + y]
intkern[x_?NumericQ, aa_] :=
NIntegrate[kernel[x, y]*aa[y], {y, 0, 1}, MinRecursion -> 2,
AccuracyGoal -> 3]
Clear[a];
a0 = 0;
a1 = 1;
a[0][x_] := a0 + a1*x
soln1 = a[1][x] /.
First[NDSolve[{(a[1]^\[Prime]\[Prime])[x] == intkern[x, a[0], y],
a[1][0] == a0, a[1][1] == a1}, a[1][x], {x, 0, 1}]];
a[1][x_] = soln1;
In[283]:= Table[a[1]''[x] - intkern[x, a[1]], {x, 0., 1, .1}]
Out[283]= {4.336808689942018*10^-19, 0.01145100326794241, \
0.01721655945379122, 0.02313249302884235, 0.02990900241909161, \
0.03778448183557359, 0.04676409320217928, 0.05657128568058478, \
0.06665818935524814, 0.07624149919589895, 0.08412643746245929}
In[285]:=
soln2 = a[2][x] /.
First[NDSolve[{(a[2]^\[Prime]\[Prime])[x] == intkern[x, a[1]],
a[2][0] == a0, a[2][1] == a1}, a[2][x], {x, 0, 1}]];
a[2][x_] = soln2;
In[287]:= Table[a[2]''[x] - intkern[x, a[2]], {x, 0., 1, .1}]
Out[287]= {-2.168404344971009*10^-19, -0.001009606971360516, \
-0.00152476679745811, -0.002045817184941901, -0.002645356229312557, \
-0.003343218015068372, -0.004121109614310836, -0.004977453722712966, \
-0.005846840469889258, -0.006731367269472544, -0.007404971586975062}
So we have errors of less than .01 at this stage. Not too bad. One drawback is that it was fairly slow to get the second approximation. There may be ways to tune NDSolve to improve on that.
This is complementary to Leonid's method for two reasons.
(1) If this did not converge well because the initial linear approximation was not sufficiently close to the true result, one might instead begin with an approximation found by a finite differencing scheme. That would be akin to what he did.
(2) He pretty much indicated this himself, as a method that might follow his and produce refinements.
Daniel Lichtblau
The way your equation is currently written A''[x] == const, and than constant is independent of x. Hence the solution always has the form of quadratic polynomial. Your problem then reduces to a solving for indeterminate coefficients:
In[13]:= A[x_] := a2 x^2 + a1 x + a0;
In[14]:= K[x_, x1_] := 1;
In[16]:= Solve[{A''[x] == Integrate[K[x, x1] A[x1], {x1, 0, 1}],
A[0] == 0, A'[1] == 1}, {a2, a1, a0}]
Out[16]= {{a2 -> 3/16, a1 -> 5/8, a0 -> 0}}
In[17]:= A[x] /. First[%]
Out[17]= (5 x)/8 + (3 x^2)/16
I have a linear recurrence problem where the next element relies on more than just the prior value, e.g. the Fibonacci sequence. One method calculating the nth element is to define it via a function call, e.g.
Fibonacci[0] = 0; Fibonacci[1] = 1;
Fibonacci[n_Integer?Positive] := Fibonacci[n] + Fibonacci[n - 1]
and for the sequence I'm working with, that is exactly what I do. (The definition is inside of a Module so I don't pollute Global`.) However, I am going to be using this with 210 - 213 points, so I'm concerned about the extra overhead when I just need the last term and none of the prior elements. I'd like to use Fold to do this, but Fold only passes the immediately prior result which means it is not directly useful for a general linear recurrence problem.
I'd like a pair of functions to replace Fold and FoldList that pass a specified number of prior sequence elements to the function, i.e.
In[1] := MultiFoldList[f, {1,2}, {3,4,5}] (* for lack of a better name *)
Out[1]:= {1, 2, f[3,2,1], f[4,f[3,2,1],2], f[5,f[4,f[3,2,1],2],f[3,2,1]]}
I had something that did this, but I closed the notebook prior to saving it. So, if I rewrite it on my own, I'll post it.
Edit: as to why I am not using RSolve or MatrixPower to solve this. My specific problem is I'm performing an n-point Pade approximant to analytically continue a function I only know at a set number of points on the imaginary axis, {zi}. Part of creating the approximant is to generate a set of coefficients, ai, which is another recurrence relation, that are then fed into the final relationship
A[n+1]== A[n] + (z - z[[n]]) a[[n+1]] A[n-1]
which is not amenable to either RSolve nor MatrixPower, at least that I can see.
Can RecurrenceTable perform this task for you?
Find the 1000th term in a recurrence depending on two previous values:
In[1]:= RecurrenceTable[{a[n] == a[n - 1] + a[n - 2],
a[1] == a[2] == 1}, a,
{n, {1000}}]
Out[1]= {4346655768693745643568852767504062580256466051737178040248172\
9089536555417949051890403879840079255169295922593080322634775209689623\
2398733224711616429964409065331879382989696499285160037044761377951668\
49228875}
Edit: If your recurrence is defined by a function f[m, n] that doesn't like to get evaluated for non-numeric m and n, then you could use Condition:
In[2]:= f[m_, n_] /; IntegerQ[m] && IntegerQ[n] := m + n
The recurrence table in terms of f:
In[3]:= RecurrenceTable[{a[n] == f[a[n - 1], a[n - 2]],
a[1] == a[2] == 1}, a, {n, {1000}}]
Out[3]= {4346655768693745643568852767504062580256466051737178040248172\
9089536555417949051890403879840079255169295922593080322634775209689623\
2398733224711616429964409065331879382989696499285160037044761377951668\
49228875}
A multiple foldlist can be useful but it would not be an efficient way to get linear recurrences evaluated for large inputs. A couple of alternatives are to use RSolve or matrix powers times a vector of initial values.
Here are these methods applied to example if nth term equal to n-1 term plus two times n-2 term.
f[n_] = f[n] /. RSolve[{f[n] == f[n - 1] + 2*f[n - 2], f[1] == 1, f[2] == 1},
f[n], n][[1]]
Out[67]= 1/3 (-(-1)^n + 2^n)
f2[n_Integer] := Last[MatrixPower[{{0, 1}, {2, 1}}, n - 2].{1, 1}]
{f[11], f2[11]}
Out[79]= {683, 683}
Daniel Lichtblau
Wolfram Research
Almost a convoluted joke, but you could use a side-effect of NestWhileList
fibo[n_] :=
Module[{i = 1, s = 1},
NestWhileList[ s &, 1, (s = Total[{##}]; ++i < n) &, 2]];
Not too bad performance:
In[153]:= First#Timing#fibo[10000]
Out[153]= 0.235
By changing the last 2 by any integer you may pass the last k results to your function (in this case Total[]).
LinearRecurrence and RecurrenceTable are very useful.
For small kernels, the MatrixPower method that Daniel gave is the fastest.
For some problems these may not be applicable, and you may need to roll your own.
I will be using Nest because I believe that is appropriate for this problem, but a similar construct can be used with Fold.
A specific example, the Fibonacci sequence. This may not be the cleanest possible for that, but I believe you will see the utility as I continue.
fib[n_] :=
First#Nest[{##2, # + #2} & ## # &, {1, 1}, n - 1]
fib[15]
Fibonacci[15]
Here I use Apply (##) so that I can address elements with #, #2, etc., rathern than #[[1]] etc. I use SlotSequence to drop the first element from the old list, and Sequence it into the new list at the same time.
If you are going to operate on the entire list at once, then a simple Append[Rest##, ... may be better. Either method can be easily generalized. For example, a simple linear recurrence implementation is
lr[a_, b_, n_Integer] := First#Nest[Append[Rest##, a.#] &, b, n - 1]
lr[{1,1}, {1,1}, 15]
(the kernel is in reverse order from the built in LinearRecurrence)