Defining a non-commutative algebra - wolfram-mathematica

I'm new to Mathematica, and I'm trying to learn the ropes.
I'm trying to write a little boson algebra engine, with basic useful functions such as non-commutative algebra, normal-ordering and vacuum expectation values.
So, for starters I define the following OpProd[] function,
OpProd[a_ + b_, c_] := OpProd[a, c] + OpProd[b, c];
OpProd[a_, b_ + c_] := OpProd[a, b] + OpProd[a, c];
OpProd[c_, a_] := c a /; NumericQ[c] == True;
OpProd[left__, a_, b_] = OpProd[left, OpProd[a, b]];
which simply defines the basic properties of the algebra, and seems to work fine.
My problem is that I'd like to have an alias for OpProd[], so that whenever I write a^ b^ c^, or any string like that, Mathematica would use OpProd[] to implement the product.
(*Shorthand notation for operator products*)
Unprotect[Times];
\!\(\*OverscriptBox[\(a__\), \(^\)]\)
\!\(\*OverscriptBox[\(b__\), \(^\)]\) := OpProd[a, b];
Protect[Times];
This unfortunately does not seem to work, outputting just
In[10]:=
\!\(\*OverscriptBox[\(a\), \(^\)]\)
\!\(\*OverscriptBox[\(b\), \(^\)]\)
\!\(\*OverscriptBox[\(c\), \(^\)]\)
\!\(\*OverscriptBox[\(d\), \(^\)]\)
\!\(\*OverscriptBox[\(e\), \(^\)]\) // Simplify
Out[10]= OpProd[a, b] OpProd[c, d]
\!\(\*OverscriptBox[\(e\), \(^\)]\)
Any help would be appreciated!

Related

Plotting sigmoid function in mathematica

I am new to Mathematica.
I want to write my own sigmoid function where I can give coefficients to e and x. When plotting, I don't get any output, what could be the problem?
sigmoid_f[x_, a_, b_] := 1/(1 + ae^-bx)
Plot[sigmoid_f[x, 1, 1], {x, -5, 5}]
Thank you for your help!
I expect that when you write
sigmoid_f[x_, a_, b_] := 1/(1 - ae^-bx)
you mean to write
sigmoidf[x_, a_, b_] := 1/(1 - a*E^(-b*x))
where E is the built-in representation of Euler's number and * is the usual text form for the multiplication operator.
Also, as #Alan commented, don't use _ in the names of objects you define.
Mathematica is extremely particular about matters of case and punctuation. In your original expression ae and bx are both names of (presumably unknown) objects.

Stop evaluating an built-in Mathematica function

I am trying to simplify some formulas like
F[a,b,c]*F[a,c,b]+F[c,a,b] /. {a->1,b->2,c->3}
where
F[a,b,c] := LegendreP[a,x]+LegendreP[b,x]*LegendreP[c,x]
And Mathematica can give a polynomial of x.
But I would like to keep all LegendreP instead of expanding it. By setting the HoldAll attribute of LegendreP, I can stop this, but the arguments are also kept, which is not intended.
Could anyone give some advice to solve this problem? Thanks.
Edited: I would like to have a result like this for the above formula (where L=LegendreP)
L[3,x]+L[1,x]*L[2,x]+L[1,x]*L[1,x]+L[3,x]*L[2,x]*L[1,x]+L[1,x]*L[2,x]*L[3,x]+L[‌​3,x]*L[2,x]*L[2,x]*L[3,x]
But I would like to keep all LegendreP instead of expanded it.
Can't you use HoldForm?
F[a_, b_, c_] := HoldForm[LegendreP[a, x] + LegendreP[b, x]*LegendreP[c, x]];
F[a, b, c]*F[a, c, b] + F[c, a, b] /. {a -> 1, b -> 2, c -> 3}
ReleaseHold[%]
Simplify[%]
without knowing fully what you are trying to accomplish, one approach is to simply use some other symbol, eg:
F[a,b,c] := legendreP[a,x]+legendreP[b,x]*legendreP[c,x]
(note the lower case "l" )
When you get to the stage where you want evaluation apply a pattern substitution:
expr /. legendreP->LegendreP

Trying to get Mathematica to approximate an integral

I am trying to get Mathematica to approximate an integral that is a function of various parameters. I don't need it to be extremely precise -- the answer will be a fraction, and 5 digits would be nice, but I'd settle for as few as 2.
The problem is that there is a symbolic integral buried in the main integral, and I can't use NIntegrate on it since its symbolic.
F[x_, c_] := (1 - (1 - x)^c)^c;
a[n_, c_, x_] := F[a[n - 1, c, x], c];
a[0, c_, x_] = x;
MyIntegral[n_,c_] :=
NIntegrate[Integrate[(D[a[n,c,y],y]*y)/(1-a[n,c,x]),{y,x,1}],{x,0,1}]
Mathematica starts hanging when n is greater than 2 and c is greater than 3 or so (generally as both n and c get a little higher).
Are there any tricks for rewriting this expression so that it can be evaluated more easily? I've played with different WorkingPrecision and AccuracyGoal and PrecisionGoal options on the outer NIntegrate, but none of that helps the inner integral, which is where the problem is. In fact, for the higher values of n and c, I can't even get Mathematica to expand the inner derivative, i.e.
Expand[D[a[4,6,y],y]]
hangs.
I am using Mathematica 8 for Students.
If anyone has any tips for how I can get M. to approximate this, I would appreciate it.
Since you only want a numerical output (or that's what you'll get anyway), you can convert the symbolic integration into a numerical one using just NIntegrate as follows:
Clear[a,myIntegral]
a[n_Integer?Positive, c_Integer?Positive, x_] :=
a[n, c, x] = (1 - (1 - a[n - 1, c, x])^c)^c;
a[0, c_Integer, x_] = x;
myIntegral[n_, c_] :=
NIntegrate[D[a[n, c, y], y]*y/(1 - a[n, c, x]), {x, 0, 1}, {y, x, 1},
WorkingPrecision -> 200, PrecisionGoal -> 5]
This is much faster than performing the integration symbolically. Here's a comparison:
yoda:
myIntegral[2,2]//Timing
Out[1]= {0.088441, 0.647376595...}
myIntegral[5,2]//Timing
Out[2]= {1.10486, 0.587502888...}
rcollyer:
MyIntegral[2,2]//Timing
Out[3]= {1.0029, 0.647376}
MyIntegral[5,2]//Timing
Out[4]= {27.1697, 0.587503006...}
(* Obtained with WorkingPrecision->500, PrecisionGoal->5, MaxRecursion->20 *)
Jand's function has timings similar to rcollyer's. Of course, as you increase n, you will have to increase your WorkingPrecision way higher than this, as you've experienced in your previous question. Since you said you only need about 5 digits of precision, I've explicitly set PrecisionGoal to 5. You can change this as per your needs.
To codify the comments, I'd try the following. First, to eliminate infinite recursion with regards to the variable, n, I'd rewrite your functions as
F[x_, c_] := (1 - (1-x)^c)^c;
(* see note below *)
a[n_Integer?Positive, c_, x_] := F[a[n - 1, c, x], c];
a[0, c_, x_] = x;
that way n==0 will actually be a stopping point. The ?Positive form is a PatternTest, and useful for applying additional conditions to the parameters. I suspect the issue is that NIntegrate is re-evaluating the inner Integrate for every value of x, so I'd pull that evaluation out, like
MyIntegral[n_,c_] :=
With[{ int = Integrate[(D[a[n,c,y],y]*y)/(1-a[n,c,x]),{y,x,1}] },
NIntegrate[int,{x,0,1}]
]
where With is one of several scoping constructs specifically for creating local constants.
Your comments indicate that the inner integral takes a long time, have you tried simplifying the integrand as it is a derivative of a times a function of a? It seems like the result of a chain rule expansion to me.
Note: as per Yoda's suggestion in the comments, you can add a cacheing, or memoization, mechanism to a. Change its definition to
d:a[n_Integer?Positive, c_, x_] := d = F[a[n - 1, c, x], c];
The trick here is that in d:a[ ... ], d is a named pattern that is used again in d = F[...] cacheing the value of a for those particular parameter values.

Addition of Functions

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.

NMinimize seems to be on crack

Say I have a crazy function, f, defined like so:
util[x_, y_, c_] := 0.5*Log[c-x] + 0.5*Log[c-y]
cost[x_, y_, l_] := c /. First[NSolve[util[x, y, c+l] == Log[10+l], c]]
prof[x_, y_] := 0.01*Norm[{x,y}, 2]
liquid[x_, y_] := 0.01*Norm[{x,y}, 2]
f[x_, y_, a_, b_] := cost[a, b, liquid[x,y] + liquid[a-x, b-y]] - Max[a,b]
- cost[0,0,0] + prof[x,y] + liquid[x,y] + prof[a-x, b-y] + liquid[a-x, b-y]
Now I call NMinimize like this:
NMinimize[{f[50, 50, k, j], k >= 49, k <= 51, j >= 49, j <= 51}, {j, k}]
Which tells me this:
{-21.0465, {j -> 51., k -> 49.}}
But then if I actually check what f[50,50,49,51] is, it's this:
0.489033
Which is pretty different from the -21.0465 that NMinimize said.
Is this par for the course with NMinimize?
Floating point errors compounding or whatnot?
Any ideas for beating NMinimize (or some such function) into submission?
It certainly seems to be related to your function f not being restricted to numerical arguments, plus the symbolic preprocessing performed by NMinimize. Once you change the signature to
f[x_?NumericQ, y_?NumericQ, a_?NumericQ, b_?NumericQ]:=...
The result is as expected, although it takes considerably longer to get it.
EDIT
We can dig deeper to reveal the true reason. First, note that your f (the original one, args unrestricted) is quite a function:
In[1423]:= f[50,50,49.,51.]
Out[1423]= 0.489033
In[1392]:= f[50,50,k,j]/.{j->51.`,k->49.`}
Out[1392]= -21.0465
The real culprit is NSolve, which gives two ordered solutions:
In[1398]:= NSolve[util[x,y,c+l]==Log[10+l],c]
Out[1398]= {{c->0.5 (-2. l+1. x+1. y-2. Sqrt[100.+20. l+1. l^2+0.25 x^2-0.5 x y+0.25 y^2])},
{c->0.5 (-2. l+1. x+1. y+2. Sqrt[100.+20. l+1. l^2+0.25 x^2-0.5 x y+0.25 y^2])}}
The problem is, what is the ordering. It turns out to be different for symbolic and numeric arguments to NSolve, because in the latter case we don't have any symbols around. This can be seen as:
In[1399]:=
Block[{cost},
cost[x_,y_,l_]:=c/.Last[NSolve[util[x,y,c+l]==Log[10+l],c]];
f[50,50,k,j]/.{j->51.,k->49.}]
Out[1399]= 0.489033
So you really have to settle on what is the right ordering for you, and which solution you really want to pick.

Resources