Related
This is my first time posting here. I would really appreciate some help with a question from my mathematica study guide. My question is:
Suppose that a drunk randomly steps either forward, backward, left, or right one unit many times. Create a list of coordinates {{x,y}..} representing his path and then display that path as a set of line segments for each step. [Hint: use NestList to create a list of coordinates, Partition to form a list of segments, map Line onto the segment list, and Show[Graphics[list]] to display the path.]
I have managed to successfully create the function:
Clear[x, n]
Randomwalk[n_] :=
NestList[(# + (-1)^Table[Random[Integer, {0, 1}], {2}]) &, Table[0, {2}], n];
Randomwalk[50]
I, however, need help with the second part, where I need to graph it. MY attempt at the second part is as follows:
Show[Graphics[Line[Randomwalk[50]]]]
and although it gives me a graph, it does not seem to be correct. I would really appreciate some help with this.
You could try the following function
RandomWalk[n_]:=Accumulate[{{1,0},{-1,0},{0,1},{0,-1}}[[RandomInteger[{1,4},n]]]]
where n is the number of steps to take. Plotting works as you wrote
Graphics[Line[RandomWalk[200]]]
However, plotting with colour shows how the walk progressed, as in
With[{n=100},
Graphics[MapIndexed[{Hue[#2[[1]]/(n + 10)], Line[#]} &,
Partition[RandomWalk[n], 2, 1]]]]
Instead of using [[RandomInteger[{1,4},n]]] to pick out the directions, you could use RandomChoice which is designed expressly for this type of operation:
RandomWalk[n_] := Accumulate[RandomChoice[{{1, 0}, {-1, 0}, {0, 1}, {0, -1}}, n]]
This gives about the same (maybe slightly faster) speed as the approach using Part and RandomInteger. But if you are working with large walks (n > 10^6, say), then you might want to squeeze some speed out by forcing the list of directions to be a packed array:
NSEWPacked = Developer`ToPackedArray[{{1, 0}, {-1, 0}, {0, 1}, {0, -1}}]
Then use the packed array:
RandomWalkPacked[n_] := Accumulate[RandomChoice[NSEWPacked, n]]
You should see about an order of magnitude speedup with this:
Timing[RandomWalkPacked[10^7];]
For details on packed arrays, see Developer/ref/ToPackedArray or chapter 12 on optimizing Mathematica programs in Programming with Mathematica: An Introduction.
I would like to write a Mathematica function that constructs a list of all Fibonacci numbers less than n. Moreover, I would like to do this as elegantly and functionally as possible(so without an explicit loop).
Conceptually I want to take an infinite list of the natural numbers, map Fib[n] onto it, and then take elements from this list while they are less than n. How can I do this in Mathematica?
The first part can be done fairly easily in Mathematica. Below, I provide two functions nextFibonacci, which provides the next Fibonacci number greater than the input number (just like NextPrime) and fibonacciList, which provides a list of all Fibonacci numbers less than the input number.
ClearAll[nextFibonacci, fibonacciList]
nextFibonacci[m_] := Fibonacci[
Block[{n},
NArgMax[{n, 1/Sqrt[5] (GoldenRatio^n - (-1)^n GoldenRatio^-n) <= m, n ∈ Integers}, n]
] + 1
]
nextFibonacci[1] := 2;
fibonacciList[m_] := Fibonacci#
Range[0, Block[{n},
NArgMax[{n, 1/Sqrt[5] (GoldenRatio^n - (-1)^n GoldenRatio^-n) < m, n ∈ Integers}, n]
]
]
Now you can do things like:
nextfibonacci[15]
(* 21 *)
fibonacciList[50]
(* {0, 1, 1, 2, 3, 5, 8, 13, 21, 34} *)
The second part though, is tricky. What you're looking for is a Haskell type lazy evaluation that will only evaluate if and when necessary (as otherwise, you can't hold an infinite list in memory). For example, something like (in Haskell):
fibs = 0 : 1 : zipWith (+) fibs (tail fibs)
which then allows you to do things like
take 10 fibs
-- [0,1,1,2,3,5,8,13,21,34]
takeWhile (<100) fibs
-- [0,1,1,2,3,5,8,13,21,34,55,89]
Unfortunately, there is no built-in support for what you want. However, you can extend Mathematica to implement lazy style lists as shown in this answer, which was also implemented as a package. Now that you have all the pieces that you need, I'll let you work on this yourself.
If you grab my Lazy package from GitHub, your solution is as simple as:
Needs["Lazy`"]
LazySource[Fibonacci] ~TakeWhile~ ((# < 1000) &) // List
If you want to slightly more literally implement your original description
Conceptually I want to take an infinite list of the natural numbers, map Fib[n] onto it, and then take elements from this list while they are less than n.
you could do it as follows:
Needs["Lazy`"]
Fibonacci ~Map~ Lazy[Integers] ~TakeWhile~ ((# < 1000) &) // List
To prove that this is completely lazy, try the previous example without the // List on the end. You'll see that it stops with the (rather ugly) form:
LazyList[First[
LazyList[Fibonacci[First[LazyList[1, LazySource[#1 &, 2]]]],
Fibonacci /# Rest[LazyList[1, LazySource[#1 &, 2]]]]],
TakeWhile[
Rest[LazyList[Fibonacci[First[LazyList[1, LazySource[#1 &, 2]]]],
Fibonacci /# Rest[LazyList[1, LazySource[#1 &, 2]]]]], #1 <
1000 &]]
This consists of a LazyList[] expression whose first element is the first value of the expression that you're lazily evaluating and whose second element is instructions for how to continue the expansion.
Improvements
It's a little bit inefficient to continually call Fibonacci[n] all the time, especially as n starts getting large. It's actually possible to construct a lazy generator that will calculate the current value of the Fibonacci sequence as we stream:
Needs["Lazy`"]
LazyFibonacci[a_,b_]:=LazyList[a,LazyFibonacci[b,a+b]]
LazyFibonacci[]:=LazyFibonacci[1,1]
LazyFibonacci[] ~TakeWhile~ ((# < 1000)&) // List
Finally, we could generalize this up to a more abstract generating function that takes an initial value for an accumulator, a List of Rules to compute the accumulator's value for the next step and a List of Rules to compute the result from the current accumulator value.
LazyGenerator[init_, step_, extract_] :=
LazyList[Evaluate[init /. extract],
LazyGenerator[init /. step, step, extract]]
And could use it to generate the Fibonacci sequence as follows:
LazyGenerator[{1, 1}, {a_, b_} :> {b, a + b}, {a_, b_} :> a]
Ok, I hope I understood the question. But please note, I am not pure math major, I am mechanical engineering student. But this sounded interesting. So I looked up the formula and this is what I can come up with now. I have to run, but if there is a bug, please let me know and I will fix it.
This manipulate asks for n and then lists all Fibonacci numbers less than n. There is no loop to find how many Fibonacci numbers there are less than n. It uses Reduce to solve for the number of Fibonacci numbers less than n. I take the floor of the result and also threw away a constant that came up with in the solution a complex multiplier.
And then simply makes a table of all these numbers using Mathematica Fibonacci command. So if you enter n=20 it will list 1,1,2,3,5,8,13 and so on. I could do it for infinity as I ran out of memory (I only have 8 GB ram on my pc).
I put the limit for n to 500000 Feel free to edit the code and change it.
Manipulate[
Module[{k, m},
k = Floor#N[Assuming[Element[m, Integers] && m > 0,
Reduce[f[m] == n, m]][[2, 1, 2]] /. Complex[0, 2] -> 0];
TableForm#Join[{{"#", "Fibonacci number" }},
Table[{i, Fibonacci[i]}, {i, 1, k}]]
],
{{n, 3, "n="}, 2, 500000, 1, Appearance -> "Labeled", ImageSize -> Small},
SynchronousUpdating -> False,
ContentSize -> {200, 500}, Initialization :>
{
\[CurlyPhi][n_] := ((1 + Sqrt[5])/2)^n;
\[Psi][n_] := -(1/\[CurlyPhi][n]);
f[n_] := (\[CurlyPhi][n] - \[Psi][n])/Sqrt[5];
}]
Screen shot
The index k of the Fibonacci number Fk is k=Floor[Log[GoldenRatio,Fk]*Sqrt[5]+1/2]],
https://en.wikipedia.org/wiki/Fibonacci_number. Hence, the list of Fibonacci numbers less than or equal to n is
FibList[n_Integer]:=Fibonacci[Range[Floor[Log[GoldenRatio,Sqrt[5]*n+1/2]]]]
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]]
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)
I know that using the Insert menu, you can create a matrix with vertical and horizontal lines, but not a more generic partition, such as dividing a 4x4 matrix into 4 2x2 partitions. Nor, can MatrixForm do any sort of partitioning. So, how would I go about programmatically displaying such a partitioned matrix? I would like to retain the ability of MatrixForm to act only as a wrapper and not affect subsequent evaluations, but it is not strictly necessary. I suspect this would involve using a Grid, but I haven't tried it.
After playing around for far too long trying to make Interpretation drop the displayed form and use the matrix when used in subsequent lines, I gave up and just made a wrapper that acts almost exactly like MatrixForm. This was really quick as it was a simple modification of this question.
Clear[pMatrixForm,pMatrixFormHelper]
pMatrixForm[mat_,col_Integer,row_:{}]:=pMatrixForm[mat,{col},row]
pMatrixForm[mat_,col_,row_Integer]:=pMatrixForm[mat,col,{row}]
pMatrixFormHelper[mat_,col_,row_]:=Interpretation[MatrixForm[
{Grid[mat,Dividers->{Thread[col->True],Thread[row->True]}]}],mat]
pMatrixForm[mat_?MatrixQ,col:{___Integer}:{},row:{___Integer}:{}]:=
(CellPrint[ExpressionCell[pMatrixFormHelper[mat,col,row],
"Output",CellLabel->StringJoin["Out[",ToString[$Line],"]//pMatrixForm="]]];
Unprotect[Out];Out[$Line]=mat;Protect[Out];mat;)
Then the postfix command //pMatrixForm[#, 3, 3]& will give the requested 2x2 partitioning of a 4x4 matrix. It maybe useful to change the defaults of pMatrixForm from no partitions to central partitions. This would not be hard.
So this is what I came up with. For a matrix M:
M = {{a, b, 0, 0}, {c, d, 0, 0}, {0, 0, x, y}, {0, 0, z, w}};
you construct two list of True/False values (with True for places where you want separators) that take two arguments; first the matrix and second a list of positions for separators.
colSep = Fold[ReplacePart[#1, #2 -> True] &,
Table[False, {First#Dimensions##1 + 1}], #2] &;
rowSep = Fold[ReplacePart[#1, #2 -> True] &,
Table[False, {Last#Dimensions##1 + 1}], #2] &;
Now the partitioned view using Grid[] is made with the use of Dividers:
partMatrix = Grid[#1, Dividers -> {colSep[#1, #2], rowSep[#1, #3]}] &;
This takes three arguments; first the matrix, second the list of positions for column dividers, and third the list of values for row dividers.
In order for it to display nicely you just wrap it in brakets and use MatrixForm:
MatrixForm#{partMatrix[M, {3}, {3}]}
Which does the 2by2 partitioning you mentioned.