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.
Consider following simple, illustrating example
cf = Block[{a, x, degree = 3},
With[{expr = Product[x - a[[i]], {i, degree}]},
Compile[{{x, _Real, 0}, {a, _Real, 1}}, expr]
]
]
This is one of the possible ways to transfer code in the body of a Compile statement. It produces the Part::partd error, since a[[i]] is at the moment of evaluation not a list.
The easy solution is to just ignore this message or turn it off. There are of course other ways around it. For instance one could circumvent the evaluation of a[[i]] by replacing it inside the Compile-body before it is compiled
cf = ReleaseHold[Block[{a, x, degree = 3},
With[{expr = Product[x - a[i], {i, degree}]},
Hold[Compile[{{x, _Real, 0}, {a, _Real, 1}}, expr]] /.
a[i_] :> a[[i]]]
]
]
If the compiled function a large bit of code, the Hold, Release and the replacement at the end goes a bit against my idea of beautiful code. Is there a short and nice solution I have not considered yet?
Answer to the post of Szabolcs
Could you tell me though why you are using With here?
Yes, and it has to do with the reason why I cannot use := here. I use With, to have something like a #define in C, which means a code-replacement at the place I need it. Using := in With delays the evaluation and what the body of Compile sees is not the final piece of code which it is supposed to compile. Therefore,
<< CompiledFunctionTools`
cf = Block[{a, x, degree = 3},
With[{expr := Product[x - a[[i]], {i, degree}]},
Compile[{{x, _Real, 0}, {a, _Real, 1}}, expr]]];
CompilePrint[cf]
shows you, that there is a call to the Mathematica-kernel in the compiled function
I4 = MainEvaluate[ Function[{x, a}, degree][ R0, T(R1)0]]
This is bad because Compile should use only the local variables to calculate the result.
Update
Szabolcs solution works in this case but it leaves the whole expression unevaluated. Let me explain, why it is important that the expression is expanded before it is compiled. I have to admit, my toy-example was not the best. So lets try a better one using With and SetDelayed like in the solution of Szabolcs
Block[{a, x}, With[
{expr := D[Product[x - a[[i]], {i, 3}], x]},
Compile[{{x, _Real, 0}, {a, _Real, 1}}, expr]
]
]
Say I have a polynomial of degree 3 and I need the derivative of it inside the Compile. In the above code I want Mathematica to calculate the derivative for unassigned roots a[[i]] so I can use the formula very often in the compiled code. Looking at the compiled code above
one sees, that the D[..] cannot be compiled as nicely as the Product and stays unevaluated
11 R1 = MainEvaluate[ Hold[D][ R5, R0]]
Therefore, my updated question is: Is it possible to evaluate a piece of code without evaluating the Part[]-accesses in it better/nicer than using
Block[{a, x}, With[
{expr = D[Quiet#Product[x - a[[i]], {i, 3}], x]},
Compile[{{x, _Real, 0}, {a, _Real, 1}}, expr]
]
]
Edit: I put the Quiet to the place it belongs. I had it in front of code block to make it visible to everyone that I used Quiet here to suppress the warning. As Ruebenko pointed already out, it should in real code always be as close as possible to where it belongs. With this approach you probably don't miss other important warnings/errors.
Update 2
Since we're moving away from the original question, we should move this discussion maybe to a new thread. I don't know to whom I should give the best answer-award to my question since we discussed Mathematica and Scoping more than how to suppress the a[[i]] issue.
Update 3
To give the final solution: I simply suppress (unfortunately like I did all the time) the a[[i]] warning with Quiet. In a real example below, I have to use Quiet outside the complete Block to suppress the warning.
To inject the required code into the body of Compile I use a pure function and give the code to inline as argument. This is the same approach Michael Trott is using in, e.g. his Numerics book. This is a bit like the where clause in Haskell, where you define stuff you used afterwards.
newtonC = Function[{degree, f, df, colors},
Compile[{{x0, _Complex, 0}, {a, _Complex, 1}},
Block[{x = x0, xn = 0.0 + 0.0 I, i = 0, maxiter = 256,
eps = 10^(-6.), zeroId = 1, j = 1},
For[i = 0, i < maxiter, ++i,
xn = x - f/(df + eps);
If[Abs[xn - x] < eps,
Break[]
];
x = xn;
];
For[j = 1, j <= degree, ++j,
If[Abs[xn - a[[j]]] < eps*10^2,
zeroId = j + 1;
Break[];
];
];
colors[[zeroId]]*(1 - (i/maxiter)^0.3)*1.5
],
CompilationTarget -> "C", RuntimeAttributes -> {Listable},
RuntimeOptions -> "Speed", Parallelization -> True]]##
(Quiet#Block[{degree = 3, polynomial, a, x},
polynomial = HornerForm[Product[x - a[[i]], {i, degree}]];
{degree, polynomial, HornerForm[D[polynomial, x]],
List ### (ColorData[52, #] & /# Range[degree + 1])}])
And this function is now fast enough to calculate the Newton-fractal of a polynomial where the position of the roots is not fixed. Therefore, we can adjust the roots dynamically.
Feel free to adjust n. Here it runs up to n=756 fluently
(* ImageSize n*n, Complex plange from -b-I*b to b+I*b *)
With[{n = 256, b = 2.0},
DynamicModule[{
roots = RandomReal[{-b, b}, {3, 2}],
raster = Table[x + I y, {y, -b, b, 2 b/n}, {x, -b, b, 2 b/n}]},
LocatorPane[Dynamic[roots],
Dynamic[
Graphics[{Inset[
Image[Reverse#newtonC[raster, Complex ### roots], "Real"],
{-b, -b}, {1, 1}, 2 {b, b}]}, PlotRange -> {{-b, b}, {-
b, b}}, ImageSize -> {n, n}]], {{-b, -b}, {b, b}},
Appearance -> Style["\[Times]", Red, 20]
]
]
]
Teaser:
Ok, here is the very oversimplified version of the code generation framework I am using for various purposes:
ClearAll[symbolToHideQ]
SetAttributes[symbolToHideQ, HoldFirst];
symbolToHideQ[s_Symbol, expandedSymbs_] :=! MemberQ[expandedSymbs, Unevaluated[s]];
ClearAll[globalProperties]
globalProperties[] := {DownValues, SubValues, UpValues (*,OwnValues*)};
ClearAll[getSymbolsToHide];
Options[getSymbolsToHide] = {
Exceptions -> {List, Hold, HoldComplete,
HoldForm, HoldPattern, Blank, BlankSequence, BlankNullSequence,
Optional, Repeated, Verbatim, Pattern, RuleDelayed, Rule, True,
False, Integer, Real, Complex, Alternatives, String,
PatternTest,(*Note- this one is dangerous since it opens a hole
to evaluation leaks. But too good to be ingored *)
Condition, PatternSequence, Except
}
};
getSymbolsToHide[code_Hold, headsToExpand : {___Symbol}, opts : OptionsPattern[]] :=
Join ## Complement[
Cases[{
Flatten[Outer[Compose, globalProperties[], headsToExpand]], code},
s_Symbol /; symbolToHideQ[s, headsToExpand] :> Hold[s],
Infinity,
Heads -> True
],
Hold /# OptionValue[Exceptions]];
ClearAll[makeHidingSymbol]
SetAttributes[makeHidingSymbol, HoldAll];
makeHidingSymbol[s_Symbol] :=
Unique[hidingSymbol(*Unevaluated[s]*) (*,Attributes[s]*)];
ClearAll[makeHidingRules]
makeHidingRules[symbs : Hold[__Symbol]] :=
Thread[List ## Map[HoldPattern, symbs] -> List ## Map[makeHidingSymbol, symbs]];
ClearAll[reverseHidingRules];
reverseHidingRules[rules : {(_Rule | _RuleDelayed) ..}] :=
rules /. (Rule | RuleDelayed)[Verbatim[HoldPattern][lhs_], rhs_] :> (rhs :> lhs);
FrozenCodeEval[code_Hold, headsToEvaluate : {___Symbol}] :=
Module[{symbolsToHide, hidingRules, revHidingRules, result},
symbolsToHide = getSymbolsToHide[code, headsToEvaluate];
hidingRules = makeHidingRules[symbolsToHide];
revHidingRules = reverseHidingRules[hidingRules];
result =
Hold[Evaluate[ReleaseHold[code /. hidingRules]]] /. revHidingRules;
Apply[Remove, revHidingRules[[All, 1]]];
result];
The code works by temporarily hiding most symbols with some dummy ones, and allow certain symbols evaluate. Here is how this would work here:
In[80]:=
FrozenCodeEval[
Hold[Compile[{{x,_Real,0},{a,_Real,1}},D[Product[x-a[[i]],{i,3}],x]]],
{D,Product,Derivative,Plus}
]
Out[80]=
Hold[Compile[{{x,_Real,0},{a,_Real,1}},
(x-a[[1]]) (x-a[[2]])+(x-a[[1]]) (x-a[[3]])+(x-a[[2]]) (x-a[[3]])]]
So, to use it, you have to wrap your code in Hold and indicate which heads you want to evaluate. What remains here is just to apply ReleseHold to it. Note that the above code just illustrates the ideas, but is still quite limited. The full version of my method involves other steps which make it much more powerful but also more complex.
Edit
While the above code is still too limited to accomodate many really interesting cases, here is one additional neat example of what would be rather hard to achieve with the traditional tools of evaluation control:
In[102]:=
FrozenCodeEval[
Hold[f[x_, y_, z_] :=
With[Thread[{a, b, c} = Map[Sqrt, {x, y, z}]],
a + b + c]],
{Thread, Map}]
Out[102]=
Hold[
f[x_, y_, z_] :=
With[{a = Sqrt[x], b = Sqrt[y], c = Sqrt[z]}, a + b + c]]
EDIT -- Big warning!! Injecting code using With or Function into Compile that uses some of Compile's local variables is not reliable! Consider the following:
In[63]:= With[{y=x},Compile[x,y]]
Out[63]= CompiledFunction[{x$},x,-CompiledCode-]
In[64]:= With[{y=x},Compile[{{x,_Real}},y]]
Out[64]= CompiledFunction[{x},x,-CompiledCode-]
Note the renaming of x to x$ in the first case. I recommend you read about localization here and here. (Yes, this is confusing!) We can guess about why this only happens in the first case and not the second, but my point is that this behaviour might not be intended (call it a bug, dark corner or undefined behaviour), so relying on it is fragile ...
Replace-based solutions, like my withRules function do work though (this was not my intended use for that function, but it fits well here ...)
In[65]:= withRules[{y->x},Compile[x,y]]
Out[65]= CompiledFunction[{x},x,-CompiledCode-]
Original answers
You can use := in With, like so:
cf = Block[{a, x, degree = 3},
With[{expr := Product[x - a[[i]], {i, degree}]},
Compile[{{x, _Real, 0}, {a, _Real, 1}}, expr]
]
]
It will avoid evaluating expr and the error from Part.
Generally, = and := work as expected in all of With, Module and Block.
Could you tell me though why you are using With here? (I'm sure you have a good reason, I just can't see it from this simplified example.)
Additional answer
Addressing #halirutan's concern about degree not being inlined during compilation
I see this as exactly the same situation as if we had a global variable defined that we use in Compile. Take for example:
In[18]:= global=1
Out[18]= 1
In[19]:= cf2=Compile[{},1+global]
Out[19]= CompiledFunction[{},1+global,-CompiledCode-]
In[20]:= CompilePrint[cf2]
Out[20]=
No argument
3 Integer registers
Underflow checking off
Overflow checking off
Integer overflow checking on
RuntimeAttributes -> {}
I0 = 1
Result = I2
1 I1 = MainEvaluate[ Function[{}, global][ ]]
2 I2 = I0 + I1
3 Return
This is a common issue. The solution is to tell Compile to inline globals, like so:
cf = Block[{a, x, degree = 3},
With[{expr := Product[x - a[[i]], {i, degree}]},
Compile[{{x, _Real, 0}, {a, _Real, 1}}, expr,
CompilationOptions -> {"InlineExternalDefinitions" -> True}]]];
CompilePrint[cf]
You can check that now there's no callback to the main evaluator.
Alternatively you can inject the value of degree using an extra layer of With instead of Block. This will make you wish for something like this very much.
Macro expansion in Mathematica
This is somewhat unrelated, but you mention in your post that you use With for macro expansion. Here's my first (possibly buggy) go at implementing macro expansion in Mathematica. This is not well tested, feel free to try to break it and post a comment.
Clear[defineMacro, macros, expandMacros]
macros = Hold[];
SetAttributes[defineMacro, HoldAllComplete]
defineMacro[name_Symbol, value_] := (AppendTo[macros, name]; name := value)
SetAttributes[expandMacros, HoldAllComplete]
expandMacros[expr_] := Unevaluated[expr] //. Join ## (OwnValues /# macros)
Description:
macros is a (held) list of all symbols to be expanded.
defineMacro will make a new macro.
expandMacros will expand macro definitions in an expression.
Beware: I didn't implement macro-redefinition, this will not work while expansion is on using $Pre. Also beware of recursive macro definitions and infinite loops.
Usage:
Do macro expansion on all input by defining $Pre:
$Pre = expandMacros;
Define a to have the value 1:
defineMacro[a, 1]
Set a delayed definition for b:
b := a + 1
Note that the definition of b is not fully evaluated, but a is expanded.
?b
Global`b
b:=1+1
Turn off macro expansion ($Pre can be dangerous if there's a bug in my code):
$Pre =.
One way:
cf = Block[{a, x, degree = 3},
With[{expr = Quiet[Product[x - a[[i]], {i, degree}]]},
Compile[{{x, _Real, 0}, {a, _Real, 1}}, expr]]]
be careful though, it you really want this.
Original code:
newtonC = Function[{degree, f, df, colors},
Compile[{{x0, _Complex, 0}, {a, _Complex, 1}},
Block[{x = x0, xn = 0.0 + 0.0 I, i = 0, maxiter = 256,
...
RuntimeOptions -> "Speed", Parallelization -> True]]##
(Quiet#Block[{degree = 3, polynomial, a, x},
polynomial = HornerForm[Product[x - a[[i]], {i, degree}]];
...
Modified code:
newtonC = Function[{degree, f, df, colors},
Compile[{{x0, _Complex, 0}, {a, _Complex, 1}},
Block[{x = x0, xn = 0.0 + 0.0 I, i = 0, maxiter = 256,
...
RuntimeOptions -> "Speed", Parallelization -> True],HoldAllComplete]##
( (( (HoldComplete###)/.a[i_]:>a[[i]] )&)#Block[{degree = 3, polynomial, a, x},
polynomial = HornerForm[Product[x - a[i], {i, degree}]];
...
Add HoldAllComplete attribute to the function.
Write a[i] in place of a[[i]].
Replace Quiet with (( (HoldComplete###)/.a[i_]:>a[[i]] )&)
Produces the identical code, no Quiet, and all of the Hold stuff is in one place.
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?