How can one add the number of powers of x in expressions like the following?
x^2f[x]g[x^3]
or
x^2g[x^4]
or
x^2g[x^2f[x^2]]
The counting is such that all these examples must return 6.
I was thinking of using Count with some pattern, but I didn't manage to construct a pattern for this.
Here's my quick hack - some of the behaviour (see the final example) might not be quite what you want:
SetAttributes[countPowers, Listable]
countPowers[expr_, symb_] := Module[{a},
Cases[{expr} /. symb -> symb^a // PowerExpand, symb^n_ :> n,
Infinity] /. a -> 1 // Total]
Then
In[3]:= countPowers[{x^2 f[x] g[x^3], x^2 g[x^4], x^2 g[x^2 f[x^2]]}, x]
Out[3]= {6, 6, 6}
and
In[4]:= countPowers[{x^(2 I) g[x^3], g[x, x^4],
x^2 g[E^(2 Pi I x) , f[x]^x]}, x]
Out[4]= {3 + 2 I, 5, 5}
Since you want to count x as an implicit power of 1, you could use this:
powerCount[x_Symbol][expr_] :=
Tr # Reap[PowerExpand[expr] /. {x^n_ :> Sow[n], x :> Sow[1]}][[2,1]]
powerCount[x] /#
{
x^2f[x]g[x^3],
x^2g[x^4],
x^2g[x^2f[x^2]]
}
{6, 6, 6}
Alternatively, this could be written without Sow and Reap if that makes it easier to read:
powerCount[x_Symbol][expr_] :=
Module[{t = 0}, PowerExpand[expr] /. {x^n_ :> (t += n), x :> t++}; t]
Either form can be made more terse using vanishing patterns, at the possible expense of clarity:
powerCount[x_Symbol][expr_] :=
Tr # Reap[PowerExpand[expr] /. x^n_ | x :> Sow[1 n]][[2, 1]]
If I do the following in Mathematica
f[l_] := Module[{}, l[[1]] = Append[l[[1]], 3]; l]
f[{{}, 3}]
I get an error:
Set::setps: "{{},3} in the part assignment is not a symbol. "
Even l={{}, 3};f[l] gets the same error. But I can do f[l_] := Module[{}, {Append[l[[1]], 3],l[[2]]}] or l = {{}, 3}; l[[1]] = Append[l[[1]], 3]; l.
What is your explanation?
There are multiple problems here:
Attempting Part assignment on a non-Symbol, just as the error message states.
Attempting to manipulate a named replacement object as though it were a symbol.
The replacement that takes place in this construct:
f[x_] := head[x, 2, 3]
Is analogous to that of With:
With[{x = something}, head[x, 2, 3]]
That is, the substitution is made directly and before evaluation, such that the function Head never even sees an object x. Look what happens with this:
ClearAll[f,x]
x = 5;
f[x_] := (x = x+2; x)
f[x]
During evaluation of In[8]:= Set::setraw: Cannot assign to raw object 5. >>
Out[]= 5
This evaluates as: (5 = 5+2; 5) so not only is assignment to 5 impossible, but all instances of x that appear in the right hand side of := are replaced with the value of x when it is fed to f. Consider what happens if we try to bypass the assignment problem by using a function with side effects:
ClearAll[f, x, incrementX]
incrementX[] := (x += 2)
x = 3;
incrementX[];
x
5
So our incrementX function is working. But now we try:
f[x_] := (incrementX[]; x)
f[x]
5
incrementX did not fail:
x
7
Rather, the the value of x was 5 at the time of evaluation of f[x] and therefore that is returned.
What does work?
What options do we have for things related to what you are attempting? There are several.
1. Use a Hold attribute
We can set a Hold attribute such as HoldFirst or HoldAll on the function, so that we may pass the symbol name to RHS functions, rather than only its value.
ClearAll[heldF]
SetAttributes[heldF, HoldAll]
x = {1, 2, 3};
heldF[x_] := (x[[1]] = 7; x)
heldF[x]
x
<pre>{7, 2, 3}</pre>
<pre>{7, 2, 3}</pre>
We see that both the global value of x, and the x expression returned by heldF are changed. Note that heldF must be given a Symbol as an argument otherwise you are again attempting {1, 2, 3}[[1]] = 7.
2. Use a temporary Symbol
As Arnoud Buzing shows, we can also use a temporary Symbol in Module.
ClearAll[proxyF]
x = {1, 2, 3};
proxyF[x_] := Module[{proxy = x}, proxy[[1]] = 7; proxy]
proxyF[x]
proxyF[{1, 2, 3}]
x
{7, 2, 3}
{7, 2, 3}
{1, 2, 3}
3. Use ReplacePart
We can also avoid symbols completely and just use ReplacePart:
ClearAll[directF]
x = {1, 2, 3};
directF[x_] := ReplacePart[x, 1 -> 7]
directF[x]
x
{7, 2, 3}
{1, 2, 3}
This can be used for modifications rather than outright replacements as well:
ClearAll[f]
f[l_] := ReplacePart[l, 1 :> l[[1]] ~Append~ 3]
f[{{}, 3}]
{{3}, 3}
Try
f[{{}, 3}] // Trace
and you see that the value of l is inserted into the l[[1]] = Append[l[[1]], 3] bit before evaluation. So mma is attempting to evaluate this: {{}, 3}[[1]] = {3}
This may do something like you want
ClearAll[f];
f[l_] := Module[{},
Append[l[[1]], 3]~Join~Rest[l]
]
(the idea is to avoid assigning to parts of l, since l will be evaluated before the assignment is attempted)
If you do want to use Part in your Module, you may want to consider using a temporary variable:
f[l_List] := Module[{t = l}, t[[1]] = Pi; t]
And:
In[] := f[{1, 2, 3}]
Out[] = {Pi, 2, 3}
One may set a Default value for the arguments of a function:
Default[f] = 5;
And then use:
f[a_, b_.] := {a, b}
f[1, 2]
f[1]
{1, 2}
{1, 5}
This creates the following Values:
DefaultValues[f]
DownValues[f]
{HoldPattern[Default[f]] :> 5}
{HoldPattern[f[a_, b_.]] :> {a, b}}
From this one might think that the value 5 is not fixed in the definition of f, but addresses the DefaultValues assignment. However, if we change the DefaultValues, either directly or using:
Default[f] = 9;
DefaultValues[f]
{HoldPattern[Default[f]] :> 9}
and use f again:
f[1]
{1, 5}
we see that the new value is not used.
Therefore, my questions are:
Why does the default value used by f[a_, b_.] := {a, b} not change with DefaultValues?
Where is the real default value (5) stored, since it does not appear in either DownValues or DefaultValues?
Not an answer, but:
Using the behaviour that the original default is kept until the function is redefined suggests a quick work-around:
Define a global variable for the Default before any other definitions are made.
In[1]:= Default[f]:=$f
In[2]:= f[a_.]:=a
In[3]:= f[]
Out[3]= $f
In[4]:= $f=5; f[]
Out[5]= 5
In[6]:= $f=6; f[]
Out[7]= 6
In[8]:= $f=.; f[]
Out[9]= $f
This also works for Optional
In[1]:= g[a_:$g] := a
In[2]:= g[]
Out[2]= $g
In[3]:= $g=1; g[]
Out[4]= 1
From the documentation,
The necessary values for Default[f] must always be defined before _. is used as an argument of f.
Redefining f after setting Default[f] = 9; uses the new default value. So my guess is it is defined internally the first time, f is defined, and doesn't change even if DefaultValue#f stores the new value.
I have found that this behavior in the case of local rules is due to specifics of internals of RuleDelayed.
Compare:
In[1]:= Default[f] = 5;
replaceAll[f[1],
f[a_, b_.] :> Unevaluated#{a, b}] /. (Default[f] = 9; replaceAll) ->
ReplaceAll
Default[f] = 5;
Block[{RuleDelayed},
replaceAll[f[1],
f[a_, b_.] :> Unevaluated#{a, b}] /. (Default[f] = 9;
replaceAll) -> ReplaceAll]
Out[2]= {1, 5}
Out[4]= Unevaluated[{1, 9}]
One can see that Blocking RuleDelayed makes local rules to behave as one could expect.
Suppose we want to generate a list of primes p for which p + 2 is also prime.
A quick solution is to generate a complete list of the first n primes and use the Select function to return the elements which meet the condition.
Select[Table[Prime[k], {k, n}], PrimeQ[# + 2] &]
However, this is inefficient as it loads a large list into the memory before returning the filtered list. A For loop with Sow/Reap (or l = {}; AppendTo[l, k]) solves the memory issue, but it is far from elegant and is cumbersome to implement a number of times in a Mathematica script.
Reap[
For[k = 1, k <= n, k++,
p = Prime[k];
If[PrimeQ[p + 2], Sow[p]]
]
][[-1, 1]]
An ideal solution would be a built-in function which allows an option similar to this.
Table[Prime[k], {k, n}, AddIf -> PrimeQ[# + 2] &]
I will interpret this more as a question about automation and software engineering rather than about the specific problem at hand, and given a large number of solutions posted already. Reap and Sow are good means (possibly, the best in the symbolic setting) to collect intermediate results. Let us just make it general, to avoid code duplication.
What we need is to write a higher-order function. I will not do anything radically new, but will simply package your solution to make it more generally applicable:
Clear[tableGen];
tableGen[f_, iter : {i_Symbol, __}, addif : Except[_List] : (True &)] :=
Module[{sowTag},
If[# === {}, #, First##] &#
Last#Reap[Do[If[addif[#], Sow[#,sowTag]] &[f[i]], iter],sowTag]];
The advantages of using Do over For are that the loop variable is localized dynamically (so, no global modifications for it outside the scope of Do), and also the iterator syntax of Do is closer to that of Table (Do is also slightly faster).
Now, here is the usage
In[56]:= tableGen[Prime, {i, 10}, PrimeQ[# + 2] &]
Out[56]= {3, 5, 11, 17, 29}
In[57]:= tableGen[Prime, {i, 3, 10}, PrimeQ[# + 1] &]
Out[57]= {}
In[58]:= tableGen[Prime, {i, 10}]
Out[58]= {2, 3, 5, 7, 11, 13, 17, 19, 23, 29}
EDIT
This version is closer to the syntax you mentioned (it takes an expression rather than a function):
ClearAll[tableGenAlt];
SetAttributes[tableGenAlt, HoldAll];
tableGenAlt[expr_, iter_List, addif : Except[_List] : (True &)] :=
Module[{sowTag},
If[# === {}, #, First##] &#
Last#Reap[Do[If[addif[#], Sow[#,sowTag]] &[expr], iter],sowTag]];
It has an added advantage that you may even have iterator symbols defined globally, since they are passed unevaluated and dynamically localized. Examples of use:
In[65]:= tableGenAlt[Prime[i], {i, 10}, PrimeQ[# + 2] &]
Out[65]= {3, 5, 11, 17, 29}
In[68]:= tableGenAlt[Prime[i], {i, 10}]
Out[68]= {2, 3, 5, 7, 11, 13, 17, 19, 23, 29}
Note that since the syntax is different now, we had to use the Hold-attribute to prevent the passed expression expr from premature evaluation.
EDIT 2
Per #Simon's request, here is the generalization for many dimensions:
ClearAll[tableGenAltMD];
SetAttributes[tableGenAltMD, HoldAll];
tableGenAltMD[expr_, iter__List, addif : Except[_List] : (True &)] :=
Module[{indices, indexedRes, sowTag},
SetDelayed ## Prepend[Thread[Map[Take[#, 1] &, List ## Hold ### Hold[iter]],
Hold], indices];
indexedRes =
If[# === {}, #, First##] &#
Last#Reap[Do[If[addif[#], Sow[{#, indices},sowTag]] &[expr], iter],sowTag];
Map[
First,
SplitBy[indexedRes ,
Table[With[{i = i}, Function[Slot[1][[2, i]]]], {i,Length[Hold[iter]] - 1}]],
{-3}]];
It is considerably less trivial, since I had to Sow the indices together with the added values, and then split the resulting flat list according to the indices. Here is an example of use:
{i, j, k} = {1, 2, 3};
tableGenAltMD[i + j + k, {i, 1, 5}, {j, 1, 3}, {k, 1, 2}, # < 7 &]
{{{3, 4}, {4, 5}, {5, 6}}, {{4, 5}, {5, 6}, {6}}, {{5, 6}, {6}}, {{6}}}
I assigned the values to i,j,k iterator variables to illustrate that this function does localize the iterator variables and is insensitive to possible global values for them. To check the result, we may use Table and then delete the elements not satisfying the condition:
In[126]:=
DeleteCases[Table[i + j + k, {i, 1, 5}, {j, 1, 3}, {k, 1, 2}],
x_Integer /; x >= 7, Infinity] //. {} :> Sequence[]
Out[126]= {{{3, 4}, {4, 5}, {5, 6}}, {{4, 5}, {5, 6}, {6}}, {{5, 6}, {6}}, {{6}}}
Note that I did not do extensive checks so the current version may contain bugs and needs some more testing.
EDIT 3 - BUG FIX
Note the important bug-fix: in all functions, I now use Sow with a custom unique tag, and Reap as well. Without this change, the functions would not work properly when expression they evaluate also uses Sow. This is a general situation with Reap-Sow, and resembles that for exceptions (Throw-Catch).
EDIT 4 - SyntaxInformation
Since this is such a potentially useful function, it is nice to make it behave more like a built-in function. First we add syntax highlighting and basic argument checking through
SyntaxInformation[tableGenAltMD] = {"ArgumentsPattern" -> {_, {_, _, _., _.}.., _.},
"LocalVariables" -> {"Table", {2, -2}}};
Then, adding a usage message allows the menu item "Make Template" (Shift+Ctrl+k) to work:
tableGenAltMD::usage = "tableGenAltMD[expr,{i,imax},addif] will generate \
a list of values expr when i runs from 1 to imax, \
only including elements if addif[expr] returns true.
The default of addiff is True&."
A more complete and formatted usage message can be found in this gist.
I think the Reap/Sow approach is likely to be most efficient in terms of memory usage. Some alternatives might be:
DeleteCases[(With[{p=Prime[#]},If[PrimeQ[p+2],p,{}] ] ) & /# Range[K]),_List]
Or (this one might need some sort of DeleteCases to eliminate Null results):
FoldList[[(With[{p=Prime[#2]},If[PrimeQ[p+2],p] ] )& ,1.,Range[2,K] ]
Both hold a big list of integers 1 to K in memory, but the Primes are scoped inside the With[] construct.
Yes, this is another answer. Another alternative that includes the flavour of the Reap/Sow approach and the FoldList approach would be to use Scan.
result = {1};
Scan[With[{p=Prime[#]},If[PrimeQ[p+2],result={result,p}]]&,Range[2,K] ];
Flatten[result]
Again, this involves a long list of integers, but the intermediate Prime results are not stored because they are in the local scope of With. Because p is a constant in the scope of the With function, you can use With rather than Module, and gain a bit of speed.
You can perhaps try something like this:
Clear[f, primesList]
f = With[{p = Prime[#]},Piecewise[{{p, PrimeQ[p + 2]}}, {}] ] &;
primesList[k_] := Union#Flatten#(f /# Range[k]);
If you want both the prime p and the prime p+2, then the solution is
Clear[f, primesList]
f = With[{p = Prime[#]},Piecewise[{{p, PrimeQ[p + 2]}}, {}] ] &;
primesList[k_] :=
Module[{primes = f /# Range[k]},
Union#Flatten#{primes, primes + 2}];
Well, someone has to allocate memory somewhere for the full table size, since it is not known before hand what the final size will be.
In the good old days before functional programming :), this sort of thing was solved by allocating the maximum array size, and then using a separate index to insert to it so no holes are made. Like this
x=Table[0,{100}]; (*allocate maximum possible*)
j=0;
Table[ If[PrimeQ[k+2], x[[++j]]=k],{k,100}];
x[[1;;j]] (*the result is here *)
{1,3,5,9,11,15,17,21,27,29,35,39,41,45,51,57,59,65,69,71,77,81,87,95,99}
Here's another couple of alternatives using NextPrime:
pairs1[pmax_] := Select[Range[pmax], PrimeQ[#] && NextPrime[#] == 2 + # &]
pairs2[pnum_] := Module[{p}, NestList[(p = NextPrime[#];
While[p + 2 != (p = NextPrime[p])];
p - 2) &, 3, pnum]]
and a modification of your Reap/Sow solution that lets you specify the maximum prime:
pairs3[pmax_] := Module[{k,p},
Reap[For[k = 1, (p = Prime[k]) <= pmax, k++,
If[PrimeQ[p + 2], Sow[p]]]][[-1, 1]]]
The above are in order of increasing speed.
In[4]:= pairs2[10000]//Last//Timing
Out[4]= {3.48,1261079}
In[5]:= pairs1[1261079]//Last//Timing
Out[5]= {6.84,1261079}
In[6]:= pairs3[1261079]//Last//Timing
Out[7]= {0.58,1261079}
I have discovered that InString[] does not work in MathLink mode when sending input with EnterExpressionPacket header. So I need to define my own function that returns previous input line. One way I have developed here does not work in some cases:
In[1]:= Unevaluated[2 + 2]
With[{line = $Line - 1}, HoldForm[In[line]]] /. (DownValues[In])
Out[1]= Unevaluated[2 + 2]
Out[2]= 2 + 2
This is because RuleDelayed has no HoldAllComplete attribute. Adding this attribute makes this OK:
In[1]:= Unprotect[RuleDelayed];
SetAttributes[RuleDelayed, HoldAllComplete];
Protect[RuleDelayed];
Unevaluated[2 + 2]
With[{line = $Line - 1}, HoldForm[In[line]]] /. DownValues[In]
Out[4]= Unevaluated[2 + 2]
Out[5]= Unevaluated[2 + 2]
But modifying built-in functions generally is not a good idea. Is there a better way to do this?
It seems that I have solved the problem. Here is the function:
In[1]:=
getLastInput := Module[{num, f},
f = Function[{u, v},
{u /. {In -> num, HoldPattern -> First}, HoldForm[v]}, HoldAllComplete];
First#Cases[
Block[{RuleDelayed = f}, DownValues[In]],
{$Line - 1, x_} -> x, {1}, 1]]
In[2]:=
Unevaluated[2+2]
getLastInput
Out[2]=
Unevaluated[2+2]
Out[3]=
Unevaluated[2+2]
And I just have got the answer to the question on InString in MathLink mode from Todd Gayley (Wolfram Research):
InString is only assigned when using
EnterTextPacket, not
EnterExpressionPacket. There is no
string form of the input when sending
EnterExpressionPacket (whose content
is, by definition, already an
expression).
EDIT:
I just have found that my code does not work with input expressions with head Evaluate. The solution is to replace HoldForm by HoldComplete in my code:
getLastInput := Module[{num, f},
f = Function[{u, v},
{u /. {In -> num, HoldPattern -> First}, HoldComplete[v]}, HoldAllComplete];
First#Cases[
Block[{RuleDelayed = f}, DownValues[In]],
{$Line - 1, x_} -> x, {1}, 1]]
This works well. Another approach would be to unprotect HoldForm and set up attribute HoldAllComplete on it. I'm wondering why HoldForm does not have this attribute by default?
EDIT 2:
In the comments for the main question Leonid Shifrin suggested much better solution:
getLastInput :=
Block[{RuleDelayed},SetAttributes[RuleDelayed,HoldAllComplete];
With[{line=$Line-1},HoldComplete[In[line]]/.DownValues[In]]]
See comments for details.
EDIT 3:
The last code can be made even better for by replacing HoldComplete by double HoldForm:
getLastInput :=
Block[{RuleDelayed},SetAttributes[RuleDelayed,HoldAllComplete];
With[{line=$Line-1},HoldForm#HoldForm[In[line]]/.DownValues[In]]]
The idea is taken from presentation by Robby Villegas of Wolfram Research at the 1999 Developer Conference. See subsection "HoldCompleteForm: a non-printing variant of HoldComplete (just as HoldForm is to Hold)" in "Working With Unevaluated Expressions" notebook posted here.
I would use $Pre and $Line for this; unlike $PreRead, it's applied to input expressions, not input strings or box forms. All you need is to assign it a function that has the HoldAllComplete attribute, like this one which I've adapted from the example in the documentation:
SetAttributes[saveinputs, HoldAllComplete];
saveinputs[new_] :=
With[{line = $Line},
inputs[line] = HoldComplete[new]; new]
$Pre = saveinputs;
I tested this with MathLink, and the behavior seems to be what you desired (I've elided some of the transcript to highlight the key point):
In[14]:= LinkWrite[link,
Unevaluated[
EnterExpressionPacket[
SetAttributes[saveinputs, HoldAllComplete];
saveinputs[new_] :=
With[{line = $Line},
inputs[line] = HoldComplete[new]; new];
$Pre = saveinputs;]]]
In[15]:= LinkRead[link]
Out[15]= InputNamePacket["In[2]:= "]
In[20]:= LinkWrite[link,
Unevaluated[EnterExpressionPacket[Evaluate[1 + 1]]]]
In[21]:= LinkRead[link]
Out[21]= OutputNamePacket["Out[2]= "]
In[21]:= LinkRead[link]
Out[21]= ReturnExpressionPacket[2]
In[24]:= LinkWrite[link, Unevaluated[EnterExpressionPacket[DownValues[inputs]]]]
In[26]:= LinkRead[link]
Out[26]= ReturnExpressionPacket[
{HoldPattern[inputs[2]] :> HoldComplete[Evaluate[1 + 1]],
HoldPattern[inputs[3]] :> HoldComplete[DownValues[inputs]]}]
I just have found simpler but dangerous way:
In[3]:= Unevaluated[2 + 2]
Trace[In[$Line - 1]] // Last
Trace[In[$Line - 1]] // Last
Out[3]= Unevaluated[2 + 2]
Out[4]= Unevaluated[2 + 2]
During evaluation of In[3]:= $RecursionLimit::reclim: Recursion depth of 256 exceeded. >>
During evaluation of In[3]:= $RecursionLimit::reclim: Recursion depth of 256 exceeded. >>
During evaluation of In[3]:= $IterationLimit::itlim: Iteration limit of 4096 exceeded. >>
Out[5]= Hold[In[$Line-1]]
Does anybody know a way to make it safe?