How do I loop this?
p = Table[RandomChoice[{Heads, Tails}, 2 i + 1], {i, 10}];
v = Count[#, Heads] & /# p;
c = Count[#, Tails] & /# p;
f = Abs[v - c];
g = Take[f, LengthWhile[f, # != 3 &] + 1]
Thanks!
EDIT
In this coin flipping game the rules are as follows :
A single play consists of repeatedly
flipping a fair coin until the
difference between the number of
heads tossed and the number of tails
is three.
You must pay $1 each time the coin is
flipped, and you may not quit during
the play of the game.
You receive $8 at the end of each
play of the game.
Should you play this game?
How much might you expect to win or
lose after 500 plays?
You may use a spreadsheet simulation and/or reasoning about probabilities to answer these questions.
The class is using Excel, I'm trying to learn Mathematica.
A little bit more on the theoretical side
Your game is a random walk on R1.
As such, the expectancy value for the number of flips to get a distance of 3 is 32=9, and that is also the expectancy value for your cost.
As your earning per game is $8, you'll lose at a mean rate of $1 per game.
Note that these figures are consistent with #Mr. Wizard's result of 135108 - 120000 = 15108 for 15000 games.
If I understand the rules of the coin flipping game, and if you must use a Monte Carlo method, consider this:
count =
Table[
i = x = 0;
While[Abs[x] < 3, x += RandomChoice[{1, -1}]; i++];
i,
{15000}
];
The idea is to flip a coin until one person is winning by three, and then output the number of turns it took to get there. Do this 15,000 times, and create a list of the results (count).
The money you spent to play 15,000 games is simply the number of turns that were played, or:
Total # count
(* Out= 135108 *)
While your winnings are $8 * 15,000 = $120,000, so this is not a good game to play.
If you need to count the number of times each number of turns comes up, then:
Sort # Tally # count
Not sure if this is the best way to accomplish what you want, but this should get you started. First, note that I changed the names Heads and Tails to lowercase (Heads is a built-in symbol...)---lowercase variable names are the best way to avoid this type of problem.
Remove[p, v, c, fun, f, g, head, tail];
fun[n_] :=
Do[
Block[
{p, v, c, f, g},
p = Table[RandomChoice[{head, tail}, 2 i + 1], {i, 10}];
v = Count[#, head] & /# p;
c = Count[#, tail] & /# p;
f = Abs[v - c];
g = Print[Take[f, LengthWhile[f, # != 3 &] + 1]]
],
{n}]
Simply enter the number of times you want to run the loop... fun[5] gives:
{1,1,1,1,5,3}
{3}
{1,1,5,1,5,1,3}
{3}
{1,5,3}
Note: because you'll probably want to do something with the output, using Table[] is probably better than Do[]. This will return a list of lists.
Remove[p, v, c, fun, f, g, head, tail];
fun[n_] :=
Table[
Block[
{p, v, c, f, g},
p = Table[RandomChoice[{head, tail}, 2 i + 1], {i, 10}];
v = Count[#, head] & /# p;
c = Count[#, tail] & /# p;
f = Abs[v - c];
g = Take[f, LengthWhile[f, # != 3 &] + 1]
],
{n}]
Nothing fancy!
A little more Mathematica-ish. No vars defined.
g[n_] := Table[(Abs /# Total /#
Array[RandomChoice[{-1, 1}, (2 # + 1)] &, 10]) /.
{x___, 3, ___} :> {x, 3},
{n}]
Credit to #Mr.Wizard for this answer.
g[2]
->{{1, 1, 1, 5, 5, 1, 5, 7, 3}, {1, 3}}
I don't like bitching about RTFM etc. but looping is pretty basic. If I type "loop" in the search box in the documentation center one of the first few hits contains a link to the page "guide/LoopingConstructs" and this contains a link to the tutorial "tutorial/LoopsAndControlStructures". Have you read these?
Related
My aim is to create a lot of functions f_i in a loop. These functions depend on parameters a[[i]], which can be taken from array A = {a1, a2, ...}. In order to eliminate the influence of the interator i, which leads to the situation when all functions are the same, I aspire to create variable names for each iteration.
The example: suppose I have got the array W = {1,2,3, ..., 100} and I should create variables w1 = 1, w2 = 2, ..., w100 = 100. I am trying to do this with the help of a for-loop:
loc[expr1_, expr2_] :=
ToExpression[StringJoin[ToString[expr1], ToString[expr2]]];
For[i = 1, i <= 100, i++,
{
loc[w, i] = W[[i]];
}]
When I need to see which value variable wk contains, then wk is not defined. But loc[w, k] = k is known.
How can I define variables wi? Or is there another way to create functions in a loop?
Thanks in advance
The way you are using {} leads me to believe that you have prior experience with other programming languages.
Mathematica is a very different language and some of what you know and expect will be wrong. Mathematica only uses {} to mean that is a list of elements. It is not used to group blocks of code. ; is more often used to group blocks of code.
Next, try
W={1,2,3};
For[i=i,i<=3,i++,
ToExpression["w"<>ToString[i]<>"="<>ToString[i]]
];
w2
and see that that returns
2
I understand that there is an intense desire in people who have been trained in other programming languages to use For to accomplish things. There are other ways o doing that for most purposes in Mathematica.
For one simple example
W={1,2,3};
Map[ToExpression["z"<>ToString[#]<>"="<>ToString[#]]&,W];
z2
returns
2
where I used z instead of w just to be certain that it wasn't showing me a prior cached value of w2
You can even do things like
W={1,2,3};
loc[n_,v_]:=ToExpression[ToString[n]<>ToString[v]<>"="<>ToString[v]];
Map[loc[a,#]&,W];
a3
which returns
3
Ordinarily, you will use indexed variables for this. E.g.,
ClearAll[x, xs]
n = 4
xs = Array[Indexed[x, #] &, 4]
Example use with random data:
RandomSeed[314]
mA = RandomInteger[{0, 99}, {n, n}]
vb = RandomInteger[{0, 99}, n]
Solve[mA.xs == vb, xs]
This is just for illustration; one would ordinarily use LinearSolve for the example problem. E.g., MapThread[Rule, {xs, LinearSolve[mA, vb]}].
It would be simpler to use a function variable, e.g. w[1], but here is a method to define w1 etc.
Note Clear can clear assignments using string versions of the symbols.
W = {1, 2, 7, 9};
Clear ## Map["w" <> ToString[#] &, W]
Map[(Evaluate[Symbol["w" <> ToString[#]]] = #) &, W];
w9
9
Symbol /# Map["w" <> ToString[#] &, W]
{1, 2, 7, 9}
Alternatively, with a function variable . . .
Map[(w[#] = #) &, W]
{1, 2, 7, 9}
w[9]
9
Also, using the OP's structure
Clear[loc]
Clear[w]
Clear ## Map["w" <> ToString[#] &, W]
W = {1, 2, 3, 4};
loc[expr1_, expr2_] := StringJoin[ToString[expr1], ToString[expr2]]
For[i = 1, i <= 4, i++, Evaluate[Symbol[loc[w, i]]] = W[[i]]]
Symbol /# Map["w" <> ToString[#] &, W]
{1, 2, 3, 4}
Note Evaluate[Symbol[loc[w, i]]] = W[[i]]] has the advantage that if the data at W[[i]] is a string it does not get transformed as it would by using ToExpression.
This is a fun little problem, and I wanted to check with the experts here if there is a better functional/Mathematica way to approach solving it than what I did. I am not too happy with my solution since I use big IF THEN ELSE in it, but could not find a Mathematica command to use easily to do it (such as Select, Cases, Sow/Reap, Map.. etc...)
Here is the problem, given a list values (numbers or symbols), but for simplicity, lets assume a list of numbers for now. The list can contain zeros and the goal is replace the each zero with the element seen before it.
At the end, the list should contain no zeros in it.
Here is an example, given
a = {1, 0, 0, -1, 0, 0, 5, 0};
the result should be
a = {1, 1, 1, -1, -1, -1, 5, 5}
It should ofcourse be done in the most efficient way.
This is what I could come up with
Scan[(a[[#]] = If[a[[#]] == 0, a[[#-1]], a[[#]]]) &, Range[2, Length[a]]];
I wanted to see if I can use Sow/Reap on this, but did not know how.
question: can this be solved in a more functional/Mathematica way? The shorter the better ofcourse :)
update 1
Thanks everyone for the answer, all are very good to learn from. This is the result of speed test, on V 8.04, using windows 7, 4 GB Ram, intel 930 #2.8 Ghz:
I've tested the methods given for n from 100,000 to 4 million. The ReplaceRepeated method does not do well for large lists.
update 2
Removed earlier result that was shown above in update1 due to my error in copying one of the tests.
The updated results are below. Leonid method is the fastest. Congratulation Leonid. A very fast method.
The test program is the following:
(*version 2.0 *)
runTests[sizeOfList_?(IntegerQ[#] && Positive[#] &)] :=
Module[{tests, lst, result, nasser, daniel, heike, leonid, andrei,
sjoerd, i, names},
nasser[lst_List] := Module[{a = lst},
Scan[(a[[#]] = If[a[[#]] == 0, a[[# - 1]], a[[#]]]) &,
Range[2, Length[a]]]
];
daniel[lst_List] := Module[{replaceWithPrior},
replaceWithPrior[ll_, n_: 0] :=
Module[{prev}, Map[If[# == 0, prev, prev = #] &, ll]
];
replaceWithPrior[lst]
];
heike[lst_List] := Flatten[Accumulate /# Split[lst, (#2 == 0) &]];
andrei[lst_List] := Module[{x, y, z},
ReplaceRepeated[lst, {x___, y_, 0, z___} :> {x, y, y, z},
MaxIterations -> Infinity]
];
leonid[lst_List] :=
FoldList[If[#2 == 0, #1, #2] &, First##, Rest##] & #lst;
sjoerd[lst_List] :=
FixedPoint[(1 - Unitize[#]) RotateRight[#] + # &, lst];
lst = RandomChoice[Join[ConstantArray[0, 10], Range[-1, 5]],
sizeOfList];
tests = {nasser, daniel, heike, leonid, sjoerd};
names = {"Nasser","Daniel", "Heike", "Leonid", "Sjoerd"};
result = Table[0, {Length[tests]}, {2}];
Do[
result[[i, 1]] = names[[i]];
Block[{j, r = Table[0, {5}]},
Do[
r[[j]] = First#Timing[tests[[i]][lst]], {j, 1, 5}
];
result[[i, 2]] = Mean[r]
],
{i, 1, Length[tests]}
];
result
]
To run the tests for length 1000 the command is:
Grid[runTests[1000], Frame -> All]
Thanks everyone for the answers.
Much (order of magnitude) faster than other solutions still:
FoldList[If[#2 == 0, #1, #2] &, First##, Rest##] &
The speedup is due to Fold autocompiling. Will not be so dramatic for non-packed arrays. Benchmarks:
In[594]:=
a=b=c=RandomChoice[Join[ConstantArray[0,10],Range[-1,5]],150000];
(b=Flatten[Accumulate/#Split[b,(#2==0)&]]);//Timing
Scan[(a[[#]]=If[a[[#]]==0,a[[#-1]],a[[#]]])&,Range[2,Length[a]]]//Timing
(c=FoldList[If[#2==0,#1,#2]&,First##,Rest##]&#c);//Timing
SameQ[a,b,c]
Out[595]= {0.187,Null}
Out[596]= {0.625,Null}
Out[597]= {0.016,Null}
Out[598]= True
This seems to be a factor 4 faster on my machine:
a = Flatten[Accumulate /# Split[a, (#2 == 0) &]]
The timings I get are
a = b = RandomChoice[Join[ConstantArray[0, 10], Range[-1, 5]], 10000];
(b = Flatten[Accumulate /# Split[b, (#2 == 0) &]]); // Timing
Scan[(a[[#]] = If[a[[#]] == 0, a[[# - 1]], a[[#]]]) &,
Range[2, Length[a]]] // Timing
SameQ[a, b]
(* {0.015815, Null} *)
(* {0.061929, Null} *)
(* True *)
FixedPoint[(1 - Unitize[#]) RotateRight[#] + # &, d]
is about 10 and 2 times faster than Heike's solutions but slower than Leonid's.
You question looks exactly like a task for ReplaceRepeated function. What it does basically is that it applies the same set of rules to the expression until no more rules are applicable. In your case the expression is a list, and the rule is to replace 0 with its predecessor whenever occurs in a list. So here is the solution:
a = {1, 0, 0, -1, 0, 0, 5, 0};
a //. {x___, y_, 0, z___} -> {x, y, y, z};
The pattern for the rule here is the following:
x___ - any symbol, zero or more repetitions, the beginning of the list
y_ - exactly one element before zero
0 - zero itself, this element will be replaced with y later
z___ - any symbol, zero or more repetitions, the end of the list
I would like to get a List (ideally a set -- discarding repetition -- but assuming there's no direct way to do this I'll just use Union) of the leaves from a given expression.
For example, the expression
ArcTan[(-1 + 2*x)/Sqrt[3]]/Sqrt[3]
has a LeafCount of 18:
-1 (3)
2 (3)
3 (2)
x
ArcTan
Plus
Power (2)
Rational (2)
Times (3)
so I would like something like
{-1, 2, 3, x, ArcTan, Plus, Power, Rational, Times}
Actually, I really just want the functions so
{ArcTan, Plus, Power, Rational, Times}
would be ideal -- but presumably there's some not-too-difficult way to filter these when I have them.
I've had some luck with
H[s_] := If[LeafCount[s] == 1, s, Head[s]]
H /# Level[expr, 1, Heads -> True]
H /# Level[expr, 2, Heads -> True]
(* ... *)
but I feel like there must be a better way.
You could use Cases for this:
In[176]:=
Cases[ArcTan[(-1 + 2*x)/Sqrt[3]]/Sqrt[3], h_[___] :> h,
{0,Infinity}] // DeleteDuplicates
Out[176]= {Rational, Power, Times, Plus, ArcTan}
Your own solution does not seem bad:
expr = ArcTan[(-1 + 2*x)/Sqrt[3]]/Sqrt[3];
H[s_] := If[LeafCount[s] == 1, s, Head[s]]
H /# Level[exp, -1, Heads -> True] // Union
{-1, 2, 3, ArcTan, Plus, Power, Rational, Times, x}
Brett Champion's method is more streamlined, but I would change it a little:
Union#Cases[expr, h_[___] :> h, {0, -1}]
This way you pick up a top level head, such as ArcTan in:
expr = ArcTan[(-1 + 2*x)/Sqrt[3]];
For the original question, one can get all leaves via Level with level spec of {-1} and allowing for heads.
In[87]:= Level[ArcTan[(-1 + 2*x)/Sqrt[3]]/Sqrt[3], {-1}, Heads -> True]
Out[87]= {Times, Power, 3, -(1/2), ArcTan, Times, Power, 3, -(1/
2), Plus, -1, Times, 2, x}
Daniel Lichtblau
Here's what I came up with...
In[92]:= f[e_] := DeleteDuplicates[Prepend[Head[#] & /# Level[e, Depth[e]], Head[e]]]
In[93]:= f[ArcTan[(-1 + 2*x)/Sqrt[3]]/Sqrt[3]]
Out[93]= {Times, Integer, Rational, Power, Symbol, Plus, ArcTan}
You can then easily remove Integer and Symbol.
Edit:
Now let's wrap the expression in a list to make sure we're getting the uppermost head. (The original expression had Times as its head but it was also twice inside.
In[139]:= a = {ArcTan[(-1 + 2*x)/Sqrt[3]]/Sqrt[3]}
In[140]:= TreeForm[a, AspectRatio -> .7]
In[142]:= f[a]
Out[142]= {List, Integer, Rational, Power, Symbol, Times, Plus, ArcTan}
I want to repeat a function n times on a table, For n=2 I have the following code, How can I be sure that the function had run twice since my fc is differend every time?
smat = Table[{9, 8, 10}, {3}]
f[x_?Table] := ReplacePart[
x, {{2, 1} -> x[[2]][[1]] - #, {2, 2} -> x[[2]][[2]] + #}] &# fc[x[[2]][[1]]];
fc[k_?NumericQ] := Count[RandomReal[{0, 1}, k], x_ /; x < .1]
Nest[f, smat, 2]
This is probably what you want:
smat = Table[{9, 8, 10}, {3}]
ClearAll[f, fc];
f[x_List] :=
ReplacePart[
x, {{2, 1} -> x[[2]][[1]] - #, {2, 2} -> x[[2]][[2]] + #}] &#
fc[x[[2]][[1]]];
fc[k_?NumericQ] := Count[RandomReal[{0, 1}, k], x_ /; x < .1]
Nest[f, smat, 2]
ClearAll clears any previous definitions for those symbols (just in case). f[x_?Table] won't work; you want f[x_List], which means that the argument has a List head (Table is not a Head, and ? isn't what you want here).
I am not sure I have really answered your question though...
EDIT: To be clear, f[x_?something] means "apply something to x and, if it returns True, evaluate the right hand side of the := that follows. Look up PatternTest in Mathematica's documentation for more.
Acl covered the problems with the code pretty well, so I won't. To answer your question, though, I'd first separate your functions f and fc in separate cells, with fc being declared prior to f, and preface each cell with Clear[<function name>]. Now, to test if f is being applied twice, temporarily replace fc with
fc[_]:= a
or use another "dummy" value other than a, but it should be symbolic to increase readability. As a point of note, {1,2,3} + a == {1 + a, 2 + a, 3 + a}, so if f is applied twice, each term in x[[2]][[1]] and x[[2]][[2]] will have 2 a added to it.
Now, if you are unsure if fc is working correctly by itself, I'd apply it to a number separate cases without f, first.
This is an example. I want to know if there is a general way to deal with this kind of problems.
Suppose I have a function (a ε ℜ) :
f[a_, n_Integer, m_Integer] := Sum[a^i k[i],{i,0,n}]^m
And I need a closed form for the coefficient a^p. What is the better way to proceed?
Note 1:In this particular case, one could go manually trying to represent the sum through Multinomial[ ], but it seems difficult to write down the Multinomial terms for a variable number of arguments, and besides, I want Mma to do it.
Note 2: Of course
Collect[f[a, 3, 4], a]
Will do, but only for a given m and n.
Note 3: This question is related to this other one. My application is different, but probably the same methods apply. So, feel free to answer both with a single shot.
Note 4:
You can model the multinomial theorem with a function like:
f[n_, m_] :=
Sum[KroneckerDelta[m - Sum[r[i], {i, n}]]
(Multinomial ## Sequence#Array[r, n])
Product[x[i]^r[i], {i, n}],
Evaluate#(Sequence ## Table[{r[i], 0, m}, {i, 1, n}])];
So, for example
f[2,3]
is the cube of a binomial
x[1]^3+ 3 x[1]^2 x[2]+ 3 x[1] x[2]^2+ x[2]^3
The coefficient by a^k can be viewed as derivative of order k at zero divided by k!. In version 8, there is a function BellY, which allows to construct a derivative at a point for composition of functions, out of derivatives of individual components. Basically, for f[g[x]] and expanding around x==0 we find Derivative[p][Function[x,f[g[x]]][0] as
BellY[ Table[ { Derivative[k][f][g[0]], Derivative[k][g][0]}, {k, 1, p} ] ]/p!
This is also known as generalized Bell polynomial, see wiki.
In the case at hand:
f[a_, n_Integer, m_Integer] := Sum[a^i k[i], {i, 0, n}]^m
With[{n = 3, m = 4, p = 7},
BellY[ Table[{FactorialPower[m, s] k[0]^(m - s),
If[s <= n, s! k[s], 0]}, {s, 1, p}]]/p!] // Distribute
(*
Out[80]= 4 k[1] k[2]^3 + 12 k[1]^2 k[2] k[3] + 12 k[0] k[2]^2 k[3] +
12 k[0] k[1] k[3]^2
*)
With[{n = 3, m = 4, p = 7}, Coefficient[f[a, n, m], a, p]]
(*
Out[81]= 4 k[1] k[2]^3 + 12 k[1]^2 k[2] k[3] + 12 k[0] k[2]^2 k[3] +
12 k[0] k[1] k[3]^2
*)
Doing it this way is more computationally efficient than building the entire expression and extracting coefficients.
EDIT The approach here outlined will work for symbolic orders n and m, but requires explicit value for p. When using it is this circumstances, it is better to replace If with its Piecewise analog, e.g. Boole:
With[{p = 2},
BellY[Table[{FactorialPower[m, s] k[0]^(m - s),
Boole[s <= n] s! k[s]}, {s, 1, p}]]/p!]
(* 1/2 (Boole[1 <= n]^2 FactorialPower[m, 2] k[0]^(-2 + m)
k[1]^2 + 2 m Boole[2 <= n] k[0]^(-1 + m) k[2]) *)