Related
So generally, if you have two functions f,g: X -->Y, and if there is some binary operation + defined on Y, then f + g has a canonical definition as the function x --> f(x) + g(x).
What's the best way to implement this in Mathematica?
f[x_] := x^2
g[x_] := 2*x
h = f + g;
h[1]
yields
(f + g)[1]
as an output
of course,
H = Function[z, f[z] + g[z]];
H[1]
Yields '3'.
Consider:
In[1]:= Through[(f + g)[1]]
Out[1]= f[1] + g[1]
To elaborate, you can define h like this:
h = Through[ (f + g)[#] ] &;
If you have a limited number of functions and operands, then UpSet as recommended by yoda is surely syntactically cleaner. However, Through is more general. Without any new definitions involving Times or h, one can easily do:
i = Through[ (h * f * g)[#] ] &
i[7]
43218
Another way of doing what you're trying to do is using UpSetDelayed.
f[x_] := x^2;
g[x_] := 2*x;
f + g ^:= f[#] + g[#] &; (*define upvalues for the operation f+g*)
h[x_] = f + g;
h[z]
Out[1]= 2 z + z^2
Also see this very nice answer by rcollyer (and also the ones by Leonid & Verbeia) for more on UpValues and when to use them
I will throw in a complete code for Gram - Schmidt and an example for function addition etc, since I happened to have that code written about 4 years ago. Did not test extensively though. I did not change a single line of it now, so a disclaimer (I was a lot worse at mma at the time). That said, here is a Gram - Schmidt procedure implementation, which is a slightly generalized version of the code I discussed here:
oneStepOrtogonalizeGen[vec_, {}, _, _, _] := vec;
oneStepOrtogonalizeGen[vec_, vecmat_List, dotF_, plusF_, timesF_] :=
Fold[plusF[#1, timesF[-dotF[vec, #2]/dotF[#2, #2], #2]] &, vec, vecmat];
GSOrthogonalizeGen[startvecs_List, dotF_, plusF_, timesF_] :=
Fold[Append[#1,oneStepOrtogonalizeGen[#2, #1, dotF, plusF, timesF]] &, {}, startvecs];
normalizeGen[vec_, dotF_, timesF_] := timesF[1/Sqrt[dotF[vec, vec]], vec];
GSOrthoNormalizeGen[startvecs_List, dotF_, plusF_, timesF_] :=
Map[normalizeGen[#, dotF, timesF] &, GSOrthogonalizeGen[startvecs, dotF, plusF, timesF]];
The functions above are parametrized by 3 functions, realizing addition, multiplication by a number, and the dot product in a given vector space. The example to illustrate will be to find Hermite polynomials by orthonormalizing monomials. These are possible implementations for the 3 functions we need:
hermiteDot[f_Function, g_Function] :=
Module[{x}, Integrate[f[x]*g[x]*Exp[-x^2], {x, -Infinity, Infinity}]];
SetAttributes[functionPlus, {Flat, Orderless, OneIdentity}];
functionPlus[f__Function] := With[{expr = Plus ## Through[{f}[#]]}, expr &];
SetAttributes[functionTimes, {Flat, Orderless, OneIdentity}];
functionTimes[a___, f_Function] /; FreeQ[{a}, # | Function] :=
With[{expr = Times[a, f[#]]}, expr &];
These functions may be a bit naive, but they will illustrate the idea (and yes, I also used Through). Here are some examples to illustrate their use:
In[114]:= hermiteDot[#^2 &, #^4 &]
Out[114]= (15 Sqrt[\[Pi]])/8
In[107]:= functionPlus[# &, #^2 &, Sin[#] &]
Out[107]= Sin[#1] + #1 + #1^2 &
In[111]:= functionTimes[z, #^2 &, x, 5]
Out[111]= 5 x z #1^2 &
Now, the main test:
In[115]:=
results =
GSOrthoNormalizeGen[{1 &, # &, #^2 &, #^3 &, #^4 &}, hermiteDot,
functionPlus, functionTimes]
Out[115]= {1/\[Pi]^(1/4) &, (Sqrt[2] #1)/\[Pi]^(1/4) &, (
Sqrt[2] (-(1/2) + #1^2))/\[Pi]^(1/4) &, (2 (-((3 #1)/2) + #1^3))/(
Sqrt[3] \[Pi]^(1/4)) &, (Sqrt[2/3] (-(3/4) + #1^4 -
3 (-(1/2) + #1^2)))/\[Pi]^(1/4) &}
These are indeed the properly normalized Hermite polynomials, as is easy to verify. The normalization of built-in HermiteH is different. Our results are normalized as one would normalize the wave functions of a harmonic oscillator, say. It is trivial to obtain a list of polynomials as expressions depending on a variable, say x:
In[116]:= Through[results[x]]
Out[116]= {1/\[Pi]^(1/4),(Sqrt[2] x)/\[Pi]^(1/4),(Sqrt[2] (-(1/2)+x^2))/\[Pi]^(1/4),
(2 (-((3 x)/2)+x^3))/(Sqrt[3] \[Pi]^(1/4)),(Sqrt[2/3] (-(3/4)+x^4-3 (-(1/2)+x^2)))/\[Pi]^(1/4)}
I would suggest defining an operator other than the built-in Plus for this purpose. There are a number of operators provided by Mathematica that are reserved for user definitions in cases such as this. One such operator is CirclePlus which has no pre-defined meaning but which has a nice compact representation (at least, it is compact in a notebook -- not so compact on a StackOverflow web page). You could define CirclePlus to perform function addition thus:
(x_ \[CirclePlus] y_)[args___] := x[args] + y[args]
With this definition in place, you can now perform function addition:
h = f \[CirclePlus] g;
h[x]
(* Out[3]= f[x]+g[x] *)
If one likes to live on the edge, the same technique can be used with the built-in Plus operator provided it is unprotected first:
Unprotect[Plus];
(x_ + y_)[args___] := x[args] + y[args]
Protect[Plus];
h = f + g;
h[x]
(* Out[7]= f[x]+g[x] *)
I would generally advise against altering the behaviour of built-in functions -- especially one as fundamental as Plus. The reason is that there is no guarantee that user-added definitions to Plus will be respected by other built-in or kernel functions. In some circumstances calls to Plus are optimized, and those optimizations might be not take the user definitions into account. However, this consideration may not affect any particular application so the option is still a valid, if risky, design choice.
I have a very complicated mathematica expression that I'd like to simplify by using a new, possibly dimensionless parameter.
An example of my expression is:
K=a*b*t/((t+f)c*d);
(the actual expression is monstrously large, thousands of characters). I'd like to replace all occurrences of the expression t/(t+f) with p
p=t/(t+f);
The goal here is to find a replacement so that all t's and f's are replaced by p. In this case, the replacement p is a nondimensionalized parameter, so it seems like a good candidate replacement.
I've not been able to figure out how to do this in mathematica (or if its possible). I tried:
eq1= K==a*b*t/((t+f)c*d);
eq2= p==t/(t+f);
Solve[{eq1,eq2},K]
Not surprisingly, this doesn't work. If there were a way to force it to solve for K in terms of p,a,b,c,d, this might work, but I can't figure out how to do that either. Thoughts?
Edit #1 (11/10/11 - 1:30)
[deleted to simplify]
OK, new tact. I've taken p=ton/(ton+toff) and multiplied p by several expressions. I know that p can be completely eliminated. The new expression (in terms of p) is
testEQ = A B p + A^2 B p^2 + (A+B)p^3;
Then I made the substitution for p, and called (normal) FullSimplify, giving me this expression.
testEQ2= (ton (B ton^2 + A^2 B ton (toff + ton) +
A (ton^2 + B (toff + ton)^2)))/(toff + ton)^3;
Finally, I tried all of the suggestions below, except the last (not sure how it works yet!)
Only the eliminate option worked. So I guess I'll try this method from now on. Thank you.
EQ1 = a1 == (ton (B ton^2 + A^2 B ton (toff + ton) +
A (ton^2 + B (toff + ton)^2)))/(toff + ton)^3;
EQ2 = P1 == ton/(ton + toff);
Eliminate[{EQ1, EQ2}, {ton, toff}]
A B P1 + A^2 B P1^2 + (A + B) P1^3 == a1
I should add, if the goal is to make all substitutions that are possible, leaving the rest, I still don't know how to do that. But it appears that if a substitution can completely eliminate a few variables, Eliminate[] works best.
Have you tried this?
K = a*b*t/((t + f) c*d);
Solve[p == t/(t + f), t]
-> {{t -> -((f p)/(-1 + p))}}
Simplify[K /. %[[1]] ]
-> (a b p)/(c d)
EDIT: Oh, and are you aware of Eliminiate?
Eliminate[{eq1, eq2}, {t,f}]
-> a b p == c d K && c != 0 && d != 0
Solve[%, K]
-> {{K -> (a b p)/(c d)}}
EDIT 2: Also, in this simple case, solving for K and t simultaneously seems to do the trick, too:
Solve[{eq1, eq2}, {K, t}]
-> {{K -> (a b p)/(c d), t -> -((f p)/(-1 + p))}}
Something along these lines is discussed in the MathGroup post at
http://forums.wolfram.com/mathgroup/archive/2009/Oct/msg00023.html
(I see it has an apocryphal note that is quite relevant, at least to the author of that post.)
Here is how it might be applied in the example above. For purposes of keeping this self contained I'll repeat the replacement code.
replacementFunction[expr_, rep_, vars_] :=
Module[{num = Numerator[expr], den = Denominator[expr],
hed = Head[expr], base, expon},
If[PolynomialQ[num, vars] &&
PolynomialQ[den, vars] && ! NumberQ[den],
replacementFunction[num, rep, vars]/
replacementFunction[den, rep, vars],
If[hed === Power && Length[expr] == 2,
base = replacementFunction[expr[[1]], rep, vars];
expon = replacementFunction[expr[[2]], rep, vars];
PolynomialReduce[base^expon, rep, vars][[2]],
If[Head[hed] === Symbol &&
MemberQ[Attributes[hed], NumericFunction],
Map[replacementFunction[#, rep, vars] &, expr],
PolynomialReduce[expr, rep, vars][[2]]]]]]
Your example is now as follows. We take the input, and also the replacement. For the latter we make an equivalent polynomial by clearing denominators.
kK = a*b*t/((t + f) c*d);
rep = Numerator[Together[p - t/(t + f)]];
Now we can invoke the replacement. We list the variables we are interested in replacing, treating 'p' as a parameter. This way it will get ordered lower than the others, meaning the replacements will try to remove them in favor of 'p'.
In[127]:= replacementFunction[kK, rep, {t, f}]
Out[127]= (a b p)/(c d)
This approach has a bit of magic in figuring out what should be the listed "variables". Possibly some further tweakage could be done to improve on that. But I believe that, generally, simply not listing the things we want to use as new replacements is the right way to go.
Over the years there have been variants of this idea on MathGroup. It is possible that some others may be better suited to the specific expression(s) you wish to handle.
--- edit ---
The idea behind this is to use PolynomialReduce to do algebraic replacement. That is to say, we do not try for pattern matching but instead use polynomial "canonicalization" a method. But in general we're not working with polynomial inputs. So we apply this idea recursively on PolynomialQ arguments inside NumericQ functions.
Earlier versions of this idea, along with some more explanation, can be found at the note referenced below, as well as in notes it references (how's that for explanatory recursion?).
http://forums.wolfram.com/mathgroup/archive/2006/Aug/msg00283.html
--- end edit ---
--- edit 2 ---
As observed in the wild, this approach is not always a simplifier. It does algebraic replacement, which involves, under the hood, a notion of "term ordering" (roughly, "which things get replaced by which others?") and thus simple variables may expand to longer expressions.
Another form of term rewriting is syntactic replacement via pattern matching, and other responses discuss using that approach. It has a different drawback, insofar as the generality of patterns to consider might become overwhelming. For example, what does one do with k^2/(w + p^4)^3 when the rule is to replace k/(w + p^4) with q? (Specifically, how do we recognize this as being equivalent to (k/(w + p^4))^2*1/(w + p^4)?)
The upshot is one needs to have an idea of what is desired and what methods might be feasible. This of course is generally problem specific.
One thing that occurs is perhaps you want to find and replace all commonly occurring "complicated" expressions with simpler ones. This is referred to as common subexpression elimination (CSE). In Mathematica this can be done using a function called Experimental`OptimizeExpression[]. Here are several links to MathGroup posts that discuss this.
http://forums.wolfram.com/mathgroup/archive/2009/Jul/msg00138.html
http://forums.wolfram.com/mathgroup/archive/2007/Nov/msg00270.html
http://forums.wolfram.com/mathgroup/archive/2006/Sep/msg00300.html
http://forums.wolfram.com/mathgroup/archive/2005/Jan/msg00387.html
http://forums.wolfram.com/mathgroup/archive/2002/Jan/msg00369.html
Here is an example from one of those notes.
InputForm[Experimental`OptimizeExpression[(3 + 3*a^2 + Sqrt[5 + 6*a + 5*a^2] +
a*(4 + Sqrt[5 + 6*a + 5*a^2]))/6]]
Out[206]//InputForm=
Experimental`OptimizedExpression[Block[{Compile`$1, Compile`$3, Compile`$4,
Compile`$5, Compile`$6}, Compile`$1 = a^2; Compile`$3 = 6*a;
Compile`$4 = 5*Compile`$1; Compile`$5 = 5 + Compile`$3 + Compile`$4;
Compile`$6 = Sqrt[Compile`$5]; (3 + 3*Compile`$1 + Compile`$6 +
a*(4 + Compile`$6))/6]]
--- end edit 2 ---
Daniel Lichtblau
K = a*b*t/((t+f)c*d);
FullSimplify[ K,
TransformationFunctions -> {(# /. t/(t + f) -> p &), Automatic}]
(a b p) / (c d)
Corrected update to show another method:
EQ1 = a1 == (ton (B ton^2 + A^2 B ton (toff + ton) +
A (ton^2 + B (toff + ton)^2)))/(toff + ton)^3;
f = # /. ton + toff -> ton/p &;
FullSimplify[f # EQ1]
a1 == p (A B + A^2 B p + (A + B) p^2)
I don't know if this is of any value at this point, but hopefully at least it works.
Mathematica 7.0 seems to dislike having blanks in the denominator. Can anyone explain why this is?
Input:
ClearAll["Global`*"];
(*Without blanks:*)
a^2 / b^2 /. a^2 / b^2 -> d
(*with:*)
a^2 / b^2 /. a^c_ / b^c_ -> d
(*Without blanks:*)
a^2 / b^2 /. (a / b)^2 -> d
(*With:*)
a^2 / b^2 /. (a / b)^c_ -> d
(*Without blanks:*)
a^2 / b^2 /. a^2 * b^(-2) -> d
(*With:*)
a^2 / b^2 /. a^c_ * b^(-c_) -> d
Output:
d
a^2/b^2
d
a^2/b^2
d
a^2/b^2
I'm trying to work this for a more complicated problem. The substitution that I want to make is in an expression of the form:
(a ^ c_. * Coefficient1_. / b ^ c_. / Coefficient2_.) + (a ^ d_. * Coefficient3_. / b ^ d_. / Coefficient4_.)
Where the coefficients may involve sums, products, and quotients of variables that may or may not includea and b.
Possibly relevant:
The FullForm shows that the power in the denominator is stored as a product of -1 and c:
Input:
FullForm[a^2/b^2]
FullForm[a^c_/b^c_]
FullForm[ (a / b)^2 ]
FullForm[(a / b)^c_ ]
FullForm[a^2 * b^(-2) ]
FullForm[a^c_ * b^(-c_)]
Output:
Times[Power[a,2],Power[b,-2]]
Times[Power[a,Pattern[c,Blank[]]],Power[b,Times[-1,Pattern[c,Blank[]]]]]
Times[Power[a,2],Power[b,-2]]
Power[Times[a,Power[b,-1]],Pattern[c,Blank[]]]
Times[Power[a,2],Power[b,-2]]
Times[Power[a,Pattern[c,Blank[]]],Power[b,Times[-1,Pattern[c,Blank[]]]]]
Edit: Bolded change to my actual case.
Generally speaking you should try to avoid doing mathematical manipulation using ReplaceAll which is a structural tool.
As opposed to FullForm, I will use TreeForm to illustrate these expressions:
a^2/b^2 // TreeForm
a^c_/b^c_ // TreeForm
You can see that while these expressions are mathematically similar, they are structurally quite different. You may be able to hammer out a functioning replacement rule for a specific case, but you will usually be better off using the Formula Manipulation (or Polynomial Algebra) tools that Mathematica provides.
If you carefully describe the mathematical manipulation you wish to achieve, I will attempt to provide a better solution.
As belisarius humorously points out in a comment, trying to force Mathematica to "see" or display expressions the way you do is often largely futile. This is one of the reasons that the opening statement above is true.
I agree with everything Mr.Wizard wrote. Having said that, a replacement rule that would work in this specific case would be:
a^2/b^2 /. (Times[Power[a,c_],Power[b,e_]]/; e == -c )-> d
or
a^2/b^2 /. (a^c_ b^e_/; e == -c )-> d
Note that I added the constraint /; e == -c so that I effectively have a -c_ without actually creating the corresponding Times[-1,c_] expression
The primary reason a^2 / b^2 /. a^c_ / b^c_ -> d doesn't work is your using Rule (->) not RuleDelayed (:>). The second reason, as you found with FullForm, is that a/b is interpreted as Times[a, Power[b,-1]], so it is best to not use division. Making these changes,
a^2 / b^2 /. a^n_ b^m_ :> {n,m}
returns {2, -2}. Usually, you'll want to have a default value, so that
a / b^2 /. a^n_. b^m_. :> {n,m}
returns {1,-2}.
Edit: to ensure that the two exponents are equal, requires the addition of the Condition (/;)
a^2 / b^2 /. a^n_. b^m_. /; n == m :> n
Note: by using _. this will also catch a/b.
I need to find a method to transform an expression like
a^(1+m+n) b^(2+2m - 2n)
into
(a b^2)^m (a/b^2)^n (a b^2),
that is, to group terms with the same exponent. I tried using Collect[], etc, but can't get anything to work.
Any suggestions?
Thanks,
Tom
Using Log in combination with CoefficientRules:
exp = a^(1 + m + n) b^(2 + 2 m - 2 n);
Times ## (Exp[#[[2]]]^(Times ## ({n, m}^#[[1]])) & /#
CoefficientRules[PowerExpand[Log[exp]], {n, m}])
output:
a (a/b^2)^n b^2 (a b^2)^m
You can do this, for example:
log[x_*y_] := log[x] + log[y];
log[x_^y_] := y*log[x];
log1 /: a_*log1[b_] := log1[b^a];
log1 /: Plus[x__log1] := log1[Times ## Map[First, {x}]];
exp[HoldPattern[Plus[x__]]] := Times ## Map[exp, {x}];
exp[log1[x_]] := x
and then:
In[58]:= exp[Collect[Expand[log[a^(1+m+n) b^(2+2m-2n)]],{m,n}]]/.log->log1
Out[58]= a (a/b^2)^n b^2 (a b^2)^m
With the help of some very gracious stackoverflow contributors in this post, I have the following new definition for NonCommutativeMultiply (**) in Mathematica:
Unprotect[NonCommutativeMultiply];
ClearAll[NonCommutativeMultiply]
NonCommutativeMultiply[] := 1
NonCommutativeMultiply[___, 0, ___] := 0
NonCommutativeMultiply[a___, 1, b___] := a ** b
NonCommutativeMultiply[a___, i_Integer, b___] := i*a ** b
NonCommutativeMultiply[a_] := a
c___ ** Subscript[a_, i_] ** Subscript[b_, j_] ** d___ /; i > j :=
c ** Subscript[b, j] ** Subscript[a, i] ** d
SetAttributes[NonCommutativeMultiply, {OneIdentity, Flat}]
Protect[NonCommutativeMultiply];
This multiplication is great, however, it does not deal with negative values at the beginning of an expression, i.e.,
a**b**c + (-q)**c**a
should simplify to
a**b**c - q**c**a
and it will not.
In my multiplication, the variable q (and any integer scaler) is commutative; I am still trying to write a SetCommutative function, without success. I am not in desperate need of SetCommutative, it would just be nice.
It would also be helpful if I were able to pull all of the q's to the beginning of each expression, i.e.,:
a**b**c + a**b**q**c**a
should simplify to:
a**b**c + q**a**b**c**a
and similarly, combining these two issues:
a**b**c + a**c**(-q)**b
should simplify to:
a**b**c - q**a**c**b
At the current time, I would like to figure out how to deal with these negative variables at the beginning of an expression and how to pull the q's and (-q)'s to the front as above. I have tried to deal with the two issues mentioned here using ReplaceRepeated (\\.), but so far I have had no success.
All ideas are welcome, thanks...
The key to doing this is to realize that Mathematica represents a-b as a+((-1)*b), as you can see from
In[1]= FullForm[a-b]
Out[2]= Plus[a,Times[-1,b]]
For the first part of your question, all you have to do is add this rule:
NonCommutativeMultiply[Times[-1, a_], b__] := - a ** b
or you can even catch the sign from any position:
NonCommutativeMultiply[a___, Times[-1, b_], c___] := - a ** b ** c
Update -- part 2. The general problem with getting scalars to front is that the pattern _Integer in your current rule will only spot things that are manifestly integers. It wont even spot that q is an integer in a construction like Assuming[{Element[q, Integers]}, a**q**b].
To achieve this, you need to examine assumptions, a process that is probably to expensive to be put in the global transformation table. Instead I would write a transformation function that I could apply manually (and maybe remove the current rule form the global table). Something like this might work:
NCMScalarReduce[e_] := e //. {
NonCommutativeMultiply[a___, i_ /; Simplify#Element[i, Reals],b___]
:> i a ** b
}
The rule used above uses Simplify to explicitly query assumptions, which you can set globally by assigning to $Assumptions or locally by using Assuming:
Assuming[{q \[Element] Reals},
NCMScalarReduce[c ** (-q) ** c]]
returns -q c**c.
HTH
Just a quick answer that repeats some of the comments from the previous question.
You can remove a couple of the definitions and solve all of the parts of this question using the rule that acts on Times[i,c] where i is commutative and c has the default of Sequence[]
Unprotect[NonCommutativeMultiply];
ClearAll[NonCommutativeMultiply]
NonCommutativeMultiply[] := 1
NonCommutativeMultiply[a___, (i:(_Integer|q))(c_:Sequence[]), b___] := i a**Switch[c, 1, Unevaluated[Sequence[]], _, c]**b
NonCommutativeMultiply[a_] := a
c___**Subscript[a_, i_]**Subscript[b_, j_] ** d___ /; i > j := c**Subscript[b, j]**Subscript[a, i]**d
SetAttributes[NonCommutativeMultiply, {OneIdentity, Flat}]
Protect[NonCommutativeMultiply];
This then works as expected
In[]:= a**b**q**(-c)**3**(2 a)**q
Out[]= -6 q^2 a**b**c**a
Note that you can generalize (_Integer|q) to work on more general commutative objects.